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 extern int minibuffer_auto_raise
;
65 extern Lisp_Object minibuf_window
;
66 extern Lisp_Object Vlocale_coding_system
;
67 extern int load_in_progress
;
69 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
70 Lisp_Object Qyes_or_no_p_history
;
71 Lisp_Object Qcursor_in_echo_area
;
72 Lisp_Object Qwidget_type
;
73 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
75 extern Lisp_Object Qinput_method_function
;
77 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
79 extern long get_random (void);
80 extern void seed_random (long);
86 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
87 doc
: /* Return the argument unchanged. */)
94 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
95 doc
: /* Return a pseudo-random number.
96 All integers representable in Lisp are equally likely.
97 On most systems, this is 29 bits' worth.
98 With positive integer LIMIT, return random number in interval [0,LIMIT).
99 With argument t, set the random number seed from the current time and pid.
100 Other values of LIMIT are ignored. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (limit
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
144 if (STRINGP (sequence
))
145 XSETFASTINT (val
, SCHARS (sequence
));
146 else if (VECTORP (sequence
))
147 XSETFASTINT (val
, ASIZE (sequence
));
148 else if (CHAR_TABLE_P (sequence
))
149 XSETFASTINT (val
, MAX_CHAR
);
150 else if (BOOL_VECTOR_P (sequence
))
151 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
152 else if (COMPILEDP (sequence
))
153 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
154 else if (CONSP (sequence
))
157 while (CONSP (sequence
))
159 sequence
= XCDR (sequence
);
162 if (!CONSP (sequence
))
165 sequence
= XCDR (sequence
);
170 CHECK_LIST_END (sequence
, sequence
);
172 val
= make_number (i
);
174 else if (NILP (sequence
))
175 XSETFASTINT (val
, 0);
177 wrong_type_argument (Qsequencep
, sequence
);
182 /* This does not check for quits. That is safe since it must terminate. */
184 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
185 doc
: /* Return the length of a list, but avoid error or infinite loop.
186 This function never gets an error. If LIST is not really a list,
187 it returns 0. If LIST is circular, it returns a finite value
188 which is at least the number of distinct elements. */)
192 Lisp_Object tail
, halftail
, length
;
195 /* halftail is used to detect circular lists. */
197 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
199 if (EQ (tail
, halftail
) && len
!= 0)
203 halftail
= XCDR (halftail
);
206 XSETINT (length
, len
);
210 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
211 doc
: /* Return the number of bytes in STRING.
212 If STRING is multibyte, this may be greater than the length of STRING. */)
216 CHECK_STRING (string
);
217 return make_number (SBYTES (string
));
220 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
221 doc
: /* Return t if two strings have identical contents.
222 Case is significant, but text properties are ignored.
223 Symbols are also allowed; their print names are used instead. */)
225 register Lisp_Object s1
, s2
;
228 s1
= SYMBOL_NAME (s1
);
230 s2
= SYMBOL_NAME (s2
);
234 if (SCHARS (s1
) != SCHARS (s2
)
235 || SBYTES (s1
) != SBYTES (s2
)
236 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
241 DEFUN ("compare-strings", Fcompare_strings
,
242 Scompare_strings
, 6, 7, 0,
243 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
244 In string STR1, skip the first START1 characters and stop at END1.
245 In string STR2, skip the first START2 characters and stop at END2.
246 END1 and END2 default to the full lengths of the respective strings.
248 Case is significant in this comparison if IGNORE-CASE is nil.
249 Unibyte strings are converted to multibyte for comparison.
251 The value is t if the strings (or specified portions) match.
252 If string STR1 is less, the value is a negative number N;
253 - 1 - N is the number of characters that match at the beginning.
254 If string STR1 is greater, the value is a positive number N;
255 N - 1 is the number of characters that match at the beginning. */)
256 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
257 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
259 register int end1_char
, end2_char
;
260 register int i1
, i1_byte
, i2
, i2_byte
;
265 start1
= make_number (0);
267 start2
= make_number (0);
268 CHECK_NATNUM (start1
);
269 CHECK_NATNUM (start2
);
278 i1_byte
= string_char_to_byte (str1
, i1
);
279 i2_byte
= string_char_to_byte (str2
, i2
);
281 end1_char
= SCHARS (str1
);
282 if (! NILP (end1
) && end1_char
> XINT (end1
))
283 end1_char
= XINT (end1
);
285 end2_char
= SCHARS (str2
);
286 if (! NILP (end2
) && end2_char
> XINT (end2
))
287 end2_char
= XINT (end2
);
289 while (i1
< end1_char
&& i2
< end2_char
)
291 /* When we find a mismatch, we must compare the
292 characters, not just the bytes. */
295 if (STRING_MULTIBYTE (str1
))
296 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
299 c1
= SREF (str1
, i1
++);
300 MAKE_CHAR_MULTIBYTE (c1
);
303 if (STRING_MULTIBYTE (str2
))
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
307 c2
= SREF (str2
, i2
++);
308 MAKE_CHAR_MULTIBYTE (c2
);
314 if (! NILP (ignore_case
))
318 tem
= Fupcase (make_number (c1
));
320 tem
= Fupcase (make_number (c2
));
327 /* Note that I1 has already been incremented
328 past the character that we are comparing;
329 hence we don't add or subtract 1 here. */
331 return make_number (- i1
+ XINT (start1
));
333 return make_number (i1
- XINT (start1
));
337 return make_number (i1
- XINT (start1
) + 1);
339 return make_number (- i1
+ XINT (start1
) - 1);
344 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
345 doc
: /* Return t if first arg string is less than second in lexicographic order.
347 Symbols are also allowed; their print names are used instead. */)
349 register Lisp_Object s1
, s2
;
352 register int i1
, i1_byte
, i2
, i2_byte
;
355 s1
= SYMBOL_NAME (s1
);
357 s2
= SYMBOL_NAME (s2
);
361 i1
= i1_byte
= i2
= i2_byte
= 0;
364 if (end
> SCHARS (s2
))
369 /* When we find a mismatch, we must compare the
370 characters, not just the bytes. */
373 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
374 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
377 return c1
< c2
? Qt
: Qnil
;
379 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
383 /* "gcc -O3" enables automatic function inlining, which optimizes out
384 the arguments for the invocations of this function, whereas it
385 expects these values on the stack. */
386 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
) __attribute__((noinline
));
387 #else /* !__GNUC__ */
388 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
);
393 concat2 (Lisp_Object s1
, Lisp_Object s2
)
398 return concat (2, args
, Lisp_String
, 0);
403 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
409 return concat (3, args
, Lisp_String
, 0);
412 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
413 doc
: /* Concatenate all the arguments and make the result a list.
414 The result is a list whose elements are the elements of all the arguments.
415 Each argument may be a list, vector or string.
416 The last argument is not copied, just used as the tail of the new list.
417 usage: (append &rest SEQUENCES) */)
422 return concat (nargs
, args
, Lisp_Cons
, 1);
425 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
426 doc
: /* Concatenate all the arguments and make the result a string.
427 The result is a string whose elements are the elements of all the arguments.
428 Each argument may be a string or a list or vector of characters (integers).
429 usage: (concat &rest SEQUENCES) */)
434 return concat (nargs
, args
, Lisp_String
, 0);
437 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
438 doc
: /* Concatenate all the arguments and make the result a vector.
439 The result is a vector whose elements are the elements of all the arguments.
440 Each argument may be a list, vector or string.
441 usage: (vconcat &rest SEQUENCES) */)
446 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
450 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
451 doc
: /* Return a copy of a list, vector, string or char-table.
452 The elements of a list or vector are not copied; they are shared
453 with the original. */)
457 if (NILP (arg
)) return arg
;
459 if (CHAR_TABLE_P (arg
))
461 return copy_char_table (arg
);
464 if (BOOL_VECTOR_P (arg
))
468 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
469 / BOOL_VECTOR_BITS_PER_CHAR
);
471 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
472 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
477 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
478 wrong_type_argument (Qsequencep
, arg
);
480 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
483 /* This structure holds information of an argument of `concat' that is
484 a string and has text properties to be copied. */
487 int argnum
; /* refer to ARGS (arguments of `concat') */
488 int from
; /* refer to ARGS[argnum] (argument string) */
489 int to
; /* refer to VAL (the target string) */
493 concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)
496 register Lisp_Object tail
;
497 register Lisp_Object
this;
499 int toindex_byte
= 0;
500 register int result_len
;
501 register int result_len_byte
;
503 Lisp_Object last_tail
;
506 /* When we make a multibyte string, we can't copy text properties
507 while concatinating each string because the length of resulting
508 string can't be decided until we finish the whole concatination.
509 So, we record strings that have text properties to be copied
510 here, and copy the text properties after the concatination. */
511 struct textprop_rec
*textprops
= NULL
;
512 /* Number of elements in textprops. */
513 int num_textprops
= 0;
518 /* In append, the last arg isn't treated like the others */
519 if (last_special
&& nargs
> 0)
522 last_tail
= args
[nargs
];
527 /* Check each argument. */
528 for (argnum
= 0; argnum
< nargs
; argnum
++)
531 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
532 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
533 wrong_type_argument (Qsequencep
, this);
536 /* Compute total length in chars of arguments in RESULT_LEN.
537 If desired output is a string, also compute length in bytes
538 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
539 whether the result should be a multibyte string. */
543 for (argnum
= 0; argnum
< nargs
; argnum
++)
547 len
= XFASTINT (Flength (this));
548 if (target_type
== Lisp_String
)
550 /* We must count the number of bytes needed in the string
551 as well as the number of characters. */
557 for (i
= 0; i
< len
; i
++)
560 CHECK_CHARACTER (ch
);
561 this_len_byte
= CHAR_BYTES (XINT (ch
));
562 result_len_byte
+= this_len_byte
;
563 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
566 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
567 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
568 else if (CONSP (this))
569 for (; CONSP (this); this = XCDR (this))
572 CHECK_CHARACTER (ch
);
573 this_len_byte
= CHAR_BYTES (XINT (ch
));
574 result_len_byte
+= this_len_byte
;
575 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
578 else if (STRINGP (this))
580 if (STRING_MULTIBYTE (this))
583 result_len_byte
+= SBYTES (this);
586 result_len_byte
+= count_size_as_multibyte (SDATA (this),
593 error ("String overflow");
596 if (! some_multibyte
)
597 result_len_byte
= result_len
;
599 /* Create the output object. */
600 if (target_type
== Lisp_Cons
)
601 val
= Fmake_list (make_number (result_len
), Qnil
);
602 else if (target_type
== Lisp_Vectorlike
)
603 val
= Fmake_vector (make_number (result_len
), Qnil
);
604 else if (some_multibyte
)
605 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
607 val
= make_uninit_string (result_len
);
609 /* In `append', if all but last arg are nil, return last arg. */
610 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
613 /* Copy the contents of the args into the result. */
615 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
617 toindex
= 0, toindex_byte
= 0;
621 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
623 for (argnum
= 0; argnum
< nargs
; argnum
++)
627 register unsigned int thisindex
= 0;
628 register unsigned int thisindex_byte
= 0;
632 thislen
= Flength (this), thisleni
= XINT (thislen
);
634 /* Between strings of the same kind, copy fast. */
635 if (STRINGP (this) && STRINGP (val
)
636 && STRING_MULTIBYTE (this) == some_multibyte
)
638 int thislen_byte
= SBYTES (this);
640 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
642 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
644 textprops
[num_textprops
].argnum
= argnum
;
645 textprops
[num_textprops
].from
= 0;
646 textprops
[num_textprops
++].to
= toindex
;
648 toindex_byte
+= thislen_byte
;
651 /* Copy a single-byte string to a multibyte string. */
652 else if (STRINGP (this) && STRINGP (val
))
654 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
656 textprops
[num_textprops
].argnum
= argnum
;
657 textprops
[num_textprops
].from
= 0;
658 textprops
[num_textprops
++].to
= toindex
;
660 toindex_byte
+= copy_text (SDATA (this),
661 SDATA (val
) + toindex_byte
,
662 SCHARS (this), 0, 1);
666 /* Copy element by element. */
669 register Lisp_Object elt
;
671 /* Fetch next element of `this' arg into `elt', or break if
672 `this' is exhausted. */
673 if (NILP (this)) break;
675 elt
= XCAR (this), this = XCDR (this);
676 else if (thisindex
>= thisleni
)
678 else if (STRINGP (this))
681 if (STRING_MULTIBYTE (this))
683 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
686 XSETFASTINT (elt
, c
);
690 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
692 && !ASCII_CHAR_P (XINT (elt
))
693 && XINT (elt
) < 0400)
695 c
= BYTE8_TO_CHAR (XINT (elt
));
700 else if (BOOL_VECTOR_P (this))
703 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
704 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
712 elt
= AREF (this, thisindex
);
716 /* Store this element into the result. */
723 else if (VECTORP (val
))
725 ASET (val
, toindex
, elt
);
732 toindex_byte
+= CHAR_STRING (XINT (elt
),
733 SDATA (val
) + toindex_byte
);
735 SSET (val
, toindex_byte
++, XINT (elt
));
741 XSETCDR (prev
, last_tail
);
743 if (num_textprops
> 0)
746 int last_to_end
= -1;
748 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
750 this = args
[textprops
[argnum
].argnum
];
751 props
= text_property_list (this,
753 make_number (SCHARS (this)),
755 /* If successive arguments have properites, be sure that the
756 value of `composition' property be the copy. */
757 if (last_to_end
== textprops
[argnum
].to
)
758 make_composition_value_copy (props
);
759 add_text_properties_from_list (val
, props
,
760 make_number (textprops
[argnum
].to
));
761 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
769 static Lisp_Object string_char_byte_cache_string
;
770 static EMACS_INT string_char_byte_cache_charpos
;
771 static EMACS_INT string_char_byte_cache_bytepos
;
774 clear_string_char_byte_cache (void)
776 string_char_byte_cache_string
= Qnil
;
779 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
782 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
785 EMACS_INT best_below
, best_below_byte
;
786 EMACS_INT best_above
, best_above_byte
;
788 best_below
= best_below_byte
= 0;
789 best_above
= SCHARS (string
);
790 best_above_byte
= SBYTES (string
);
791 if (best_above
== best_above_byte
)
794 if (EQ (string
, string_char_byte_cache_string
))
796 if (string_char_byte_cache_charpos
< char_index
)
798 best_below
= string_char_byte_cache_charpos
;
799 best_below_byte
= string_char_byte_cache_bytepos
;
803 best_above
= string_char_byte_cache_charpos
;
804 best_above_byte
= string_char_byte_cache_bytepos
;
808 if (char_index
- best_below
< best_above
- char_index
)
810 unsigned char *p
= SDATA (string
) + best_below_byte
;
812 while (best_below
< char_index
)
814 p
+= BYTES_BY_CHAR_HEAD (*p
);
817 i_byte
= p
- SDATA (string
);
821 unsigned char *p
= SDATA (string
) + best_above_byte
;
823 while (best_above
> char_index
)
826 while (!CHAR_HEAD_P (*p
)) p
--;
829 i_byte
= p
- SDATA (string
);
832 string_char_byte_cache_bytepos
= i_byte
;
833 string_char_byte_cache_charpos
= char_index
;
834 string_char_byte_cache_string
= string
;
839 /* Return the character index corresponding to BYTE_INDEX in STRING. */
842 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
845 EMACS_INT best_below
, best_below_byte
;
846 EMACS_INT best_above
, best_above_byte
;
848 best_below
= best_below_byte
= 0;
849 best_above
= SCHARS (string
);
850 best_above_byte
= SBYTES (string
);
851 if (best_above
== best_above_byte
)
854 if (EQ (string
, string_char_byte_cache_string
))
856 if (string_char_byte_cache_bytepos
< byte_index
)
858 best_below
= string_char_byte_cache_charpos
;
859 best_below_byte
= string_char_byte_cache_bytepos
;
863 best_above
= string_char_byte_cache_charpos
;
864 best_above_byte
= string_char_byte_cache_bytepos
;
868 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
870 unsigned char *p
= SDATA (string
) + best_below_byte
;
871 unsigned char *pend
= SDATA (string
) + byte_index
;
875 p
+= BYTES_BY_CHAR_HEAD (*p
);
879 i_byte
= p
- SDATA (string
);
883 unsigned char *p
= SDATA (string
) + best_above_byte
;
884 unsigned char *pbeg
= SDATA (string
) + byte_index
;
889 while (!CHAR_HEAD_P (*p
)) p
--;
893 i_byte
= p
- SDATA (string
);
896 string_char_byte_cache_bytepos
= i_byte
;
897 string_char_byte_cache_charpos
= i
;
898 string_char_byte_cache_string
= string
;
903 /* Convert STRING to a multibyte string. */
906 string_make_multibyte (Lisp_Object string
)
913 if (STRING_MULTIBYTE (string
))
916 nbytes
= count_size_as_multibyte (SDATA (string
),
918 /* If all the chars are ASCII, they won't need any more bytes
919 once converted. In that case, we can return STRING itself. */
920 if (nbytes
== SBYTES (string
))
923 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
924 copy_text (SDATA (string
), buf
, SBYTES (string
),
927 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
934 /* Convert STRING (if unibyte) to a multibyte string without changing
935 the number of characters. Characters 0200 trough 0237 are
936 converted to eight-bit characters. */
939 string_to_multibyte (Lisp_Object string
)
946 if (STRING_MULTIBYTE (string
))
949 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
950 /* If all the chars are ASCII, they won't need any more bytes once
952 if (nbytes
== SBYTES (string
))
953 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
955 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
956 bcopy (SDATA (string
), buf
, SBYTES (string
));
957 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
959 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
966 /* Convert STRING to a single-byte string. */
969 string_make_unibyte (Lisp_Object string
)
976 if (! STRING_MULTIBYTE (string
))
979 nchars
= SCHARS (string
);
981 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
982 copy_text (SDATA (string
), buf
, SBYTES (string
),
985 ret
= make_unibyte_string (buf
, nchars
);
991 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
993 doc
: /* Return the multibyte equivalent of STRING.
994 If STRING is unibyte and contains non-ASCII characters, the function
995 `unibyte-char-to-multibyte' is used to convert each unibyte character
996 to a multibyte character. In this case, the returned string is a
997 newly created string with no text properties. If STRING is multibyte
998 or entirely ASCII, it is returned unchanged. In particular, when
999 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1000 \(When the characters are all ASCII, Emacs primitives will treat the
1001 string the same way whether it is unibyte or multibyte.) */)
1005 CHECK_STRING (string
);
1007 return string_make_multibyte (string
);
1010 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1012 doc
: /* Return the unibyte equivalent of STRING.
1013 Multibyte character codes are converted to unibyte according to
1014 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1015 If the lookup in the translation table fails, this function takes just
1016 the low 8 bits of each character. */)
1020 CHECK_STRING (string
);
1022 return string_make_unibyte (string
);
1025 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1027 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1028 If STRING is unibyte, the result is STRING itself.
1029 Otherwise it is a newly created string, with no text properties.
1030 If STRING is multibyte and contains a character of charset
1031 `eight-bit', it is converted to the corresponding single byte. */)
1035 CHECK_STRING (string
);
1037 if (STRING_MULTIBYTE (string
))
1039 int bytes
= SBYTES (string
);
1040 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1042 bcopy (SDATA (string
), str
, bytes
);
1043 bytes
= str_as_unibyte (str
, bytes
);
1044 string
= make_unibyte_string (str
, bytes
);
1050 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1052 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1053 If STRING is multibyte, the result is STRING itself.
1054 Otherwise it is a newly created string, with no text properties.
1056 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1057 part of a correct utf-8 sequence), it is converted to the corresponding
1058 multibyte character of charset `eight-bit'.
1059 See also `string-to-multibyte'.
1061 Beware, this often doesn't really do what you think it does.
1062 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1063 If you're not sure, whether to use `string-as-multibyte' or
1064 `string-to-multibyte', use `string-to-multibyte'. */)
1068 CHECK_STRING (string
);
1070 if (! STRING_MULTIBYTE (string
))
1072 Lisp_Object new_string
;
1075 parse_str_as_multibyte (SDATA (string
),
1078 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1079 bcopy (SDATA (string
), SDATA (new_string
),
1081 if (nbytes
!= SBYTES (string
))
1082 str_as_multibyte (SDATA (new_string
), nbytes
,
1083 SBYTES (string
), NULL
);
1084 string
= new_string
;
1085 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1090 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1092 doc
: /* Return a multibyte string with the same individual chars as STRING.
1093 If STRING is multibyte, the result is STRING itself.
1094 Otherwise it is a newly created string, with no text properties.
1096 If STRING is unibyte and contains an 8-bit byte, it is converted to
1097 the corresponding multibyte character of charset `eight-bit'.
1099 This differs from `string-as-multibyte' by converting each byte of a correct
1100 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1101 correct sequence. */)
1105 CHECK_STRING (string
);
1107 return string_to_multibyte (string
);
1110 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1112 doc
: /* Return a unibyte string with the same individual chars as STRING.
1113 If STRING is unibyte, the result is STRING itself.
1114 Otherwise it is a newly created string, with no text properties,
1115 where each `eight-bit' character is converted to the corresponding byte.
1116 If STRING contains a non-ASCII, non-`eight-bit' character,
1117 an error is signaled. */)
1121 CHECK_STRING (string
);
1123 if (STRING_MULTIBYTE (string
))
1125 EMACS_INT chars
= SCHARS (string
);
1126 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1127 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1129 if (converted
< chars
)
1130 error ("Can't convert the %dth character to unibyte", converted
);
1131 string
= make_unibyte_string (str
, chars
);
1138 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1139 doc
: /* Return a copy of ALIST.
1140 This is an alist which represents the same mapping from objects to objects,
1141 but does not share the alist structure with ALIST.
1142 The objects mapped (cars and cdrs of elements of the alist)
1143 are shared, however.
1144 Elements of ALIST that are not conses are also shared. */)
1148 register Lisp_Object tem
;
1153 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1154 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1156 register Lisp_Object car
;
1160 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1165 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1166 doc
: /* Return a new string whose contents are a substring of STRING.
1167 The returned string consists of the characters between index FROM
1168 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1169 zero-indexed: 0 means the first character of STRING. Negative values
1170 are counted from the end of STRING. If TO is nil, the substring runs
1171 to the end of STRING.
1173 The STRING argument may also be a vector. In that case, the return
1174 value is a new vector that contains the elements between index FROM
1175 \(inclusive) and index TO (exclusive) of that vector argument. */)
1178 register Lisp_Object from
, to
;
1183 int from_char
, to_char
;
1184 int from_byte
= 0, to_byte
= 0;
1186 CHECK_VECTOR_OR_STRING (string
);
1187 CHECK_NUMBER (from
);
1189 if (STRINGP (string
))
1191 size
= SCHARS (string
);
1192 size_byte
= SBYTES (string
);
1195 size
= ASIZE (string
);
1200 to_byte
= size_byte
;
1206 to_char
= XINT (to
);
1210 if (STRINGP (string
))
1211 to_byte
= string_char_to_byte (string
, to_char
);
1214 from_char
= XINT (from
);
1217 if (STRINGP (string
))
1218 from_byte
= string_char_to_byte (string
, from_char
);
1220 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1221 args_out_of_range_3 (string
, make_number (from_char
),
1222 make_number (to_char
));
1224 if (STRINGP (string
))
1226 res
= make_specified_string (SDATA (string
) + from_byte
,
1227 to_char
- from_char
, to_byte
- from_byte
,
1228 STRING_MULTIBYTE (string
));
1229 copy_text_properties (make_number (from_char
), make_number (to_char
),
1230 string
, make_number (0), res
, Qnil
);
1233 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1239 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1240 doc
: /* Return a substring of STRING, without text properties.
1241 It starts at index FROM and ending before TO.
1242 TO may be nil or omitted; then the substring runs to the end of STRING.
1243 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1244 If FROM or TO is negative, it counts from the end.
1246 With one argument, just copy STRING without its properties. */)
1249 register Lisp_Object from
, to
;
1251 int size
, size_byte
;
1252 int from_char
, to_char
;
1253 int from_byte
, to_byte
;
1255 CHECK_STRING (string
);
1257 size
= SCHARS (string
);
1258 size_byte
= SBYTES (string
);
1261 from_char
= from_byte
= 0;
1264 CHECK_NUMBER (from
);
1265 from_char
= XINT (from
);
1269 from_byte
= string_char_to_byte (string
, from_char
);
1275 to_byte
= size_byte
;
1281 to_char
= XINT (to
);
1285 to_byte
= string_char_to_byte (string
, to_char
);
1288 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1289 args_out_of_range_3 (string
, make_number (from_char
),
1290 make_number (to_char
));
1292 return make_specified_string (SDATA (string
) + from_byte
,
1293 to_char
- from_char
, to_byte
- from_byte
,
1294 STRING_MULTIBYTE (string
));
1297 /* Extract a substring of STRING, giving start and end positions
1298 both in characters and in bytes. */
1301 substring_both (Lisp_Object string
, int from
, int from_byte
, int to
, int to_byte
)
1307 CHECK_VECTOR_OR_STRING (string
);
1309 if (STRINGP (string
))
1311 size
= SCHARS (string
);
1312 size_byte
= SBYTES (string
);
1315 size
= ASIZE (string
);
1317 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1318 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1320 if (STRINGP (string
))
1322 res
= make_specified_string (SDATA (string
) + from_byte
,
1323 to
- from
, to_byte
- from_byte
,
1324 STRING_MULTIBYTE (string
));
1325 copy_text_properties (make_number (from
), make_number (to
),
1326 string
, make_number (0), res
, Qnil
);
1329 res
= Fvector (to
- from
, &AREF (string
, from
));
1334 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1335 doc
: /* Take cdr N times on LIST, returns the result. */)
1338 register Lisp_Object list
;
1340 register int i
, num
;
1343 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1346 CHECK_LIST_CONS (list
, list
);
1352 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1353 doc
: /* Return the Nth element of LIST.
1354 N counts from zero. If LIST is not that long, nil is returned. */)
1356 Lisp_Object n
, list
;
1358 return Fcar (Fnthcdr (n
, list
));
1361 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1362 doc
: /* Return element of SEQUENCE at index N. */)
1364 register Lisp_Object sequence
, n
;
1367 if (CONSP (sequence
) || NILP (sequence
))
1368 return Fcar (Fnthcdr (n
, sequence
));
1370 /* Faref signals a "not array" error, so check here. */
1371 CHECK_ARRAY (sequence
, Qsequencep
);
1372 return Faref (sequence
, n
);
1375 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1376 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1377 The value is actually the tail of LIST whose car is ELT. */)
1379 register Lisp_Object elt
;
1382 register Lisp_Object tail
;
1383 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1385 register Lisp_Object tem
;
1386 CHECK_LIST_CONS (tail
, list
);
1388 if (! NILP (Fequal (elt
, tem
)))
1395 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1396 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1397 The value is actually the tail of LIST whose car is ELT. */)
1399 register Lisp_Object elt
, list
;
1403 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1407 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1411 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1422 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1423 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1424 The value is actually the tail of LIST whose car is ELT. */)
1426 register Lisp_Object elt
;
1429 register Lisp_Object tail
;
1432 return Fmemq (elt
, list
);
1434 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1436 register Lisp_Object tem
;
1437 CHECK_LIST_CONS (tail
, list
);
1439 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1446 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1447 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1448 The value is actually the first element of LIST whose car is KEY.
1449 Elements of LIST that are not conses are ignored. */)
1451 Lisp_Object key
, list
;
1456 || (CONSP (XCAR (list
))
1457 && EQ (XCAR (XCAR (list
)), key
)))
1462 || (CONSP (XCAR (list
))
1463 && EQ (XCAR (XCAR (list
)), key
)))
1468 || (CONSP (XCAR (list
))
1469 && EQ (XCAR (XCAR (list
)), key
)))
1479 /* Like Fassq but never report an error and do not allow quits.
1480 Use only on lists known never to be circular. */
1483 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1486 && (!CONSP (XCAR (list
))
1487 || !EQ (XCAR (XCAR (list
)), key
)))
1490 return CAR_SAFE (list
);
1493 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1494 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1495 The value is actually the first element of LIST whose car equals KEY. */)
1497 Lisp_Object key
, list
;
1504 || (CONSP (XCAR (list
))
1505 && (car
= XCAR (XCAR (list
)),
1506 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1511 || (CONSP (XCAR (list
))
1512 && (car
= XCAR (XCAR (list
)),
1513 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1518 || (CONSP (XCAR (list
))
1519 && (car
= XCAR (XCAR (list
)),
1520 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1530 /* Like Fassoc but never report an error and do not allow quits.
1531 Use only on lists known never to be circular. */
1534 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1537 && (!CONSP (XCAR (list
))
1538 || (!EQ (XCAR (XCAR (list
)), key
)
1539 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1542 return CONSP (list
) ? XCAR (list
) : Qnil
;
1545 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1546 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1547 The value is actually the first element of LIST whose cdr is KEY. */)
1549 register Lisp_Object key
;
1555 || (CONSP (XCAR (list
))
1556 && EQ (XCDR (XCAR (list
)), key
)))
1561 || (CONSP (XCAR (list
))
1562 && EQ (XCDR (XCAR (list
)), key
)))
1567 || (CONSP (XCAR (list
))
1568 && EQ (XCDR (XCAR (list
)), key
)))
1578 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1579 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1580 The value is actually the first element of LIST whose cdr equals KEY. */)
1582 Lisp_Object key
, list
;
1589 || (CONSP (XCAR (list
))
1590 && (cdr
= XCDR (XCAR (list
)),
1591 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1596 || (CONSP (XCAR (list
))
1597 && (cdr
= XCDR (XCAR (list
)),
1598 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1603 || (CONSP (XCAR (list
))
1604 && (cdr
= XCDR (XCAR (list
)),
1605 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1615 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1616 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1617 The modified LIST is returned. Comparison is done with `eq'.
1618 If the first member of LIST is ELT, there is no way to remove it by side effect;
1619 therefore, write `(setq foo (delq element foo))'
1620 to be sure of changing the value of `foo'. */)
1622 register Lisp_Object elt
;
1625 register Lisp_Object tail
, prev
;
1626 register Lisp_Object tem
;
1630 while (!NILP (tail
))
1632 CHECK_LIST_CONS (tail
, list
);
1639 Fsetcdr (prev
, XCDR (tail
));
1649 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1650 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1651 SEQ must be a list, a vector, or a string.
1652 The modified SEQ is returned. Comparison is done with `equal'.
1653 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1654 is not a side effect; it is simply using a different sequence.
1655 Therefore, write `(setq foo (delete element foo))'
1656 to be sure of changing the value of `foo'. */)
1658 Lisp_Object elt
, seq
;
1664 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1665 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1668 if (n
!= ASIZE (seq
))
1670 struct Lisp_Vector
*p
= allocate_vector (n
);
1672 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1673 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1674 p
->contents
[n
++] = AREF (seq
, i
);
1676 XSETVECTOR (seq
, p
);
1679 else if (STRINGP (seq
))
1681 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1684 for (i
= nchars
= nbytes
= ibyte
= 0;
1686 ++i
, ibyte
+= cbytes
)
1688 if (STRING_MULTIBYTE (seq
))
1690 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1691 cbytes
= CHAR_BYTES (c
);
1699 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1706 if (nchars
!= SCHARS (seq
))
1710 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1711 if (!STRING_MULTIBYTE (seq
))
1712 STRING_SET_UNIBYTE (tem
);
1714 for (i
= nchars
= nbytes
= ibyte
= 0;
1716 ++i
, ibyte
+= cbytes
)
1718 if (STRING_MULTIBYTE (seq
))
1720 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1721 cbytes
= CHAR_BYTES (c
);
1729 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1731 unsigned char *from
= SDATA (seq
) + ibyte
;
1732 unsigned char *to
= SDATA (tem
) + nbytes
;
1738 for (n
= cbytes
; n
--; )
1748 Lisp_Object tail
, prev
;
1750 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1752 CHECK_LIST_CONS (tail
, seq
);
1754 if (!NILP (Fequal (elt
, XCAR (tail
))))
1759 Fsetcdr (prev
, XCDR (tail
));
1770 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1771 doc
: /* Reverse LIST by modifying cdr pointers.
1772 Return the reversed list. */)
1776 register Lisp_Object prev
, tail
, next
;
1778 if (NILP (list
)) return list
;
1781 while (!NILP (tail
))
1784 CHECK_LIST_CONS (tail
, list
);
1786 Fsetcdr (tail
, prev
);
1793 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1794 doc
: /* Reverse LIST, copying. Return the reversed list.
1795 See also the function `nreverse', which is used more often. */)
1801 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1804 new = Fcons (XCAR (list
), new);
1806 CHECK_LIST_END (list
, list
);
1810 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1812 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1813 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1814 Returns the sorted list. LIST is modified by side effects.
1815 PREDICATE is called with two elements of LIST, and should return non-nil
1816 if the first element should sort before the second. */)
1818 Lisp_Object list
, predicate
;
1820 Lisp_Object front
, back
;
1821 register Lisp_Object len
, tem
;
1822 struct gcpro gcpro1
, gcpro2
;
1823 register int length
;
1826 len
= Flength (list
);
1827 length
= XINT (len
);
1831 XSETINT (len
, (length
/ 2) - 1);
1832 tem
= Fnthcdr (len
, list
);
1834 Fsetcdr (tem
, Qnil
);
1836 GCPRO2 (front
, back
);
1837 front
= Fsort (front
, predicate
);
1838 back
= Fsort (back
, predicate
);
1840 return merge (front
, back
, predicate
);
1844 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1847 register Lisp_Object tail
;
1849 register Lisp_Object l1
, l2
;
1850 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1857 /* It is sufficient to protect org_l1 and org_l2.
1858 When l1 and l2 are updated, we copy the new values
1859 back into the org_ vars. */
1860 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1880 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1896 Fsetcdr (tail
, tem
);
1902 /* This does not check for quits. That is safe since it must terminate. */
1904 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1905 doc
: /* Extract a value from a property list.
1906 PLIST is a property list, which is a list of the form
1907 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1908 corresponding to the given PROP, or nil if PROP is not one of the
1909 properties on the list. This function never signals an error. */)
1914 Lisp_Object tail
, halftail
;
1916 /* halftail is used to detect circular lists. */
1917 tail
= halftail
= plist
;
1918 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1920 if (EQ (prop
, XCAR (tail
)))
1921 return XCAR (XCDR (tail
));
1923 tail
= XCDR (XCDR (tail
));
1924 halftail
= XCDR (halftail
);
1925 if (EQ (tail
, halftail
))
1928 #if 0 /* Unsafe version. */
1929 /* This function can be called asynchronously
1930 (setup_coding_system). Don't QUIT in that case. */
1931 if (!interrupt_input_blocked
)
1939 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1940 doc
: /* Return the value of SYMBOL's PROPNAME property.
1941 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1943 Lisp_Object symbol
, propname
;
1945 CHECK_SYMBOL (symbol
);
1946 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1949 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1950 doc
: /* Change value in PLIST of PROP to VAL.
1951 PLIST is a property list, which is a list of the form
1952 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1953 If PROP is already a property on the list, its value is set to VAL,
1954 otherwise the new PROP VAL pair is added. The new plist is returned;
1955 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1956 The PLIST is modified by side effects. */)
1959 register Lisp_Object prop
;
1962 register Lisp_Object tail
, prev
;
1963 Lisp_Object newcell
;
1965 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1966 tail
= XCDR (XCDR (tail
)))
1968 if (EQ (prop
, XCAR (tail
)))
1970 Fsetcar (XCDR (tail
), val
);
1977 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1981 Fsetcdr (XCDR (prev
), newcell
);
1985 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1986 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1987 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1988 (symbol
, propname
, value
)
1989 Lisp_Object symbol
, propname
, value
;
1991 CHECK_SYMBOL (symbol
);
1992 XSYMBOL (symbol
)->plist
1993 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1997 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1998 doc
: /* Extract a value from a property list, comparing with `equal'.
1999 PLIST is a property list, which is a list of the form
2000 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2001 corresponding to the given PROP, or nil if PROP is not
2002 one of the properties on the list. */)
2010 CONSP (tail
) && CONSP (XCDR (tail
));
2011 tail
= XCDR (XCDR (tail
)))
2013 if (! NILP (Fequal (prop
, XCAR (tail
))))
2014 return XCAR (XCDR (tail
));
2019 CHECK_LIST_END (tail
, prop
);
2024 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2025 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2026 PLIST is a property list, which is a list of the form
2027 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2028 If PROP is already a property on the list, its value is set to VAL,
2029 otherwise the new PROP VAL pair is added. The new plist is returned;
2030 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2031 The PLIST is modified by side effects. */)
2034 register Lisp_Object prop
;
2037 register Lisp_Object tail
, prev
;
2038 Lisp_Object newcell
;
2040 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2041 tail
= XCDR (XCDR (tail
)))
2043 if (! NILP (Fequal (prop
, XCAR (tail
))))
2045 Fsetcar (XCDR (tail
), val
);
2052 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2056 Fsetcdr (XCDR (prev
), newcell
);
2060 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2061 doc
: /* Return t if the two args are the same Lisp object.
2062 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2064 Lisp_Object obj1
, obj2
;
2067 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2069 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2072 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2073 doc
: /* Return t if two Lisp objects have similar structure and contents.
2074 They must have the same data type.
2075 Conses are compared by comparing the cars and the cdrs.
2076 Vectors and strings are compared element by element.
2077 Numbers are compared by value, but integers cannot equal floats.
2078 (Use `=' if you want integers and floats to be able to be equal.)
2079 Symbols must match exactly. */)
2081 register Lisp_Object o1
, o2
;
2083 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2086 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2087 doc
: /* Return t if two Lisp objects have similar structure and contents.
2088 This is like `equal' except that it compares the text properties
2089 of strings. (`equal' ignores text properties.) */)
2091 register Lisp_Object o1
, o2
;
2093 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2096 /* DEPTH is current depth of recursion. Signal an error if it
2098 PROPS, if non-nil, means compare string text properties too. */
2101 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2104 error ("Stack overflow in equal");
2110 if (XTYPE (o1
) != XTYPE (o2
))
2119 d1
= extract_float (o1
);
2120 d2
= extract_float (o2
);
2121 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2122 though they are not =. */
2123 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2127 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2134 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2138 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2140 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2143 o1
= XOVERLAY (o1
)->plist
;
2144 o2
= XOVERLAY (o2
)->plist
;
2149 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2150 && (XMARKER (o1
)->buffer
== 0
2151 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2155 case Lisp_Vectorlike
:
2158 EMACS_INT size
= ASIZE (o1
);
2159 /* Pseudovectors have the type encoded in the size field, so this test
2160 actually checks that the objects have the same type as well as the
2162 if (ASIZE (o2
) != size
)
2164 /* Boolvectors are compared much like strings. */
2165 if (BOOL_VECTOR_P (o1
))
2168 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2169 / BOOL_VECTOR_BITS_PER_CHAR
);
2171 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2173 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2178 if (WINDOW_CONFIGURATIONP (o1
))
2179 return compare_window_configurations (o1
, o2
, 0);
2181 /* Aside from them, only true vectors, char-tables, compiled
2182 functions, and fonts (font-spec, font-entity, font-ojbect)
2183 are sensible to compare, so eliminate the others now. */
2184 if (size
& PSEUDOVECTOR_FLAG
)
2186 if (!(size
& (PVEC_COMPILED
2187 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2189 size
&= PSEUDOVECTOR_SIZE_MASK
;
2191 for (i
= 0; i
< size
; i
++)
2196 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2204 if (SCHARS (o1
) != SCHARS (o2
))
2206 if (SBYTES (o1
) != SBYTES (o2
))
2208 if (bcmp (SDATA (o1
), SDATA (o2
),
2211 if (props
&& !compare_string_intervals (o1
, o2
))
2223 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2224 doc
: /* Store each element of ARRAY with ITEM.
2225 ARRAY is a vector, string, char-table, or bool-vector. */)
2227 Lisp_Object array
, item
;
2229 register int size
, index
, charval
;
2230 if (VECTORP (array
))
2232 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2233 size
= ASIZE (array
);
2234 for (index
= 0; index
< size
; index
++)
2237 else if (CHAR_TABLE_P (array
))
2241 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2242 XCHAR_TABLE (array
)->contents
[i
] = item
;
2243 XCHAR_TABLE (array
)->defalt
= item
;
2245 else if (STRINGP (array
))
2247 register unsigned char *p
= SDATA (array
);
2248 CHECK_NUMBER (item
);
2249 charval
= XINT (item
);
2250 size
= SCHARS (array
);
2251 if (STRING_MULTIBYTE (array
))
2253 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2254 int len
= CHAR_STRING (charval
, str
);
2255 int size_byte
= SBYTES (array
);
2256 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2259 if (size
!= size_byte
)
2262 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2263 if (len
!= this_len
)
2264 error ("Attempt to change byte length of a string");
2267 for (i
= 0; i
< size_byte
; i
++)
2268 *p
++ = str
[i
% len
];
2271 for (index
= 0; index
< size
; index
++)
2274 else if (BOOL_VECTOR_P (array
))
2276 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2278 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2279 / BOOL_VECTOR_BITS_PER_CHAR
);
2281 charval
= (! NILP (item
) ? -1 : 0);
2282 for (index
= 0; index
< size_in_chars
- 1; index
++)
2284 if (index
< size_in_chars
)
2286 /* Mask out bits beyond the vector size. */
2287 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2288 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2293 wrong_type_argument (Qarrayp
, array
);
2297 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2299 doc
: /* Clear the contents of STRING.
2300 This makes STRING unibyte and may change its length. */)
2305 CHECK_STRING (string
);
2306 len
= SBYTES (string
);
2307 bzero (SDATA (string
), len
);
2308 STRING_SET_CHARS (string
, len
);
2309 STRING_SET_UNIBYTE (string
);
2315 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2317 Lisp_Object args
[2];
2320 return Fnconc (2, args
);
2323 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2324 doc
: /* Concatenate any number of lists by altering them.
2325 Only the last argument is not altered, and need not be a list.
2326 usage: (nconc &rest LISTS) */)
2331 register int argnum
;
2332 register Lisp_Object tail
, tem
, val
;
2336 for (argnum
= 0; argnum
< nargs
; argnum
++)
2339 if (NILP (tem
)) continue;
2344 if (argnum
+ 1 == nargs
) break;
2346 CHECK_LIST_CONS (tem
, tem
);
2355 tem
= args
[argnum
+ 1];
2356 Fsetcdr (tail
, tem
);
2358 args
[argnum
+ 1] = tail
;
2364 /* This is the guts of all mapping functions.
2365 Apply FN to each element of SEQ, one by one,
2366 storing the results into elements of VALS, a C vector of Lisp_Objects.
2367 LENI is the length of VALS, which should also be the length of SEQ. */
2370 mapcar1 (int leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2372 register Lisp_Object tail
;
2375 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2379 /* Don't let vals contain any garbage when GC happens. */
2380 for (i
= 0; i
< leni
; i
++)
2383 GCPRO3 (dummy
, fn
, seq
);
2385 gcpro1
.nvars
= leni
;
2389 /* We need not explicitly protect `tail' because it is used only on lists, and
2390 1) lists are not relocated and 2) the list is marked via `seq' so will not
2395 for (i
= 0; i
< leni
; i
++)
2397 dummy
= call1 (fn
, AREF (seq
, i
));
2402 else if (BOOL_VECTOR_P (seq
))
2404 for (i
= 0; i
< leni
; i
++)
2407 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2408 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2409 dummy
= call1 (fn
, dummy
);
2414 else if (STRINGP (seq
))
2418 for (i
= 0, i_byte
= 0; i
< leni
;)
2423 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2424 XSETFASTINT (dummy
, c
);
2425 dummy
= call1 (fn
, dummy
);
2427 vals
[i_before
] = dummy
;
2430 else /* Must be a list, since Flength did not get an error */
2433 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2435 dummy
= call1 (fn
, XCAR (tail
));
2445 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2446 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2447 In between each pair of results, stick in SEPARATOR. Thus, " " as
2448 SEPARATOR results in spaces between the values returned by FUNCTION.
2449 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2450 (function
, sequence
, separator
)
2451 Lisp_Object function
, sequence
, separator
;
2456 register Lisp_Object
*args
;
2458 struct gcpro gcpro1
;
2462 len
= Flength (sequence
);
2463 if (CHAR_TABLE_P (sequence
))
2464 wrong_type_argument (Qlistp
, sequence
);
2466 nargs
= leni
+ leni
- 1;
2467 if (nargs
< 0) return empty_unibyte_string
;
2469 SAFE_ALLOCA_LISP (args
, nargs
);
2472 mapcar1 (leni
, args
, function
, sequence
);
2475 for (i
= leni
- 1; i
> 0; i
--)
2476 args
[i
+ i
] = args
[i
];
2478 for (i
= 1; i
< nargs
; i
+= 2)
2479 args
[i
] = separator
;
2481 ret
= Fconcat (nargs
, args
);
2487 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2488 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2489 The result is a list just as long as SEQUENCE.
2490 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2491 (function
, sequence
)
2492 Lisp_Object function
, sequence
;
2494 register Lisp_Object len
;
2496 register Lisp_Object
*args
;
2500 len
= Flength (sequence
);
2501 if (CHAR_TABLE_P (sequence
))
2502 wrong_type_argument (Qlistp
, sequence
);
2503 leni
= XFASTINT (len
);
2505 SAFE_ALLOCA_LISP (args
, leni
);
2507 mapcar1 (leni
, args
, function
, sequence
);
2509 ret
= Flist (leni
, args
);
2515 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2516 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2517 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2518 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2519 (function
, sequence
)
2520 Lisp_Object function
, sequence
;
2524 leni
= XFASTINT (Flength (sequence
));
2525 if (CHAR_TABLE_P (sequence
))
2526 wrong_type_argument (Qlistp
, sequence
);
2527 mapcar1 (leni
, 0, function
, sequence
);
2532 /* Anything that calls this function must protect from GC! */
2534 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2535 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2536 Takes one argument, which is the string to display to ask the question.
2537 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2538 No confirmation of the answer is requested; a single character is enough.
2539 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2540 the bindings in `query-replace-map'; see the documentation of that variable
2541 for more information. In this case, the useful bindings are `act', `skip',
2542 `recenter', and `quit'.\)
2544 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2545 is nil and `use-dialog-box' is non-nil. */)
2549 register Lisp_Object obj
, key
, def
, map
;
2550 register int answer
;
2551 Lisp_Object xprompt
;
2552 Lisp_Object args
[2];
2553 struct gcpro gcpro1
, gcpro2
;
2554 int count
= SPECPDL_INDEX ();
2556 specbind (Qcursor_in_echo_area
, Qt
);
2558 map
= Fsymbol_value (intern ("query-replace-map"));
2560 CHECK_STRING (prompt
);
2562 GCPRO2 (prompt
, xprompt
);
2564 #ifdef HAVE_WINDOW_SYSTEM
2565 if (display_hourglass_p
)
2566 cancel_hourglass ();
2573 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2574 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2578 Lisp_Object pane
, menu
;
2579 redisplay_preserve_echo_area (3);
2580 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2581 Fcons (Fcons (build_string ("No"), Qnil
),
2583 menu
= Fcons (prompt
, pane
);
2584 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2585 answer
= !NILP (obj
);
2588 #endif /* HAVE_MENUS */
2589 cursor_in_echo_area
= 1;
2590 choose_minibuf_frame ();
2593 Lisp_Object pargs
[3];
2595 /* Colorize prompt according to `minibuffer-prompt' face. */
2596 pargs
[0] = build_string ("%s(y or n) ");
2597 pargs
[1] = intern ("face");
2598 pargs
[2] = intern ("minibuffer-prompt");
2599 args
[0] = Fpropertize (3, pargs
);
2604 if (minibuffer_auto_raise
)
2606 Lisp_Object mini_frame
;
2608 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2610 Fraise_frame (mini_frame
);
2613 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2614 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2615 cursor_in_echo_area
= 0;
2616 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2619 key
= Fmake_vector (make_number (1), obj
);
2620 def
= Flookup_key (map
, key
, Qt
);
2622 if (EQ (def
, intern ("skip")))
2627 else if (EQ (def
, intern ("act")))
2632 else if (EQ (def
, intern ("recenter")))
2638 else if (EQ (def
, intern ("quit")))
2640 /* We want to exit this command for exit-prefix,
2641 and this is the only way to do it. */
2642 else if (EQ (def
, intern ("exit-prefix")))
2647 /* If we don't clear this, then the next call to read_char will
2648 return quit_char again, and we'll enter an infinite loop. */
2653 if (EQ (xprompt
, prompt
))
2655 args
[0] = build_string ("Please answer y or n. ");
2657 xprompt
= Fconcat (2, args
);
2662 if (! noninteractive
)
2664 cursor_in_echo_area
= -1;
2665 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2669 unbind_to (count
, Qnil
);
2670 return answer
? Qt
: Qnil
;
2673 /* This is how C code calls `yes-or-no-p' and allows the user
2676 Anything that calls this function must protect from GC! */
2679 do_yes_or_no_p (Lisp_Object prompt
)
2681 return call1 (intern ("yes-or-no-p"), prompt
);
2684 /* Anything that calls this function must protect from GC! */
2686 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2687 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2688 Takes one argument, which is the string to display to ask the question.
2689 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2690 The user must confirm the answer with RET,
2691 and can edit it until it has been confirmed.
2693 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2694 is nil, and `use-dialog-box' is non-nil. */)
2698 register Lisp_Object ans
;
2699 Lisp_Object args
[2];
2700 struct gcpro gcpro1
;
2702 CHECK_STRING (prompt
);
2705 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2706 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2710 Lisp_Object pane
, menu
, obj
;
2711 redisplay_preserve_echo_area (4);
2712 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2713 Fcons (Fcons (build_string ("No"), Qnil
),
2716 menu
= Fcons (prompt
, pane
);
2717 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2721 #endif /* HAVE_MENUS */
2724 args
[1] = build_string ("(yes or no) ");
2725 prompt
= Fconcat (2, args
);
2731 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2732 Qyes_or_no_p_history
, Qnil
,
2734 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2739 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2747 message ("Please answer yes or no.");
2748 Fsleep_for (make_number (2), Qnil
);
2752 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2753 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2755 Each of the three load averages is multiplied by 100, then converted
2758 When USE-FLOATS is non-nil, floats will be used instead of integers.
2759 These floats are not multiplied by 100.
2761 If the 5-minute or 15-minute load averages are not available, return a
2762 shortened list, containing only those averages which are available.
2764 An error is thrown if the load average can't be obtained. In some
2765 cases making it work would require Emacs being installed setuid or
2766 setgid so that it can read kernel information, and that usually isn't
2769 Lisp_Object use_floats
;
2772 int loads
= getloadavg (load_ave
, 3);
2773 Lisp_Object ret
= Qnil
;
2776 error ("load-average not implemented for this operating system");
2780 Lisp_Object load
= (NILP (use_floats
) ?
2781 make_number ((int) (100.0 * load_ave
[loads
]))
2782 : make_float (load_ave
[loads
]));
2783 ret
= Fcons (load
, ret
);
2789 Lisp_Object Vfeatures
, Qsubfeatures
;
2790 extern Lisp_Object Vafter_load_alist
;
2792 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2793 doc
: /* Returns t if FEATURE is present in this Emacs.
2795 Use this to conditionalize execution of lisp code based on the
2796 presence or absence of Emacs or environment extensions.
2797 Use `provide' to declare that a feature is available. This function
2798 looks at the value of the variable `features'. The optional argument
2799 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2800 (feature
, subfeature
)
2801 Lisp_Object feature
, subfeature
;
2803 register Lisp_Object tem
;
2804 CHECK_SYMBOL (feature
);
2805 tem
= Fmemq (feature
, Vfeatures
);
2806 if (!NILP (tem
) && !NILP (subfeature
))
2807 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2808 return (NILP (tem
)) ? Qnil
: Qt
;
2811 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2812 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2813 The optional argument SUBFEATURES should be a list of symbols listing
2814 particular subfeatures supported in this version of FEATURE. */)
2815 (feature
, subfeatures
)
2816 Lisp_Object feature
, subfeatures
;
2818 register Lisp_Object tem
;
2819 CHECK_SYMBOL (feature
);
2820 CHECK_LIST (subfeatures
);
2821 if (!NILP (Vautoload_queue
))
2822 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2824 tem
= Fmemq (feature
, Vfeatures
);
2826 Vfeatures
= Fcons (feature
, Vfeatures
);
2827 if (!NILP (subfeatures
))
2828 Fput (feature
, Qsubfeatures
, subfeatures
);
2829 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2831 /* Run any load-hooks for this file. */
2832 tem
= Fassq (feature
, Vafter_load_alist
);
2834 Fprogn (XCDR (tem
));
2839 /* `require' and its subroutines. */
2841 /* List of features currently being require'd, innermost first. */
2843 Lisp_Object require_nesting_list
;
2846 require_unwind (Lisp_Object old_value
)
2848 return require_nesting_list
= old_value
;
2851 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2852 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2853 If FEATURE is not a member of the list `features', then the feature
2854 is not loaded; so load the file FILENAME.
2855 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2856 and `load' will try to load this name appended with the suffix `.elc' or
2857 `.el', in that order. The name without appended suffix will not be used.
2858 If the optional third argument NOERROR is non-nil,
2859 then return nil if the file is not found instead of signaling an error.
2860 Normally the return value is FEATURE.
2861 The normal messages at start and end of loading FILENAME are suppressed. */)
2862 (feature
, filename
, noerror
)
2863 Lisp_Object feature
, filename
, noerror
;
2865 register Lisp_Object tem
;
2866 struct gcpro gcpro1
, gcpro2
;
2867 int from_file
= load_in_progress
;
2869 CHECK_SYMBOL (feature
);
2871 /* Record the presence of `require' in this file
2872 even if the feature specified is already loaded.
2873 But not more than once in any file,
2874 and not when we aren't loading or reading from a file. */
2876 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2877 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2882 tem
= Fcons (Qrequire
, feature
);
2883 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2884 LOADHIST_ATTACH (tem
);
2886 tem
= Fmemq (feature
, Vfeatures
);
2890 int count
= SPECPDL_INDEX ();
2893 /* This is to make sure that loadup.el gives a clear picture
2894 of what files are preloaded and when. */
2895 if (! NILP (Vpurify_flag
))
2896 error ("(require %s) while preparing to dump",
2897 SDATA (SYMBOL_NAME (feature
)));
2899 /* A certain amount of recursive `require' is legitimate,
2900 but if we require the same feature recursively 3 times,
2902 tem
= require_nesting_list
;
2903 while (! NILP (tem
))
2905 if (! NILP (Fequal (feature
, XCAR (tem
))))
2910 error ("Recursive `require' for feature `%s'",
2911 SDATA (SYMBOL_NAME (feature
)));
2913 /* Update the list for any nested `require's that occur. */
2914 record_unwind_protect (require_unwind
, require_nesting_list
);
2915 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2917 /* Value saved here is to be restored into Vautoload_queue */
2918 record_unwind_protect (un_autoload
, Vautoload_queue
);
2919 Vautoload_queue
= Qt
;
2921 /* Load the file. */
2922 GCPRO2 (feature
, filename
);
2923 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2924 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2927 /* If load failed entirely, return nil. */
2929 return unbind_to (count
, Qnil
);
2931 tem
= Fmemq (feature
, Vfeatures
);
2933 error ("Required feature `%s' was not provided",
2934 SDATA (SYMBOL_NAME (feature
)));
2936 /* Once loading finishes, don't undo it. */
2937 Vautoload_queue
= Qt
;
2938 feature
= unbind_to (count
, feature
);
2944 /* Primitives for work of the "widget" library.
2945 In an ideal world, this section would not have been necessary.
2946 However, lisp function calls being as slow as they are, it turns
2947 out that some functions in the widget library (wid-edit.el) are the
2948 bottleneck of Widget operation. Here is their translation to C,
2949 for the sole reason of efficiency. */
2951 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2952 doc
: /* Return non-nil if PLIST has the property PROP.
2953 PLIST is a property list, which is a list of the form
2954 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2955 Unlike `plist-get', this allows you to distinguish between a missing
2956 property and a property with the value nil.
2957 The value is actually the tail of PLIST whose car is PROP. */)
2959 Lisp_Object plist
, prop
;
2961 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2964 plist
= XCDR (plist
);
2965 plist
= CDR (plist
);
2970 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2971 doc
: /* In WIDGET, set PROPERTY to VALUE.
2972 The value can later be retrieved with `widget-get'. */)
2973 (widget
, property
, value
)
2974 Lisp_Object widget
, property
, value
;
2976 CHECK_CONS (widget
);
2977 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2981 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2982 doc
: /* In WIDGET, get the value of PROPERTY.
2983 The value could either be specified when the widget was created, or
2984 later with `widget-put'. */)
2986 Lisp_Object widget
, property
;
2994 CHECK_CONS (widget
);
2995 tmp
= Fplist_member (XCDR (widget
), property
);
3001 tmp
= XCAR (widget
);
3004 widget
= Fget (tmp
, Qwidget_type
);
3008 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3009 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3010 ARGS are passed as extra arguments to the function.
3011 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3016 /* This function can GC. */
3017 Lisp_Object newargs
[3];
3018 struct gcpro gcpro1
, gcpro2
;
3021 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3022 newargs
[1] = args
[0];
3023 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3024 GCPRO2 (newargs
[0], newargs
[2]);
3025 result
= Fapply (3, newargs
);
3030 #ifdef HAVE_LANGINFO_CODESET
3031 #include <langinfo.h>
3034 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3035 doc
: /* Access locale data ITEM for the current C locale, if available.
3036 ITEM should be one of the following:
3038 `codeset', returning the character set as a string (locale item CODESET);
3040 `days', returning a 7-element vector of day names (locale items DAY_n);
3042 `months', returning a 12-element vector of month names (locale items MON_n);
3044 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3045 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3047 If the system can't provide such information through a call to
3048 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3050 See also Info node `(libc)Locales'.
3052 The data read from the system are decoded using `locale-coding-system'. */)
3057 #ifdef HAVE_LANGINFO_CODESET
3059 if (EQ (item
, Qcodeset
))
3061 str
= nl_langinfo (CODESET
);
3062 return build_string (str
);
3065 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3067 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3068 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3070 struct gcpro gcpro1
;
3072 synchronize_system_time_locale ();
3073 for (i
= 0; i
< 7; i
++)
3075 str
= nl_langinfo (days
[i
]);
3076 val
= make_unibyte_string (str
, strlen (str
));
3077 /* Fixme: Is this coding system necessarily right, even if
3078 it is consistent with CODESET? If not, what to do? */
3079 Faset (v
, make_number (i
),
3080 code_convert_string_norecord (val
, Vlocale_coding_system
,
3088 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3090 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3091 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3092 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3094 struct gcpro gcpro1
;
3096 synchronize_system_time_locale ();
3097 for (i
= 0; i
< 12; i
++)
3099 str
= nl_langinfo (months
[i
]);
3100 val
= make_unibyte_string (str
, strlen (str
));
3101 Faset (v
, make_number (i
),
3102 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3108 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3109 but is in the locale files. This could be used by ps-print. */
3111 else if (EQ (item
, Qpaper
))
3113 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3114 make_number (nl_langinfo (PAPER_HEIGHT
)));
3116 #endif /* PAPER_WIDTH */
3117 #endif /* HAVE_LANGINFO_CODESET*/
3121 /* base64 encode/decode functions (RFC 2045).
3122 Based on code from GNU recode. */
3124 #define MIME_LINE_LENGTH 76
3126 #define IS_ASCII(Character) \
3128 #define IS_BASE64(Character) \
3129 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3130 #define IS_BASE64_IGNORABLE(Character) \
3131 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3132 || (Character) == '\f' || (Character) == '\r')
3134 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3135 character or return retval if there are no characters left to
3137 #define READ_QUADRUPLET_BYTE(retval) \
3142 if (nchars_return) \
3143 *nchars_return = nchars; \
3148 while (IS_BASE64_IGNORABLE (c))
3150 /* Table of characters coding the 64 values. */
3151 static const char base64_value_to_char
[64] =
3153 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3154 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3155 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3156 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3157 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3158 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3159 '8', '9', '+', '/' /* 60-63 */
3162 /* Table of base64 values for first 128 characters. */
3163 static const short base64_char_to_value
[128] =
3165 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3166 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3167 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3168 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3169 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3170 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3171 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3172 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3173 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3174 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3175 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3176 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3177 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3180 /* The following diagram shows the logical steps by which three octets
3181 get transformed into four base64 characters.
3183 .--------. .--------. .--------.
3184 |aaaaaabb| |bbbbcccc| |ccdddddd|
3185 `--------' `--------' `--------'
3187 .--------+--------+--------+--------.
3188 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3189 `--------+--------+--------+--------'
3191 .--------+--------+--------+--------.
3192 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3193 `--------+--------+--------+--------'
3195 The octets are divided into 6 bit chunks, which are then encoded into
3196 base64 characters. */
3199 static int base64_encode_1 (const char *, char *, int, int, int);
3200 static int base64_decode_1 (const char *, char *, int, int, int *);
3202 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3204 doc
: /* Base64-encode the region between BEG and END.
3205 Return the length of the encoded text.
3206 Optional third argument NO-LINE-BREAK means do not break long lines
3207 into shorter lines. */)
3208 (beg
, end
, no_line_break
)
3209 Lisp_Object beg
, end
, no_line_break
;
3212 int allength
, length
;
3213 int ibeg
, iend
, encoded_length
;
3217 validate_region (&beg
, &end
);
3219 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3220 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3221 move_gap_both (XFASTINT (beg
), ibeg
);
3223 /* We need to allocate enough room for encoding the text.
3224 We need 33 1/3% more space, plus a newline every 76
3225 characters, and then we round up. */
3226 length
= iend
- ibeg
;
3227 allength
= length
+ length
/3 + 1;
3228 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3230 SAFE_ALLOCA (encoded
, char *, allength
);
3231 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3232 NILP (no_line_break
),
3233 !NILP (current_buffer
->enable_multibyte_characters
));
3234 if (encoded_length
> allength
)
3237 if (encoded_length
< 0)
3239 /* The encoding wasn't possible. */
3241 error ("Multibyte character in data for base64 encoding");
3244 /* Now we have encoded the region, so we insert the new contents
3245 and delete the old. (Insert first in order to preserve markers.) */
3246 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3247 insert (encoded
, encoded_length
);
3249 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3251 /* If point was outside of the region, restore it exactly; else just
3252 move to the beginning of the region. */
3253 if (old_pos
>= XFASTINT (end
))
3254 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3255 else if (old_pos
> XFASTINT (beg
))
3256 old_pos
= XFASTINT (beg
);
3259 /* We return the length of the encoded text. */
3260 return make_number (encoded_length
);
3263 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3265 doc
: /* Base64-encode STRING and return the result.
3266 Optional second argument NO-LINE-BREAK means do not break long lines
3267 into shorter lines. */)
3268 (string
, no_line_break
)
3269 Lisp_Object string
, no_line_break
;
3271 int allength
, length
, encoded_length
;
3273 Lisp_Object encoded_string
;
3276 CHECK_STRING (string
);
3278 /* We need to allocate enough room for encoding the text.
3279 We need 33 1/3% more space, plus a newline every 76
3280 characters, and then we round up. */
3281 length
= SBYTES (string
);
3282 allength
= length
+ length
/3 + 1;
3283 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3285 /* We need to allocate enough room for decoding the text. */
3286 SAFE_ALLOCA (encoded
, char *, allength
);
3288 encoded_length
= base64_encode_1 (SDATA (string
),
3289 encoded
, length
, NILP (no_line_break
),
3290 STRING_MULTIBYTE (string
));
3291 if (encoded_length
> allength
)
3294 if (encoded_length
< 0)
3296 /* The encoding wasn't possible. */
3298 error ("Multibyte character in data for base64 encoding");
3301 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3304 return encoded_string
;
3308 base64_encode_1 (const char *from
, char *to
, int length
, int line_break
, int multibyte
)
3310 int counter
= 0, i
= 0;
3320 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3321 if (CHAR_BYTE8_P (c
))
3322 c
= CHAR_TO_BYTE8 (c
);
3330 /* Wrap line every 76 characters. */
3334 if (counter
< MIME_LINE_LENGTH
/ 4)
3343 /* Process first byte of a triplet. */
3345 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3346 value
= (0x03 & c
) << 4;
3348 /* Process second byte of a triplet. */
3352 *e
++ = base64_value_to_char
[value
];
3360 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3361 if (CHAR_BYTE8_P (c
))
3362 c
= CHAR_TO_BYTE8 (c
);
3370 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3371 value
= (0x0f & c
) << 2;
3373 /* Process third byte of a triplet. */
3377 *e
++ = base64_value_to_char
[value
];
3384 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3385 if (CHAR_BYTE8_P (c
))
3386 c
= CHAR_TO_BYTE8 (c
);
3394 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3395 *e
++ = base64_value_to_char
[0x3f & c
];
3402 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3404 doc
: /* Base64-decode the region between BEG and END.
3405 Return the length of the decoded text.
3406 If the region can't be decoded, signal an error and don't modify the buffer. */)
3408 Lisp_Object beg
, end
;
3410 int ibeg
, iend
, length
, allength
;
3415 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3418 validate_region (&beg
, &end
);
3420 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3421 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3423 length
= iend
- ibeg
;
3425 /* We need to allocate enough room for decoding the text. If we are
3426 working on a multibyte buffer, each decoded code may occupy at
3428 allength
= multibyte
? length
* 2 : length
;
3429 SAFE_ALLOCA (decoded
, char *, allength
);
3431 move_gap_both (XFASTINT (beg
), ibeg
);
3432 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3433 multibyte
, &inserted_chars
);
3434 if (decoded_length
> allength
)
3437 if (decoded_length
< 0)
3439 /* The decoding wasn't possible. */
3441 error ("Invalid base64 data");
3444 /* Now we have decoded the region, so we insert the new contents
3445 and delete the old. (Insert first in order to preserve markers.) */
3446 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3447 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3450 /* Delete the original text. */
3451 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3452 iend
+ decoded_length
, 1);
3454 /* If point was outside of the region, restore it exactly; else just
3455 move to the beginning of the region. */
3456 if (old_pos
>= XFASTINT (end
))
3457 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3458 else if (old_pos
> XFASTINT (beg
))
3459 old_pos
= XFASTINT (beg
);
3460 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3462 return make_number (inserted_chars
);
3465 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3467 doc
: /* Base64-decode STRING and return the result. */)
3472 int length
, decoded_length
;
3473 Lisp_Object decoded_string
;
3476 CHECK_STRING (string
);
3478 length
= SBYTES (string
);
3479 /* We need to allocate enough room for decoding the text. */
3480 SAFE_ALLOCA (decoded
, char *, length
);
3482 /* The decoded result should be unibyte. */
3483 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3485 if (decoded_length
> length
)
3487 else if (decoded_length
>= 0)
3488 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3490 decoded_string
= Qnil
;
3493 if (!STRINGP (decoded_string
))
3494 error ("Invalid base64 data");
3496 return decoded_string
;
3499 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3500 MULTIBYTE is nonzero, the decoded result should be in multibyte
3501 form. If NCHARS_RETRUN is not NULL, store the number of produced
3502 characters in *NCHARS_RETURN. */
3505 base64_decode_1 (const char *from
, char *to
, int length
, int multibyte
, int *nchars_return
)
3510 unsigned long value
;
3515 /* Process first byte of a quadruplet. */
3517 READ_QUADRUPLET_BYTE (e
-to
);
3521 value
= base64_char_to_value
[c
] << 18;
3523 /* Process second byte of a quadruplet. */
3525 READ_QUADRUPLET_BYTE (-1);
3529 value
|= base64_char_to_value
[c
] << 12;
3531 c
= (unsigned char) (value
>> 16);
3532 if (multibyte
&& c
>= 128)
3533 e
+= BYTE8_STRING (c
, e
);
3538 /* Process third byte of a quadruplet. */
3540 READ_QUADRUPLET_BYTE (-1);
3544 READ_QUADRUPLET_BYTE (-1);
3553 value
|= base64_char_to_value
[c
] << 6;
3555 c
= (unsigned char) (0xff & value
>> 8);
3556 if (multibyte
&& c
>= 128)
3557 e
+= BYTE8_STRING (c
, e
);
3562 /* Process fourth byte of a quadruplet. */
3564 READ_QUADRUPLET_BYTE (-1);
3571 value
|= base64_char_to_value
[c
];
3573 c
= (unsigned char) (0xff & value
);
3574 if (multibyte
&& c
>= 128)
3575 e
+= BYTE8_STRING (c
, e
);
3584 /***********************************************************************
3586 ***** Hash Tables *****
3588 ***********************************************************************/
3590 /* Implemented by gerd@gnu.org. This hash table implementation was
3591 inspired by CMUCL hash tables. */
3595 1. For small tables, association lists are probably faster than
3596 hash tables because they have lower overhead.
3598 For uses of hash tables where the O(1) behavior of table
3599 operations is not a requirement, it might therefore be a good idea
3600 not to hash. Instead, we could just do a linear search in the
3601 key_and_value vector of the hash table. This could be done
3602 if a `:linear-search t' argument is given to make-hash-table. */
3605 /* The list of all weak hash tables. Don't staticpro this one. */
3607 struct Lisp_Hash_Table
*weak_hash_tables
;
3609 /* Various symbols. */
3611 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3612 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3613 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3615 /* Function prototypes. */
3617 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3618 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3619 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3620 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3621 Lisp_Object
, unsigned);
3622 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3623 Lisp_Object
, unsigned);
3624 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3625 unsigned, Lisp_Object
, unsigned);
3626 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3627 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3628 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3629 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3631 static unsigned sxhash_string (unsigned char *, int);
3632 static unsigned sxhash_list (Lisp_Object
, int);
3633 static unsigned sxhash_vector (Lisp_Object
, int);
3634 static unsigned sxhash_bool_vector (Lisp_Object
);
3635 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3639 /***********************************************************************
3641 ***********************************************************************/
3643 /* If OBJ is a Lisp hash table, return a pointer to its struct
3644 Lisp_Hash_Table. Otherwise, signal an error. */
3646 static struct Lisp_Hash_Table
*
3647 check_hash_table (Lisp_Object obj
)
3649 CHECK_HASH_TABLE (obj
);
3650 return XHASH_TABLE (obj
);
3654 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3658 next_almost_prime (int n
)
3670 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3671 which USED[I] is non-zero. If found at index I in ARGS, set
3672 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3673 -1. This function is used to extract a keyword/argument pair from
3674 a DEFUN parameter list. */
3677 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3681 for (i
= 0; i
< nargs
- 1; ++i
)
3682 if (!used
[i
] && EQ (args
[i
], key
))
3697 /* Return a Lisp vector which has the same contents as VEC but has
3698 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3699 vector that are not copied from VEC are set to INIT. */
3702 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3704 struct Lisp_Vector
*v
;
3707 xassert (VECTORP (vec
));
3708 old_size
= ASIZE (vec
);
3709 xassert (new_size
>= old_size
);
3711 v
= allocate_vector (new_size
);
3712 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3713 old_size
* sizeof *v
->contents
);
3714 for (i
= old_size
; i
< new_size
; ++i
)
3715 v
->contents
[i
] = init
;
3716 XSETVECTOR (vec
, v
);
3721 /***********************************************************************
3723 ***********************************************************************/
3725 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3726 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3727 KEY2 are the same. */
3730 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3732 return (FLOATP (key1
)
3734 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3738 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3739 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3740 KEY2 are the same. */
3743 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3745 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3749 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3750 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3751 if KEY1 and KEY2 are the same. */
3754 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3758 Lisp_Object args
[3];
3760 args
[0] = h
->user_cmp_function
;
3763 return !NILP (Ffuncall (3, args
));
3770 /* Value is a hash code for KEY for use in hash table H which uses
3771 `eq' to compare keys. The hash code returned is guaranteed to fit
3772 in a Lisp integer. */
3775 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3777 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3778 xassert ((hash
& ~INTMASK
) == 0);
3783 /* Value is a hash code for KEY for use in hash table H which uses
3784 `eql' to compare keys. The hash code returned is guaranteed to fit
3785 in a Lisp integer. */
3788 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3792 hash
= sxhash (key
, 0);
3794 hash
= XUINT (key
) ^ XTYPE (key
);
3795 xassert ((hash
& ~INTMASK
) == 0);
3800 /* Value is a hash code for KEY for use in hash table H which uses
3801 `equal' to compare keys. The hash code returned is guaranteed to fit
3802 in a Lisp integer. */
3805 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3807 unsigned hash
= sxhash (key
, 0);
3808 xassert ((hash
& ~INTMASK
) == 0);
3813 /* Value is a hash code for KEY for use in hash table H which uses as
3814 user-defined function to compare keys. The hash code returned is
3815 guaranteed to fit in a Lisp integer. */
3818 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3820 Lisp_Object args
[2], hash
;
3822 args
[0] = h
->user_hash_function
;
3824 hash
= Ffuncall (2, args
);
3825 if (!INTEGERP (hash
))
3826 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3827 return XUINT (hash
);
3831 /* Create and initialize a new hash table.
3833 TEST specifies the test the hash table will use to compare keys.
3834 It must be either one of the predefined tests `eq', `eql' or
3835 `equal' or a symbol denoting a user-defined test named TEST with
3836 test and hash functions USER_TEST and USER_HASH.
3838 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3840 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3841 new size when it becomes full is computed by adding REHASH_SIZE to
3842 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3843 table's new size is computed by multiplying its old size with
3846 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3847 be resized when the ratio of (number of entries in the table) /
3848 (table size) is >= REHASH_THRESHOLD.
3850 WEAK specifies the weakness of the table. If non-nil, it must be
3851 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3854 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3855 user_test
, user_hash
)
3856 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3857 Lisp_Object user_test
, user_hash
;
3859 struct Lisp_Hash_Table
*h
;
3861 int index_size
, i
, sz
;
3863 /* Preconditions. */
3864 xassert (SYMBOLP (test
));
3865 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3866 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3867 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3868 xassert (FLOATP (rehash_threshold
)
3869 && XFLOATINT (rehash_threshold
) > 0
3870 && XFLOATINT (rehash_threshold
) <= 1.0);
3872 if (XFASTINT (size
) == 0)
3873 size
= make_number (1);
3875 /* Allocate a table and initialize it. */
3876 h
= allocate_hash_table ();
3878 /* Initialize hash table slots. */
3879 sz
= XFASTINT (size
);
3882 if (EQ (test
, Qeql
))
3884 h
->cmpfn
= cmpfn_eql
;
3885 h
->hashfn
= hashfn_eql
;
3887 else if (EQ (test
, Qeq
))
3890 h
->hashfn
= hashfn_eq
;
3892 else if (EQ (test
, Qequal
))
3894 h
->cmpfn
= cmpfn_equal
;
3895 h
->hashfn
= hashfn_equal
;
3899 h
->user_cmp_function
= user_test
;
3900 h
->user_hash_function
= user_hash
;
3901 h
->cmpfn
= cmpfn_user_defined
;
3902 h
->hashfn
= hashfn_user_defined
;
3906 h
->rehash_threshold
= rehash_threshold
;
3907 h
->rehash_size
= rehash_size
;
3909 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3910 h
->hash
= Fmake_vector (size
, Qnil
);
3911 h
->next
= Fmake_vector (size
, Qnil
);
3912 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3913 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3914 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3916 /* Set up the free list. */
3917 for (i
= 0; i
< sz
- 1; ++i
)
3918 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3919 h
->next_free
= make_number (0);
3921 XSET_HASH_TABLE (table
, h
);
3922 xassert (HASH_TABLE_P (table
));
3923 xassert (XHASH_TABLE (table
) == h
);
3925 /* Maybe add this hash table to the list of all weak hash tables. */
3927 h
->next_weak
= NULL
;
3930 h
->next_weak
= weak_hash_tables
;
3931 weak_hash_tables
= h
;
3938 /* Return a copy of hash table H1. Keys and values are not copied,
3939 only the table itself is. */
3942 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3945 struct Lisp_Hash_Table
*h2
;
3946 struct Lisp_Vector
*next
;
3948 h2
= allocate_hash_table ();
3949 next
= h2
->vec_next
;
3950 bcopy (h1
, h2
, sizeof *h2
);
3951 h2
->vec_next
= next
;
3952 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3953 h2
->hash
= Fcopy_sequence (h1
->hash
);
3954 h2
->next
= Fcopy_sequence (h1
->next
);
3955 h2
->index
= Fcopy_sequence (h1
->index
);
3956 XSET_HASH_TABLE (table
, h2
);
3958 /* Maybe add this hash table to the list of all weak hash tables. */
3959 if (!NILP (h2
->weak
))
3961 h2
->next_weak
= weak_hash_tables
;
3962 weak_hash_tables
= h2
;
3969 /* Resize hash table H if it's too full. If H cannot be resized
3970 because it's already too large, throw an error. */
3973 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3975 if (NILP (h
->next_free
))
3977 int old_size
= HASH_TABLE_SIZE (h
);
3978 int i
, new_size
, index_size
;
3981 if (INTEGERP (h
->rehash_size
))
3982 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3984 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3985 new_size
= max (old_size
+ 1, new_size
);
3986 index_size
= next_almost_prime ((int)
3988 / XFLOATINT (h
->rehash_threshold
)));
3989 /* Assignment to EMACS_INT stops GCC whining about limited range
3991 nsize
= max (index_size
, 2 * new_size
);
3992 if (nsize
> MOST_POSITIVE_FIXNUM
)
3993 error ("Hash table too large to resize");
3995 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3996 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3997 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3998 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4000 /* Update the free list. Do it so that new entries are added at
4001 the end of the free list. This makes some operations like
4003 for (i
= old_size
; i
< new_size
- 1; ++i
)
4004 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4006 if (!NILP (h
->next_free
))
4008 Lisp_Object last
, next
;
4010 last
= h
->next_free
;
4011 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4015 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4018 XSETFASTINT (h
->next_free
, old_size
);
4021 for (i
= 0; i
< old_size
; ++i
)
4022 if (!NILP (HASH_HASH (h
, i
)))
4024 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4025 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4026 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4027 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4033 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4034 the hash code of KEY. Value is the index of the entry in H
4035 matching KEY, or -1 if not found. */
4038 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
4041 int start_of_bucket
;
4044 hash_code
= h
->hashfn (h
, key
);
4048 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4049 idx
= HASH_INDEX (h
, start_of_bucket
);
4051 /* We need not gcpro idx since it's either an integer or nil. */
4054 int i
= XFASTINT (idx
);
4055 if (EQ (key
, HASH_KEY (h
, i
))
4057 && h
->cmpfn (h
, key
, hash_code
,
4058 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4060 idx
= HASH_NEXT (h
, i
);
4063 return NILP (idx
) ? -1 : XFASTINT (idx
);
4067 /* Put an entry into hash table H that associates KEY with VALUE.
4068 HASH is a previously computed hash code of KEY.
4069 Value is the index of the entry in H matching KEY. */
4072 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
4074 int start_of_bucket
, i
;
4076 xassert ((hash
& ~INTMASK
) == 0);
4078 /* Increment count after resizing because resizing may fail. */
4079 maybe_resize_hash_table (h
);
4082 /* Store key/value in the key_and_value vector. */
4083 i
= XFASTINT (h
->next_free
);
4084 h
->next_free
= HASH_NEXT (h
, i
);
4085 HASH_KEY (h
, i
) = key
;
4086 HASH_VALUE (h
, i
) = value
;
4088 /* Remember its hash code. */
4089 HASH_HASH (h
, i
) = make_number (hash
);
4091 /* Add new entry to its collision chain. */
4092 start_of_bucket
= hash
% ASIZE (h
->index
);
4093 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4094 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4099 /* Remove the entry matching KEY from hash table H, if there is one. */
4102 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4105 int start_of_bucket
;
4106 Lisp_Object idx
, prev
;
4108 hash_code
= h
->hashfn (h
, key
);
4109 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4110 idx
= HASH_INDEX (h
, start_of_bucket
);
4113 /* We need not gcpro idx, prev since they're either integers or nil. */
4116 int i
= XFASTINT (idx
);
4118 if (EQ (key
, HASH_KEY (h
, i
))
4120 && h
->cmpfn (h
, key
, hash_code
,
4121 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4123 /* Take entry out of collision chain. */
4125 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4127 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4129 /* Clear slots in key_and_value and add the slots to
4131 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4132 HASH_NEXT (h
, i
) = h
->next_free
;
4133 h
->next_free
= make_number (i
);
4135 xassert (h
->count
>= 0);
4141 idx
= HASH_NEXT (h
, i
);
4147 /* Clear hash table H. */
4150 hash_clear (struct Lisp_Hash_Table
*h
)
4154 int i
, size
= HASH_TABLE_SIZE (h
);
4156 for (i
= 0; i
< size
; ++i
)
4158 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4159 HASH_KEY (h
, i
) = Qnil
;
4160 HASH_VALUE (h
, i
) = Qnil
;
4161 HASH_HASH (h
, i
) = Qnil
;
4164 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4165 ASET (h
->index
, i
, Qnil
);
4167 h
->next_free
= make_number (0);
4174 /************************************************************************
4176 ************************************************************************/
4179 init_weak_hash_tables (void)
4181 weak_hash_tables
= NULL
;
4184 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4185 entries from the table that don't survive the current GC.
4186 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4187 non-zero if anything was marked. */
4190 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
4192 int bucket
, n
, marked
;
4194 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4197 for (bucket
= 0; bucket
< n
; ++bucket
)
4199 Lisp_Object idx
, next
, prev
;
4201 /* Follow collision chain, removing entries that
4202 don't survive this garbage collection. */
4204 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4206 int i
= XFASTINT (idx
);
4207 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4208 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4211 if (EQ (h
->weak
, Qkey
))
4212 remove_p
= !key_known_to_survive_p
;
4213 else if (EQ (h
->weak
, Qvalue
))
4214 remove_p
= !value_known_to_survive_p
;
4215 else if (EQ (h
->weak
, Qkey_or_value
))
4216 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4217 else if (EQ (h
->weak
, Qkey_and_value
))
4218 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4222 next
= HASH_NEXT (h
, i
);
4224 if (remove_entries_p
)
4228 /* Take out of collision chain. */
4230 HASH_INDEX (h
, bucket
) = next
;
4232 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4234 /* Add to free list. */
4235 HASH_NEXT (h
, i
) = h
->next_free
;
4238 /* Clear key, value, and hash. */
4239 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4240 HASH_HASH (h
, i
) = Qnil
;
4253 /* Make sure key and value survive. */
4254 if (!key_known_to_survive_p
)
4256 mark_object (HASH_KEY (h
, i
));
4260 if (!value_known_to_survive_p
)
4262 mark_object (HASH_VALUE (h
, i
));
4273 /* Remove elements from weak hash tables that don't survive the
4274 current garbage collection. Remove weak tables that don't survive
4275 from Vweak_hash_tables. Called from gc_sweep. */
4278 sweep_weak_hash_tables (void)
4280 struct Lisp_Hash_Table
*h
, *used
, *next
;
4283 /* Mark all keys and values that are in use. Keep on marking until
4284 there is no more change. This is necessary for cases like
4285 value-weak table A containing an entry X -> Y, where Y is used in a
4286 key-weak table B, Z -> Y. If B comes after A in the list of weak
4287 tables, X -> Y might be removed from A, although when looking at B
4288 one finds that it shouldn't. */
4292 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4294 if (h
->size
& ARRAY_MARK_FLAG
)
4295 marked
|= sweep_weak_table (h
, 0);
4300 /* Remove tables and entries that aren't used. */
4301 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4303 next
= h
->next_weak
;
4305 if (h
->size
& ARRAY_MARK_FLAG
)
4307 /* TABLE is marked as used. Sweep its contents. */
4309 sweep_weak_table (h
, 1);
4311 /* Add table to the list of used weak hash tables. */
4312 h
->next_weak
= used
;
4317 weak_hash_tables
= used
;
4322 /***********************************************************************
4323 Hash Code Computation
4324 ***********************************************************************/
4326 /* Maximum depth up to which to dive into Lisp structures. */
4328 #define SXHASH_MAX_DEPTH 3
4330 /* Maximum length up to which to take list and vector elements into
4333 #define SXHASH_MAX_LEN 7
4335 /* Combine two integers X and Y for hashing. */
4337 #define SXHASH_COMBINE(X, Y) \
4338 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4342 /* Return a hash for string PTR which has length LEN. The hash
4343 code returned is guaranteed to fit in a Lisp integer. */
4346 sxhash_string (unsigned char *ptr
, int len
)
4348 unsigned char *p
= ptr
;
4349 unsigned char *end
= p
+ len
;
4358 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4361 return hash
& INTMASK
;
4365 /* Return a hash for list LIST. DEPTH is the current depth in the
4366 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4369 sxhash_list (Lisp_Object list
, int depth
)
4374 if (depth
< SXHASH_MAX_DEPTH
)
4376 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4377 list
= XCDR (list
), ++i
)
4379 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4380 hash
= SXHASH_COMBINE (hash
, hash2
);
4385 unsigned hash2
= sxhash (list
, depth
+ 1);
4386 hash
= SXHASH_COMBINE (hash
, hash2
);
4393 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4394 the Lisp structure. */
4397 sxhash_vector (Lisp_Object vec
, int depth
)
4399 unsigned hash
= ASIZE (vec
);
4402 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4403 for (i
= 0; i
< n
; ++i
)
4405 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4406 hash
= SXHASH_COMBINE (hash
, hash2
);
4413 /* Return a hash for bool-vector VECTOR. */
4416 sxhash_bool_vector (Lisp_Object vec
)
4418 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4421 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4422 for (i
= 0; i
< n
; ++i
)
4423 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4429 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4430 structure. Value is an unsigned integer clipped to INTMASK. */
4433 sxhash (Lisp_Object obj
, int depth
)
4437 if (depth
> SXHASH_MAX_DEPTH
)
4440 switch (XTYPE (obj
))
4451 obj
= SYMBOL_NAME (obj
);
4455 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4458 /* This can be everything from a vector to an overlay. */
4459 case Lisp_Vectorlike
:
4461 /* According to the CL HyperSpec, two arrays are equal only if
4462 they are `eq', except for strings and bit-vectors. In
4463 Emacs, this works differently. We have to compare element
4465 hash
= sxhash_vector (obj
, depth
);
4466 else if (BOOL_VECTOR_P (obj
))
4467 hash
= sxhash_bool_vector (obj
);
4469 /* Others are `equal' if they are `eq', so let's take their
4475 hash
= sxhash_list (obj
, depth
);
4480 double val
= XFLOAT_DATA (obj
);
4481 unsigned char *p
= (unsigned char *) &val
;
4482 unsigned char *e
= p
+ sizeof val
;
4483 for (hash
= 0; p
< e
; ++p
)
4484 hash
= SXHASH_COMBINE (hash
, *p
);
4492 return hash
& INTMASK
;
4497 /***********************************************************************
4499 ***********************************************************************/
4502 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4503 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4507 unsigned hash
= sxhash (obj
, 0);
4508 return make_number (hash
);
4512 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4513 doc
: /* Create and return a new hash table.
4515 Arguments are specified as keyword/argument pairs. The following
4516 arguments are defined:
4518 :test TEST -- TEST must be a symbol that specifies how to compare
4519 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4520 `equal'. User-supplied test and hash functions can be specified via
4521 `define-hash-table-test'.
4523 :size SIZE -- A hint as to how many elements will be put in the table.
4526 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4527 fills up. If REHASH-SIZE is an integer, add that many space. If it
4528 is a float, it must be > 1.0, and the new size is computed by
4529 multiplying the old size with that factor. Default is 1.5.
4531 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4532 Resize the hash table when ratio of the number of entries in the
4533 table. Default is 0.8.
4535 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4536 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4537 returned is a weak table. Key/value pairs are removed from a weak
4538 hash table when there are no non-weak references pointing to their
4539 key, value, one of key or value, or both key and value, depending on
4540 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4543 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4548 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4549 Lisp_Object user_test
, user_hash
;
4553 /* The vector `used' is used to keep track of arguments that
4554 have been consumed. */
4555 used
= (char *) alloca (nargs
* sizeof *used
);
4556 bzero (used
, nargs
* sizeof *used
);
4558 /* See if there's a `:test TEST' among the arguments. */
4559 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4560 test
= i
< 0 ? Qeql
: args
[i
];
4561 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4563 /* See if it is a user-defined test. */
4566 prop
= Fget (test
, Qhash_table_test
);
4567 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4568 signal_error ("Invalid hash table test", test
);
4569 user_test
= XCAR (prop
);
4570 user_hash
= XCAR (XCDR (prop
));
4573 user_test
= user_hash
= Qnil
;
4575 /* See if there's a `:size SIZE' argument. */
4576 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4577 size
= i
< 0 ? Qnil
: args
[i
];
4579 size
= make_number (DEFAULT_HASH_SIZE
);
4580 else if (!INTEGERP (size
) || XINT (size
) < 0)
4581 signal_error ("Invalid hash table size", size
);
4583 /* Look for `:rehash-size SIZE'. */
4584 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4585 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4586 if (!NUMBERP (rehash_size
)
4587 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4588 || XFLOATINT (rehash_size
) <= 1.0)
4589 signal_error ("Invalid hash table rehash size", rehash_size
);
4591 /* Look for `:rehash-threshold THRESHOLD'. */
4592 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4593 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4594 if (!FLOATP (rehash_threshold
)
4595 || XFLOATINT (rehash_threshold
) <= 0.0
4596 || XFLOATINT (rehash_threshold
) > 1.0)
4597 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4599 /* Look for `:weakness WEAK'. */
4600 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4601 weak
= i
< 0 ? Qnil
: args
[i
];
4603 weak
= Qkey_and_value
;
4606 && !EQ (weak
, Qvalue
)
4607 && !EQ (weak
, Qkey_or_value
)
4608 && !EQ (weak
, Qkey_and_value
))
4609 signal_error ("Invalid hash table weakness", weak
);
4611 /* Now, all args should have been used up, or there's a problem. */
4612 for (i
= 0; i
< nargs
; ++i
)
4614 signal_error ("Invalid argument list", args
[i
]);
4616 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4617 user_test
, user_hash
);
4621 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4622 doc
: /* Return a copy of hash table TABLE. */)
4626 return copy_hash_table (check_hash_table (table
));
4630 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4631 doc
: /* Return the number of elements in TABLE. */)
4635 return make_number (check_hash_table (table
)->count
);
4639 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4640 Shash_table_rehash_size
, 1, 1, 0,
4641 doc
: /* Return the current rehash size of TABLE. */)
4645 return check_hash_table (table
)->rehash_size
;
4649 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4650 Shash_table_rehash_threshold
, 1, 1, 0,
4651 doc
: /* Return the current rehash threshold of TABLE. */)
4655 return check_hash_table (table
)->rehash_threshold
;
4659 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4660 doc
: /* Return the size of TABLE.
4661 The size can be used as an argument to `make-hash-table' to create
4662 a hash table than can hold as many elements of TABLE holds
4663 without need for resizing. */)
4667 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4668 return make_number (HASH_TABLE_SIZE (h
));
4672 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4673 doc
: /* Return the test TABLE uses. */)
4677 return check_hash_table (table
)->test
;
4681 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4683 doc
: /* Return the weakness of TABLE. */)
4687 return check_hash_table (table
)->weak
;
4691 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4692 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4696 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4700 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4701 doc
: /* Clear hash table TABLE and return it. */)
4705 hash_clear (check_hash_table (table
));
4706 /* Be compatible with XEmacs. */
4711 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4712 doc
: /* Look up KEY in TABLE and return its associated value.
4713 If KEY is not found, return DFLT which defaults to nil. */)
4715 Lisp_Object key
, table
, dflt
;
4717 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4718 int i
= hash_lookup (h
, key
, NULL
);
4719 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4723 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4724 doc
: /* Associate KEY with VALUE in hash table TABLE.
4725 If KEY is already present in table, replace its current value with
4728 Lisp_Object key
, value
, table
;
4730 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4734 i
= hash_lookup (h
, key
, &hash
);
4736 HASH_VALUE (h
, i
) = value
;
4738 hash_put (h
, key
, value
, hash
);
4744 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4745 doc
: /* Remove KEY from TABLE. */)
4747 Lisp_Object key
, table
;
4749 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4750 hash_remove_from_table (h
, key
);
4755 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4756 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4757 FUNCTION is called with two arguments, KEY and VALUE. */)
4759 Lisp_Object function
, table
;
4761 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4762 Lisp_Object args
[3];
4765 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4766 if (!NILP (HASH_HASH (h
, i
)))
4769 args
[1] = HASH_KEY (h
, i
);
4770 args
[2] = HASH_VALUE (h
, i
);
4778 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4779 Sdefine_hash_table_test
, 3, 3, 0,
4780 doc
: /* Define a new hash table test with name NAME, a symbol.
4782 In hash tables created with NAME specified as test, use TEST to
4783 compare keys, and HASH for computing hash codes of keys.
4785 TEST must be a function taking two arguments and returning non-nil if
4786 both arguments are the same. HASH must be a function taking one
4787 argument and return an integer that is the hash code of the argument.
4788 Hash code computation should use the whole value range of integers,
4789 including negative integers. */)
4791 Lisp_Object name
, test
, hash
;
4793 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4798 /************************************************************************
4800 ************************************************************************/
4804 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4805 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4807 A message digest is a cryptographic checksum of a document, and the
4808 algorithm to calculate it is defined in RFC 1321.
4810 The two optional arguments START and END are character positions
4811 specifying for which part of OBJECT the message digest should be
4812 computed. If nil or omitted, the digest is computed for the whole
4815 The MD5 message digest is computed from the result of encoding the
4816 text in a coding system, not directly from the internal Emacs form of
4817 the text. The optional fourth argument CODING-SYSTEM specifies which
4818 coding system to encode the text with. It should be the same coding
4819 system that you used or will use when actually writing the text into a
4822 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4823 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4824 system would be chosen by default for writing this text into a file.
4826 If OBJECT is a string, the most preferred coding system (see the
4827 command `prefer-coding-system') is used.
4829 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4830 guesswork fails. Normally, an error is signaled in such case. */)
4831 (object
, start
, end
, coding_system
, noerror
)
4832 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4834 unsigned char digest
[16];
4835 unsigned char value
[33];
4839 int start_char
= 0, end_char
= 0;
4840 int start_byte
= 0, end_byte
= 0;
4842 register struct buffer
*bp
;
4845 if (STRINGP (object
))
4847 if (NILP (coding_system
))
4849 /* Decide the coding-system to encode the data with. */
4851 if (STRING_MULTIBYTE (object
))
4852 /* use default, we can't guess correct value */
4853 coding_system
= preferred_coding_system ();
4855 coding_system
= Qraw_text
;
4858 if (NILP (Fcoding_system_p (coding_system
)))
4860 /* Invalid coding system. */
4862 if (!NILP (noerror
))
4863 coding_system
= Qraw_text
;
4865 xsignal1 (Qcoding_system_error
, coding_system
);
4868 if (STRING_MULTIBYTE (object
))
4869 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4871 size
= SCHARS (object
);
4872 size_byte
= SBYTES (object
);
4876 CHECK_NUMBER (start
);
4878 start_char
= XINT (start
);
4883 start_byte
= string_char_to_byte (object
, start_char
);
4889 end_byte
= size_byte
;
4895 end_char
= XINT (end
);
4900 end_byte
= string_char_to_byte (object
, end_char
);
4903 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4904 args_out_of_range_3 (object
, make_number (start_char
),
4905 make_number (end_char
));
4909 struct buffer
*prev
= current_buffer
;
4911 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4913 CHECK_BUFFER (object
);
4915 bp
= XBUFFER (object
);
4916 if (bp
!= current_buffer
)
4917 set_buffer_internal (bp
);
4923 CHECK_NUMBER_COERCE_MARKER (start
);
4931 CHECK_NUMBER_COERCE_MARKER (end
);
4936 temp
= b
, b
= e
, e
= temp
;
4938 if (!(BEGV
<= b
&& e
<= ZV
))
4939 args_out_of_range (start
, end
);
4941 if (NILP (coding_system
))
4943 /* Decide the coding-system to encode the data with.
4944 See fileio.c:Fwrite-region */
4946 if (!NILP (Vcoding_system_for_write
))
4947 coding_system
= Vcoding_system_for_write
;
4950 int force_raw_text
= 0;
4952 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4953 if (NILP (coding_system
)
4954 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4956 coding_system
= Qnil
;
4957 if (NILP (current_buffer
->enable_multibyte_characters
))
4961 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4963 /* Check file-coding-system-alist. */
4964 Lisp_Object args
[4], val
;
4966 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4967 args
[3] = Fbuffer_file_name(object
);
4968 val
= Ffind_operation_coding_system (4, args
);
4969 if (CONSP (val
) && !NILP (XCDR (val
)))
4970 coding_system
= XCDR (val
);
4973 if (NILP (coding_system
)
4974 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4976 /* If we still have not decided a coding system, use the
4977 default value of buffer-file-coding-system. */
4978 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4982 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4983 /* Confirm that VAL can surely encode the current region. */
4984 coding_system
= call4 (Vselect_safe_coding_system_function
,
4985 make_number (b
), make_number (e
),
4986 coding_system
, Qnil
);
4989 coding_system
= Qraw_text
;
4992 if (NILP (Fcoding_system_p (coding_system
)))
4994 /* Invalid coding system. */
4996 if (!NILP (noerror
))
4997 coding_system
= Qraw_text
;
4999 xsignal1 (Qcoding_system_error
, coding_system
);
5003 object
= make_buffer_string (b
, e
, 0);
5004 if (prev
!= current_buffer
)
5005 set_buffer_internal (prev
);
5006 /* Discard the unwind protect for recovering the current
5010 if (STRING_MULTIBYTE (object
))
5011 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5014 md5_buffer (SDATA (object
) + start_byte
,
5015 SBYTES (object
) - (size_byte
- end_byte
),
5018 for (i
= 0; i
< 16; i
++)
5019 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5022 return make_string (value
, 32);
5029 /* Hash table stuff. */
5030 Qhash_table_p
= intern_c_string ("hash-table-p");
5031 staticpro (&Qhash_table_p
);
5032 Qeq
= intern_c_string ("eq");
5034 Qeql
= intern_c_string ("eql");
5036 Qequal
= intern_c_string ("equal");
5037 staticpro (&Qequal
);
5038 QCtest
= intern_c_string (":test");
5039 staticpro (&QCtest
);
5040 QCsize
= intern_c_string (":size");
5041 staticpro (&QCsize
);
5042 QCrehash_size
= intern_c_string (":rehash-size");
5043 staticpro (&QCrehash_size
);
5044 QCrehash_threshold
= intern_c_string (":rehash-threshold");
5045 staticpro (&QCrehash_threshold
);
5046 QCweakness
= intern_c_string (":weakness");
5047 staticpro (&QCweakness
);
5048 Qkey
= intern_c_string ("key");
5050 Qvalue
= intern_c_string ("value");
5051 staticpro (&Qvalue
);
5052 Qhash_table_test
= intern_c_string ("hash-table-test");
5053 staticpro (&Qhash_table_test
);
5054 Qkey_or_value
= intern_c_string ("key-or-value");
5055 staticpro (&Qkey_or_value
);
5056 Qkey_and_value
= intern_c_string ("key-and-value");
5057 staticpro (&Qkey_and_value
);
5060 defsubr (&Smake_hash_table
);
5061 defsubr (&Scopy_hash_table
);
5062 defsubr (&Shash_table_count
);
5063 defsubr (&Shash_table_rehash_size
);
5064 defsubr (&Shash_table_rehash_threshold
);
5065 defsubr (&Shash_table_size
);
5066 defsubr (&Shash_table_test
);
5067 defsubr (&Shash_table_weakness
);
5068 defsubr (&Shash_table_p
);
5069 defsubr (&Sclrhash
);
5070 defsubr (&Sgethash
);
5071 defsubr (&Sputhash
);
5072 defsubr (&Sremhash
);
5073 defsubr (&Smaphash
);
5074 defsubr (&Sdefine_hash_table_test
);
5076 Qstring_lessp
= intern_c_string ("string-lessp");
5077 staticpro (&Qstring_lessp
);
5078 Qprovide
= intern_c_string ("provide");
5079 staticpro (&Qprovide
);
5080 Qrequire
= intern_c_string ("require");
5081 staticpro (&Qrequire
);
5082 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
5083 staticpro (&Qyes_or_no_p_history
);
5084 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
5085 staticpro (&Qcursor_in_echo_area
);
5086 Qwidget_type
= intern_c_string ("widget-type");
5087 staticpro (&Qwidget_type
);
5089 staticpro (&string_char_byte_cache_string
);
5090 string_char_byte_cache_string
= Qnil
;
5092 require_nesting_list
= Qnil
;
5093 staticpro (&require_nesting_list
);
5095 Fset (Qyes_or_no_p_history
, Qnil
);
5097 DEFVAR_LISP ("features", &Vfeatures
,
5098 doc
: /* A list of symbols which are the features of the executing Emacs.
5099 Used by `featurep' and `require', and altered by `provide'. */);
5100 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
5101 Qsubfeatures
= intern_c_string ("subfeatures");
5102 staticpro (&Qsubfeatures
);
5104 #ifdef HAVE_LANGINFO_CODESET
5105 Qcodeset
= intern_c_string ("codeset");
5106 staticpro (&Qcodeset
);
5107 Qdays
= intern_c_string ("days");
5109 Qmonths
= intern_c_string ("months");
5110 staticpro (&Qmonths
);
5111 Qpaper
= intern_c_string ("paper");
5112 staticpro (&Qpaper
);
5113 #endif /* HAVE_LANGINFO_CODESET */
5115 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5116 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5117 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5118 invoked by mouse clicks and mouse menu items.
5120 On some platforms, file selection dialogs are also enabled if this is
5124 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5125 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5126 This applies to commands from menus and tool bar buttons even when
5127 they are initiated from the keyboard. If `use-dialog-box' is nil,
5128 that disables the use of a file dialog, regardless of the value of
5130 use_file_dialog
= 1;
5132 defsubr (&Sidentity
);
5135 defsubr (&Ssafe_length
);
5136 defsubr (&Sstring_bytes
);
5137 defsubr (&Sstring_equal
);
5138 defsubr (&Scompare_strings
);
5139 defsubr (&Sstring_lessp
);
5142 defsubr (&Svconcat
);
5143 defsubr (&Scopy_sequence
);
5144 defsubr (&Sstring_make_multibyte
);
5145 defsubr (&Sstring_make_unibyte
);
5146 defsubr (&Sstring_as_multibyte
);
5147 defsubr (&Sstring_as_unibyte
);
5148 defsubr (&Sstring_to_multibyte
);
5149 defsubr (&Sstring_to_unibyte
);
5150 defsubr (&Scopy_alist
);
5151 defsubr (&Ssubstring
);
5152 defsubr (&Ssubstring_no_properties
);
5165 defsubr (&Snreverse
);
5166 defsubr (&Sreverse
);
5168 defsubr (&Splist_get
);
5170 defsubr (&Splist_put
);
5172 defsubr (&Slax_plist_get
);
5173 defsubr (&Slax_plist_put
);
5176 defsubr (&Sequal_including_properties
);
5177 defsubr (&Sfillarray
);
5178 defsubr (&Sclear_string
);
5182 defsubr (&Smapconcat
);
5183 defsubr (&Sy_or_n_p
);
5184 defsubr (&Syes_or_no_p
);
5185 defsubr (&Sload_average
);
5186 defsubr (&Sfeaturep
);
5187 defsubr (&Srequire
);
5188 defsubr (&Sprovide
);
5189 defsubr (&Splist_member
);
5190 defsubr (&Swidget_put
);
5191 defsubr (&Swidget_get
);
5192 defsubr (&Swidget_apply
);
5193 defsubr (&Sbase64_encode_region
);
5194 defsubr (&Sbase64_decode_region
);
5195 defsubr (&Sbase64_encode_string
);
5196 defsubr (&Sbase64_decode_string
);
5198 defsubr (&Slocale_info
);
5207 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5208 (do not change this comment) */