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 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
36 #include "character.h"
41 #include "intervals.h"
44 #include "blockinput.h"
46 #if defined (HAVE_X_WINDOWS)
49 #endif /* HAVE_MENUS */
52 #define NULL ((POINTER_TYPE *)0)
55 /* Nonzero enables use of dialog boxes for questions
56 asked by mouse commands. */
59 /* Nonzero enables use of a file dialog for file name
60 questions asked by mouse commands. */
63 extern int minibuffer_auto_raise
;
64 extern Lisp_Object minibuf_window
;
65 extern Lisp_Object Vlocale_coding_system
;
66 extern int load_in_progress
;
68 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
69 Lisp_Object Qyes_or_no_p_history
;
70 Lisp_Object Qcursor_in_echo_area
;
71 Lisp_Object Qwidget_type
;
72 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
74 extern Lisp_Object Qinput_method_function
;
76 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
78 extern long get_random ();
79 extern void seed_random
P_ ((long));
85 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
86 doc
: /* Return the argument unchanged. */)
93 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
94 doc
: /* Return a pseudo-random number.
95 All integers representable in Lisp are equally likely.
96 On most systems, this is 29 bits' worth.
97 With positive integer LIMIT, return random number in interval [0,LIMIT).
98 With argument t, set the random number seed from the current time and pid.
99 Other values of LIMIT are ignored. */)
104 Lisp_Object lispy_val
;
105 unsigned long denominator
;
108 seed_random (getpid () + time (NULL
));
109 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
111 /* Try to take our random number from the higher bits of VAL,
112 not the lower, since (says Gentzel) the low bits of `random'
113 are less random than the higher ones. We do this by using the
114 quotient rather than the remainder. At the high end of the RNG
115 it's possible to get a quotient larger than n; discarding
116 these values eliminates the bias that would otherwise appear
117 when using a large n. */
118 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
120 val
= get_random () / denominator
;
121 while (val
>= XFASTINT (limit
));
125 XSETINT (lispy_val
, val
);
129 /* Random data-structure functions */
131 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
132 doc
: /* Return the length of vector, list or string SEQUENCE.
133 A byte-code function object is also allowed.
134 If the string contains multibyte characters, this is not necessarily
135 the number of bytes in the string; it is the number of characters.
136 To get the number of bytes, use `string-bytes'. */)
138 register Lisp_Object sequence
;
140 register Lisp_Object val
;
143 if (STRINGP (sequence
))
144 XSETFASTINT (val
, SCHARS (sequence
));
145 else if (VECTORP (sequence
))
146 XSETFASTINT (val
, ASIZE (sequence
));
147 else if (CHAR_TABLE_P (sequence
))
148 XSETFASTINT (val
, MAX_CHAR
);
149 else if (BOOL_VECTOR_P (sequence
))
150 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
151 else if (COMPILEDP (sequence
))
152 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
153 else if (CONSP (sequence
))
156 while (CONSP (sequence
))
158 sequence
= XCDR (sequence
);
161 if (!CONSP (sequence
))
164 sequence
= XCDR (sequence
);
169 CHECK_LIST_END (sequence
, sequence
);
171 val
= make_number (i
);
173 else if (NILP (sequence
))
174 XSETFASTINT (val
, 0);
176 wrong_type_argument (Qsequencep
, sequence
);
181 /* This does not check for quits. That is safe since it must terminate. */
183 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
184 doc
: /* Return the length of a list, but avoid error or infinite loop.
185 This function never gets an error. If LIST is not really a list,
186 it returns 0. If LIST is circular, it returns a finite value
187 which is at least the number of distinct elements. */)
191 Lisp_Object tail
, halftail
, length
;
194 /* halftail is used to detect circular lists. */
196 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
198 if (EQ (tail
, halftail
) && len
!= 0)
202 halftail
= XCDR (halftail
);
205 XSETINT (length
, len
);
209 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
210 doc
: /* Return the number of bytes in STRING.
211 If STRING is multibyte, this may be greater than the length of STRING. */)
215 CHECK_STRING (string
);
216 return make_number (SBYTES (string
));
219 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
220 doc
: /* Return t if two strings have identical contents.
221 Case is significant, but text properties are ignored.
222 Symbols are also allowed; their print names are used instead. */)
224 register Lisp_Object s1
, s2
;
227 s1
= SYMBOL_NAME (s1
);
229 s2
= SYMBOL_NAME (s2
);
233 if (SCHARS (s1
) != SCHARS (s2
)
234 || SBYTES (s1
) != SBYTES (s2
)
235 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
240 DEFUN ("compare-strings", Fcompare_strings
,
241 Scompare_strings
, 6, 7, 0,
242 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
243 In string STR1, skip the first START1 characters and stop at END1.
244 In string STR2, skip the first START2 characters and stop at END2.
245 END1 and END2 default to the full lengths of the respective strings.
247 Case is significant in this comparison if IGNORE-CASE is nil.
248 Unibyte strings are converted to multibyte for comparison.
250 The value is t if the strings (or specified portions) match.
251 If string STR1 is less, the value is a negative number N;
252 - 1 - N is the number of characters that match at the beginning.
253 If string STR1 is greater, the value is a positive number N;
254 N - 1 is the number of characters that match at the beginning. */)
255 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
256 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
258 register int end1_char
, end2_char
;
259 register int i1
, i1_byte
, i2
, i2_byte
;
264 start1
= make_number (0);
266 start2
= make_number (0);
267 CHECK_NATNUM (start1
);
268 CHECK_NATNUM (start2
);
277 i1_byte
= string_char_to_byte (str1
, i1
);
278 i2_byte
= string_char_to_byte (str2
, i2
);
280 end1_char
= SCHARS (str1
);
281 if (! NILP (end1
) && end1_char
> XINT (end1
))
282 end1_char
= XINT (end1
);
284 end2_char
= SCHARS (str2
);
285 if (! NILP (end2
) && end2_char
> XINT (end2
))
286 end2_char
= XINT (end2
);
288 while (i1
< end1_char
&& i2
< end2_char
)
290 /* When we find a mismatch, we must compare the
291 characters, not just the bytes. */
294 if (STRING_MULTIBYTE (str1
))
295 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
298 c1
= SREF (str1
, i1
++);
299 MAKE_CHAR_MULTIBYTE (c1
);
302 if (STRING_MULTIBYTE (str2
))
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
306 c2
= SREF (str2
, i2
++);
307 MAKE_CHAR_MULTIBYTE (c2
);
313 if (! NILP (ignore_case
))
317 tem
= Fupcase (make_number (c1
));
319 tem
= Fupcase (make_number (c2
));
326 /* Note that I1 has already been incremented
327 past the character that we are comparing;
328 hence we don't add or subtract 1 here. */
330 return make_number (- i1
+ XINT (start1
));
332 return make_number (i1
- XINT (start1
));
336 return make_number (i1
- XINT (start1
) + 1);
338 return make_number (- i1
+ XINT (start1
) - 1);
343 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
344 doc
: /* Return t if first arg string is less than second in lexicographic order.
346 Symbols are also allowed; their print names are used instead. */)
348 register Lisp_Object s1
, s2
;
351 register int i1
, i1_byte
, i2
, i2_byte
;
354 s1
= SYMBOL_NAME (s1
);
356 s2
= SYMBOL_NAME (s2
);
360 i1
= i1_byte
= i2
= i2_byte
= 0;
363 if (end
> SCHARS (s2
))
368 /* When we find a mismatch, we must compare the
369 characters, not just the bytes. */
372 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
373 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
376 return c1
< c2
? Qt
: Qnil
;
378 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
382 /* "gcc -O3" enables automatic function inlining, which optimizes out
383 the arguments for the invocations of this function, whereas it
384 expects these values on the stack. */
385 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
386 #else /* !__GNUC__ */
387 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
398 return concat (2, args
, Lisp_String
, 0);
404 Lisp_Object s1
, s2
, s3
;
410 return concat (3, args
, Lisp_String
, 0);
413 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
414 doc
: /* Concatenate all the arguments and make the result a list.
415 The result is a list whose elements are the elements of all the arguments.
416 Each argument may be a list, vector or string.
417 The last argument is not copied, just used as the tail of the new list.
418 usage: (append &rest SEQUENCES) */)
423 return concat (nargs
, args
, Lisp_Cons
, 1);
426 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
427 doc
: /* Concatenate all the arguments and make the result a string.
428 The result is a string whose elements are the elements of all the arguments.
429 Each argument may be a string or a list or vector of characters (integers).
430 usage: (concat &rest SEQUENCES) */)
435 return concat (nargs
, args
, Lisp_String
, 0);
438 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
439 doc
: /* Concatenate all the arguments and make the result a vector.
440 The result is a vector whose elements are the elements of all the arguments.
441 Each argument may be a list, vector or string.
442 usage: (vconcat &rest SEQUENCES) */)
447 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
451 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
452 doc
: /* Return a copy of a list, vector, string or char-table.
453 The elements of a list or vector are not copied; they are shared
454 with the original. */)
458 if (NILP (arg
)) return arg
;
460 if (CHAR_TABLE_P (arg
))
462 return copy_char_table (arg
);
465 if (BOOL_VECTOR_P (arg
))
469 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
470 / BOOL_VECTOR_BITS_PER_CHAR
);
472 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
473 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
478 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
479 wrong_type_argument (Qsequencep
, arg
);
481 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
484 /* This structure holds information of an argument of `concat' that is
485 a string and has text properties to be copied. */
488 int argnum
; /* refer to ARGS (arguments of `concat') */
489 int from
; /* refer to ARGS[argnum] (argument string) */
490 int to
; /* refer to VAL (the target string) */
494 concat (nargs
, args
, target_type
, last_special
)
497 enum Lisp_Type target_type
;
501 register Lisp_Object tail
;
502 register Lisp_Object
this;
504 int toindex_byte
= 0;
505 register int result_len
;
506 register int result_len_byte
;
508 Lisp_Object last_tail
;
511 /* When we make a multibyte string, we can't copy text properties
512 while concatinating each string because the length of resulting
513 string can't be decided until we finish the whole concatination.
514 So, we record strings that have text properties to be copied
515 here, and copy the text properties after the concatination. */
516 struct textprop_rec
*textprops
= NULL
;
517 /* Number of elments in textprops. */
518 int num_textprops
= 0;
523 /* In append, the last arg isn't treated like the others */
524 if (last_special
&& nargs
> 0)
527 last_tail
= args
[nargs
];
532 /* Check each argument. */
533 for (argnum
= 0; argnum
< nargs
; argnum
++)
536 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
537 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
538 wrong_type_argument (Qsequencep
, this);
541 /* Compute total length in chars of arguments in RESULT_LEN.
542 If desired output is a string, also compute length in bytes
543 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
544 whether the result should be a multibyte string. */
548 for (argnum
= 0; argnum
< nargs
; argnum
++)
552 len
= XFASTINT (Flength (this));
553 if (target_type
== Lisp_String
)
555 /* We must count the number of bytes needed in the string
556 as well as the number of characters. */
562 for (i
= 0; i
< len
; i
++)
565 CHECK_CHARACTER (ch
);
566 this_len_byte
= CHAR_BYTES (XINT (ch
));
567 result_len_byte
+= this_len_byte
;
568 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
571 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
572 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
573 else if (CONSP (this))
574 for (; CONSP (this); this = XCDR (this))
577 CHECK_CHARACTER (ch
);
578 this_len_byte
= CHAR_BYTES (XINT (ch
));
579 result_len_byte
+= this_len_byte
;
580 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
583 else if (STRINGP (this))
585 if (STRING_MULTIBYTE (this))
588 result_len_byte
+= SBYTES (this);
591 result_len_byte
+= count_size_as_multibyte (SDATA (this),
598 error ("String overflow");
601 if (! some_multibyte
)
602 result_len_byte
= result_len
;
604 /* Create the output object. */
605 if (target_type
== Lisp_Cons
)
606 val
= Fmake_list (make_number (result_len
), Qnil
);
607 else if (target_type
== Lisp_Vectorlike
)
608 val
= Fmake_vector (make_number (result_len
), Qnil
);
609 else if (some_multibyte
)
610 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
612 val
= make_uninit_string (result_len
);
614 /* In `append', if all but last arg are nil, return last arg. */
615 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
618 /* Copy the contents of the args into the result. */
620 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
622 toindex
= 0, toindex_byte
= 0;
626 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
628 for (argnum
= 0; argnum
< nargs
; argnum
++)
632 register unsigned int thisindex
= 0;
633 register unsigned int thisindex_byte
= 0;
637 thislen
= Flength (this), thisleni
= XINT (thislen
);
639 /* Between strings of the same kind, copy fast. */
640 if (STRINGP (this) && STRINGP (val
)
641 && STRING_MULTIBYTE (this) == some_multibyte
)
643 int thislen_byte
= SBYTES (this);
645 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
647 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
649 textprops
[num_textprops
].argnum
= argnum
;
650 textprops
[num_textprops
].from
= 0;
651 textprops
[num_textprops
++].to
= toindex
;
653 toindex_byte
+= thislen_byte
;
656 /* Copy a single-byte string to a multibyte string. */
657 else if (STRINGP (this) && STRINGP (val
))
659 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
661 textprops
[num_textprops
].argnum
= argnum
;
662 textprops
[num_textprops
].from
= 0;
663 textprops
[num_textprops
++].to
= toindex
;
665 toindex_byte
+= copy_text (SDATA (this),
666 SDATA (val
) + toindex_byte
,
667 SCHARS (this), 0, 1);
671 /* Copy element by element. */
674 register Lisp_Object elt
;
676 /* Fetch next element of `this' arg into `elt', or break if
677 `this' is exhausted. */
678 if (NILP (this)) break;
680 elt
= XCAR (this), this = XCDR (this);
681 else if (thisindex
>= thisleni
)
683 else if (STRINGP (this))
686 if (STRING_MULTIBYTE (this))
688 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
691 XSETFASTINT (elt
, c
);
695 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
697 && !ASCII_CHAR_P (XINT (elt
))
698 && XINT (elt
) < 0400)
700 c
= BYTE8_TO_CHAR (XINT (elt
));
705 else if (BOOL_VECTOR_P (this))
708 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
709 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
717 elt
= AREF (this, thisindex
);
721 /* Store this element into the result. */
728 else if (VECTORP (val
))
730 ASET (val
, toindex
, elt
);
737 toindex_byte
+= CHAR_STRING (XINT (elt
),
738 SDATA (val
) + toindex_byte
);
740 SSET (val
, toindex_byte
++, XINT (elt
));
746 XSETCDR (prev
, last_tail
);
748 if (num_textprops
> 0)
751 int last_to_end
= -1;
753 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
755 this = args
[textprops
[argnum
].argnum
];
756 props
= text_property_list (this,
758 make_number (SCHARS (this)),
760 /* If successive arguments have properites, be sure that the
761 value of `composition' property be the copy. */
762 if (last_to_end
== textprops
[argnum
].to
)
763 make_composition_value_copy (props
);
764 add_text_properties_from_list (val
, props
,
765 make_number (textprops
[argnum
].to
));
766 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
774 static Lisp_Object string_char_byte_cache_string
;
775 static EMACS_INT string_char_byte_cache_charpos
;
776 static EMACS_INT string_char_byte_cache_bytepos
;
779 clear_string_char_byte_cache ()
781 string_char_byte_cache_string
= Qnil
;
784 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
787 string_char_to_byte (string
, char_index
)
789 EMACS_INT char_index
;
792 EMACS_INT best_below
, best_below_byte
;
793 EMACS_INT best_above
, best_above_byte
;
795 best_below
= best_below_byte
= 0;
796 best_above
= SCHARS (string
);
797 best_above_byte
= SBYTES (string
);
798 if (best_above
== best_above_byte
)
801 if (EQ (string
, string_char_byte_cache_string
))
803 if (string_char_byte_cache_charpos
< char_index
)
805 best_below
= string_char_byte_cache_charpos
;
806 best_below_byte
= string_char_byte_cache_bytepos
;
810 best_above
= string_char_byte_cache_charpos
;
811 best_above_byte
= string_char_byte_cache_bytepos
;
815 if (char_index
- best_below
< best_above
- char_index
)
817 unsigned char *p
= SDATA (string
) + best_below_byte
;
819 while (best_below
< char_index
)
821 p
+= BYTES_BY_CHAR_HEAD (*p
);
824 i_byte
= p
- SDATA (string
);
828 unsigned char *p
= SDATA (string
) + best_above_byte
;
830 while (best_above
> char_index
)
833 while (!CHAR_HEAD_P (*p
)) p
--;
836 i_byte
= p
- SDATA (string
);
839 string_char_byte_cache_bytepos
= i_byte
;
840 string_char_byte_cache_charpos
= char_index
;
841 string_char_byte_cache_string
= string
;
846 /* Return the character index corresponding to BYTE_INDEX in STRING. */
849 string_byte_to_char (string
, byte_index
)
851 EMACS_INT byte_index
;
854 EMACS_INT best_below
, best_below_byte
;
855 EMACS_INT best_above
, best_above_byte
;
857 best_below
= best_below_byte
= 0;
858 best_above
= SCHARS (string
);
859 best_above_byte
= SBYTES (string
);
860 if (best_above
== best_above_byte
)
863 if (EQ (string
, string_char_byte_cache_string
))
865 if (string_char_byte_cache_bytepos
< byte_index
)
867 best_below
= string_char_byte_cache_charpos
;
868 best_below_byte
= string_char_byte_cache_bytepos
;
872 best_above
= string_char_byte_cache_charpos
;
873 best_above_byte
= string_char_byte_cache_bytepos
;
877 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
879 unsigned char *p
= SDATA (string
) + best_below_byte
;
880 unsigned char *pend
= SDATA (string
) + byte_index
;
884 p
+= BYTES_BY_CHAR_HEAD (*p
);
888 i_byte
= p
- SDATA (string
);
892 unsigned char *p
= SDATA (string
) + best_above_byte
;
893 unsigned char *pbeg
= SDATA (string
) + byte_index
;
898 while (!CHAR_HEAD_P (*p
)) p
--;
902 i_byte
= p
- SDATA (string
);
905 string_char_byte_cache_bytepos
= i_byte
;
906 string_char_byte_cache_charpos
= i
;
907 string_char_byte_cache_string
= string
;
912 /* Convert STRING to a multibyte string. */
915 string_make_multibyte (string
)
923 if (STRING_MULTIBYTE (string
))
926 nbytes
= count_size_as_multibyte (SDATA (string
),
928 /* If all the chars are ASCII, they won't need any more bytes
929 once converted. In that case, we can return STRING itself. */
930 if (nbytes
== SBYTES (string
))
933 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
934 copy_text (SDATA (string
), buf
, SBYTES (string
),
937 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
944 /* Convert STRING (if unibyte) to a multibyte string without changing
945 the number of characters. Characters 0200 trough 0237 are
946 converted to eight-bit characters. */
949 string_to_multibyte (string
)
957 if (STRING_MULTIBYTE (string
))
960 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
961 /* If all the chars are ASCII, they won't need any more bytes once
963 if (nbytes
== SBYTES (string
))
964 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
966 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
967 bcopy (SDATA (string
), buf
, SBYTES (string
));
968 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
970 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
977 /* Convert STRING to a single-byte string. */
980 string_make_unibyte (string
)
988 if (! STRING_MULTIBYTE (string
))
991 nchars
= SCHARS (string
);
993 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
994 copy_text (SDATA (string
), buf
, SBYTES (string
),
997 ret
= make_unibyte_string (buf
, nchars
);
1003 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1005 doc
: /* Return the multibyte equivalent of STRING.
1006 If STRING is unibyte and contains non-ASCII characters, the function
1007 `unibyte-char-to-multibyte' is used to convert each unibyte character
1008 to a multibyte character. In this case, the returned string is a
1009 newly created string with no text properties. If STRING is multibyte
1010 or entirely ASCII, it is returned unchanged. In particular, when
1011 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1012 \(When the characters are all ASCII, Emacs primitives will treat the
1013 string the same way whether it is unibyte or multibyte.) */)
1017 CHECK_STRING (string
);
1019 return string_make_multibyte (string
);
1022 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1024 doc
: /* Return the unibyte equivalent of STRING.
1025 Multibyte character codes are converted to unibyte according to
1026 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1027 If the lookup in the translation table fails, this function takes just
1028 the low 8 bits of each character. */)
1032 CHECK_STRING (string
);
1034 return string_make_unibyte (string
);
1037 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1039 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1040 If STRING is unibyte, the result is STRING itself.
1041 Otherwise it is a newly created string, with no text properties.
1042 If STRING is multibyte and contains a character of charset
1043 `eight-bit', it is converted to the corresponding single byte. */)
1047 CHECK_STRING (string
);
1049 if (STRING_MULTIBYTE (string
))
1051 int bytes
= SBYTES (string
);
1052 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1054 bcopy (SDATA (string
), str
, bytes
);
1055 bytes
= str_as_unibyte (str
, bytes
);
1056 string
= make_unibyte_string (str
, bytes
);
1062 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1064 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1065 If STRING is multibyte, the result is STRING itself.
1066 Otherwise it is a newly created string, with no text properties.
1068 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1069 part of a correct utf-8 sequence), it is converted to the corresponding
1070 multibyte character of charset `eight-bit'.
1071 See also `string-to-multibyte'.
1073 Beware, this often doesn't really do what you think it does.
1074 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1075 If you're not sure, whether to use `string-as-multibyte' or
1076 `string-to-multibyte', use `string-to-multibyte'. */)
1080 CHECK_STRING (string
);
1082 if (! STRING_MULTIBYTE (string
))
1084 Lisp_Object new_string
;
1087 parse_str_as_multibyte (SDATA (string
),
1090 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1091 bcopy (SDATA (string
), SDATA (new_string
),
1093 if (nbytes
!= SBYTES (string
))
1094 str_as_multibyte (SDATA (new_string
), nbytes
,
1095 SBYTES (string
), NULL
);
1096 string
= new_string
;
1097 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1102 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1104 doc
: /* Return a multibyte string with the same individual chars as STRING.
1105 If STRING is multibyte, the result is STRING itself.
1106 Otherwise it is a newly created string, with no text properties.
1108 If STRING is unibyte and contains an 8-bit byte, it is converted to
1109 the corresponding multibyte character of charset `eight-bit'.
1111 This differs from `string-as-multibyte' by converting each byte of a correct
1112 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1113 correct sequence. */)
1117 CHECK_STRING (string
);
1119 return string_to_multibyte (string
);
1122 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1124 doc
: /* Return a unibyte string with the same individual chars as STRING.
1125 If STRING is unibyte, the result is STRING itself.
1126 Otherwise it is a newly created string, with no text properties,
1127 where each `eight-bit' character is converted to the corresponding byte.
1128 If STRING contains a non-ASCII, non-`eight-bit' character,
1129 an error is signaled. */)
1133 CHECK_STRING (string
);
1135 if (STRING_MULTIBYTE (string
))
1137 EMACS_INT chars
= SCHARS (string
);
1138 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1139 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1141 if (converted
< chars
)
1142 error ("Can't convert the %dth character to unibyte", converted
);
1143 string
= make_unibyte_string (str
, chars
);
1150 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1151 doc
: /* Return a copy of ALIST.
1152 This is an alist which represents the same mapping from objects to objects,
1153 but does not share the alist structure with ALIST.
1154 The objects mapped (cars and cdrs of elements of the alist)
1155 are shared, however.
1156 Elements of ALIST that are not conses are also shared. */)
1160 register Lisp_Object tem
;
1165 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1166 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1168 register Lisp_Object car
;
1172 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1177 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1178 doc
: /* Return a new string whose contents are a substring of STRING.
1179 The returned string consists of the characters between index FROM
1180 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1181 zero-indexed: 0 means the first character of STRING. Negative values
1182 are counted from the end of STRING. If TO is nil, the substring runs
1183 to the end of STRING.
1185 The STRING argument may also be a vector. In that case, the return
1186 value is a new vector that contains the elements between index FROM
1187 \(inclusive) and index TO (exclusive) of that vector argument. */)
1190 register Lisp_Object from
, to
;
1195 int from_char
, to_char
;
1196 int from_byte
= 0, to_byte
= 0;
1198 CHECK_VECTOR_OR_STRING (string
);
1199 CHECK_NUMBER (from
);
1201 if (STRINGP (string
))
1203 size
= SCHARS (string
);
1204 size_byte
= SBYTES (string
);
1207 size
= ASIZE (string
);
1212 to_byte
= size_byte
;
1218 to_char
= XINT (to
);
1222 if (STRINGP (string
))
1223 to_byte
= string_char_to_byte (string
, to_char
);
1226 from_char
= XINT (from
);
1229 if (STRINGP (string
))
1230 from_byte
= string_char_to_byte (string
, from_char
);
1232 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1233 args_out_of_range_3 (string
, make_number (from_char
),
1234 make_number (to_char
));
1236 if (STRINGP (string
))
1238 res
= make_specified_string (SDATA (string
) + from_byte
,
1239 to_char
- from_char
, to_byte
- from_byte
,
1240 STRING_MULTIBYTE (string
));
1241 copy_text_properties (make_number (from_char
), make_number (to_char
),
1242 string
, make_number (0), res
, Qnil
);
1245 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1251 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1252 doc
: /* Return a substring of STRING, without text properties.
1253 It starts at index FROM and ending before TO.
1254 TO may be nil or omitted; then the substring runs to the end of STRING.
1255 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1256 If FROM or TO is negative, it counts from the end.
1258 With one argument, just copy STRING without its properties. */)
1261 register Lisp_Object from
, to
;
1263 int size
, size_byte
;
1264 int from_char
, to_char
;
1265 int from_byte
, to_byte
;
1267 CHECK_STRING (string
);
1269 size
= SCHARS (string
);
1270 size_byte
= SBYTES (string
);
1273 from_char
= from_byte
= 0;
1276 CHECK_NUMBER (from
);
1277 from_char
= XINT (from
);
1281 from_byte
= string_char_to_byte (string
, from_char
);
1287 to_byte
= size_byte
;
1293 to_char
= XINT (to
);
1297 to_byte
= string_char_to_byte (string
, to_char
);
1300 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1301 args_out_of_range_3 (string
, make_number (from_char
),
1302 make_number (to_char
));
1304 return make_specified_string (SDATA (string
) + from_byte
,
1305 to_char
- from_char
, to_byte
- from_byte
,
1306 STRING_MULTIBYTE (string
));
1309 /* Extract a substring of STRING, giving start and end positions
1310 both in characters and in bytes. */
1313 substring_both (string
, from
, from_byte
, to
, to_byte
)
1315 int from
, from_byte
, to
, to_byte
;
1321 CHECK_VECTOR_OR_STRING (string
);
1323 if (STRINGP (string
))
1325 size
= SCHARS (string
);
1326 size_byte
= SBYTES (string
);
1329 size
= ASIZE (string
);
1331 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1332 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1334 if (STRINGP (string
))
1336 res
= make_specified_string (SDATA (string
) + from_byte
,
1337 to
- from
, to_byte
- from_byte
,
1338 STRING_MULTIBYTE (string
));
1339 copy_text_properties (make_number (from
), make_number (to
),
1340 string
, make_number (0), res
, Qnil
);
1343 res
= Fvector (to
- from
, &AREF (string
, from
));
1348 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1349 doc
: /* Take cdr N times on LIST, returns the result. */)
1352 register Lisp_Object list
;
1354 register int i
, num
;
1357 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1360 CHECK_LIST_CONS (list
, list
);
1366 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1367 doc
: /* Return the Nth element of LIST.
1368 N counts from zero. If LIST is not that long, nil is returned. */)
1370 Lisp_Object n
, list
;
1372 return Fcar (Fnthcdr (n
, list
));
1375 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1376 doc
: /* Return element of SEQUENCE at index N. */)
1378 register Lisp_Object sequence
, n
;
1381 if (CONSP (sequence
) || NILP (sequence
))
1382 return Fcar (Fnthcdr (n
, sequence
));
1384 /* Faref signals a "not array" error, so check here. */
1385 CHECK_ARRAY (sequence
, Qsequencep
);
1386 return Faref (sequence
, n
);
1389 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1390 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1391 The value is actually the tail of LIST whose car is ELT. */)
1393 register Lisp_Object elt
;
1396 register Lisp_Object tail
;
1397 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1399 register Lisp_Object tem
;
1400 CHECK_LIST_CONS (tail
, list
);
1402 if (! NILP (Fequal (elt
, tem
)))
1409 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1410 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1411 The value is actually the tail of LIST whose car is ELT. */)
1413 register Lisp_Object elt
, list
;
1417 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1421 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1425 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1436 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1437 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1438 The value is actually the tail of LIST whose car is ELT. */)
1440 register Lisp_Object elt
;
1443 register Lisp_Object tail
;
1446 return Fmemq (elt
, list
);
1448 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1450 register Lisp_Object tem
;
1451 CHECK_LIST_CONS (tail
, list
);
1453 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1460 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1461 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1462 The value is actually the first element of LIST whose car is KEY.
1463 Elements of LIST that are not conses are ignored. */)
1465 Lisp_Object key
, list
;
1470 || (CONSP (XCAR (list
))
1471 && EQ (XCAR (XCAR (list
)), key
)))
1476 || (CONSP (XCAR (list
))
1477 && EQ (XCAR (XCAR (list
)), key
)))
1482 || (CONSP (XCAR (list
))
1483 && EQ (XCAR (XCAR (list
)), key
)))
1493 /* Like Fassq but never report an error and do not allow quits.
1494 Use only on lists known never to be circular. */
1497 assq_no_quit (key
, list
)
1498 Lisp_Object key
, list
;
1501 && (!CONSP (XCAR (list
))
1502 || !EQ (XCAR (XCAR (list
)), key
)))
1505 return CAR_SAFE (list
);
1508 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1509 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1510 The value is actually the first element of LIST whose car equals KEY. */)
1512 Lisp_Object key
, list
;
1519 || (CONSP (XCAR (list
))
1520 && (car
= XCAR (XCAR (list
)),
1521 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1526 || (CONSP (XCAR (list
))
1527 && (car
= XCAR (XCAR (list
)),
1528 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1533 || (CONSP (XCAR (list
))
1534 && (car
= XCAR (XCAR (list
)),
1535 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1545 /* Like Fassoc but never report an error and do not allow quits.
1546 Use only on lists known never to be circular. */
1549 assoc_no_quit (key
, list
)
1550 Lisp_Object key
, list
;
1553 && (!CONSP (XCAR (list
))
1554 || (!EQ (XCAR (XCAR (list
)), key
)
1555 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1558 return CONSP (list
) ? XCAR (list
) : Qnil
;
1561 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1562 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1563 The value is actually the first element of LIST whose cdr is KEY. */)
1565 register Lisp_Object key
;
1571 || (CONSP (XCAR (list
))
1572 && EQ (XCDR (XCAR (list
)), key
)))
1577 || (CONSP (XCAR (list
))
1578 && EQ (XCDR (XCAR (list
)), key
)))
1583 || (CONSP (XCAR (list
))
1584 && EQ (XCDR (XCAR (list
)), key
)))
1594 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1595 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1596 The value is actually the first element of LIST whose cdr equals KEY. */)
1598 Lisp_Object key
, list
;
1605 || (CONSP (XCAR (list
))
1606 && (cdr
= XCDR (XCAR (list
)),
1607 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1612 || (CONSP (XCAR (list
))
1613 && (cdr
= XCDR (XCAR (list
)),
1614 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1619 || (CONSP (XCAR (list
))
1620 && (cdr
= XCDR (XCAR (list
)),
1621 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1631 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1632 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1633 The modified LIST is returned. Comparison is done with `eq'.
1634 If the first member of LIST is ELT, there is no way to remove it by side effect;
1635 therefore, write `(setq foo (delq element foo))'
1636 to be sure of changing the value of `foo'. */)
1638 register Lisp_Object elt
;
1641 register Lisp_Object tail
, prev
;
1642 register Lisp_Object tem
;
1646 while (!NILP (tail
))
1648 CHECK_LIST_CONS (tail
, list
);
1655 Fsetcdr (prev
, XCDR (tail
));
1665 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1666 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1667 SEQ must be a list, a vector, or a string.
1668 The modified SEQ is returned. Comparison is done with `equal'.
1669 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1670 is not a side effect; it is simply using a different sequence.
1671 Therefore, write `(setq foo (delete element foo))'
1672 to be sure of changing the value of `foo'. */)
1674 Lisp_Object elt
, seq
;
1680 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1681 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1684 if (n
!= ASIZE (seq
))
1686 struct Lisp_Vector
*p
= allocate_vector (n
);
1688 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1689 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1690 p
->contents
[n
++] = AREF (seq
, i
);
1692 XSETVECTOR (seq
, p
);
1695 else if (STRINGP (seq
))
1697 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1700 for (i
= nchars
= nbytes
= ibyte
= 0;
1702 ++i
, ibyte
+= cbytes
)
1704 if (STRING_MULTIBYTE (seq
))
1706 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1707 cbytes
= CHAR_BYTES (c
);
1715 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1722 if (nchars
!= SCHARS (seq
))
1726 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1727 if (!STRING_MULTIBYTE (seq
))
1728 STRING_SET_UNIBYTE (tem
);
1730 for (i
= nchars
= nbytes
= ibyte
= 0;
1732 ++i
, ibyte
+= cbytes
)
1734 if (STRING_MULTIBYTE (seq
))
1736 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1737 cbytes
= CHAR_BYTES (c
);
1745 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1747 unsigned char *from
= SDATA (seq
) + ibyte
;
1748 unsigned char *to
= SDATA (tem
) + nbytes
;
1754 for (n
= cbytes
; n
--; )
1764 Lisp_Object tail
, prev
;
1766 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1768 CHECK_LIST_CONS (tail
, seq
);
1770 if (!NILP (Fequal (elt
, XCAR (tail
))))
1775 Fsetcdr (prev
, XCDR (tail
));
1786 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1787 doc
: /* Reverse LIST by modifying cdr pointers.
1788 Return the reversed list. */)
1792 register Lisp_Object prev
, tail
, next
;
1794 if (NILP (list
)) return list
;
1797 while (!NILP (tail
))
1800 CHECK_LIST_CONS (tail
, list
);
1802 Fsetcdr (tail
, prev
);
1809 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1810 doc
: /* Reverse LIST, copying. Return the reversed list.
1811 See also the function `nreverse', which is used more often. */)
1817 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1820 new = Fcons (XCAR (list
), new);
1822 CHECK_LIST_END (list
, list
);
1826 Lisp_Object
merge ();
1828 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1829 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1830 Returns the sorted list. LIST is modified by side effects.
1831 PREDICATE is called with two elements of LIST, and should return non-nil
1832 if the first element should sort before the second. */)
1834 Lisp_Object list
, predicate
;
1836 Lisp_Object front
, back
;
1837 register Lisp_Object len
, tem
;
1838 struct gcpro gcpro1
, gcpro2
;
1839 register int length
;
1842 len
= Flength (list
);
1843 length
= XINT (len
);
1847 XSETINT (len
, (length
/ 2) - 1);
1848 tem
= Fnthcdr (len
, list
);
1850 Fsetcdr (tem
, Qnil
);
1852 GCPRO2 (front
, back
);
1853 front
= Fsort (front
, predicate
);
1854 back
= Fsort (back
, predicate
);
1856 return merge (front
, back
, predicate
);
1860 merge (org_l1
, org_l2
, pred
)
1861 Lisp_Object org_l1
, org_l2
;
1865 register Lisp_Object tail
;
1867 register Lisp_Object l1
, l2
;
1868 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1875 /* It is sufficient to protect org_l1 and org_l2.
1876 When l1 and l2 are updated, we copy the new values
1877 back into the org_ vars. */
1878 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1898 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1914 Fsetcdr (tail
, tem
);
1920 /* This does not check for quits. That is safe since it must terminate. */
1922 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1923 doc
: /* Extract a value from a property list.
1924 PLIST is a property list, which is a list of the form
1925 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1926 corresponding to the given PROP, or nil if PROP is not one of the
1927 properties on the list. This function never signals an error. */)
1932 Lisp_Object tail
, halftail
;
1934 /* halftail is used to detect circular lists. */
1935 tail
= halftail
= plist
;
1936 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1938 if (EQ (prop
, XCAR (tail
)))
1939 return XCAR (XCDR (tail
));
1941 tail
= XCDR (XCDR (tail
));
1942 halftail
= XCDR (halftail
);
1943 if (EQ (tail
, halftail
))
1946 #if 0 /* Unsafe version. */
1947 /* This function can be called asynchronously
1948 (setup_coding_system). Don't QUIT in that case. */
1949 if (!interrupt_input_blocked
)
1957 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1958 doc
: /* Return the value of SYMBOL's PROPNAME property.
1959 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1961 Lisp_Object symbol
, propname
;
1963 CHECK_SYMBOL (symbol
);
1964 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1967 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1968 doc
: /* Change value in PLIST of PROP to VAL.
1969 PLIST is a property list, which is a list of the form
1970 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1971 If PROP is already a property on the list, its value is set to VAL,
1972 otherwise the new PROP VAL pair is added. The new plist is returned;
1973 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1974 The PLIST is modified by side effects. */)
1977 register Lisp_Object prop
;
1980 register Lisp_Object tail
, prev
;
1981 Lisp_Object newcell
;
1983 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1984 tail
= XCDR (XCDR (tail
)))
1986 if (EQ (prop
, XCAR (tail
)))
1988 Fsetcar (XCDR (tail
), val
);
1995 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1999 Fsetcdr (XCDR (prev
), newcell
);
2003 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2004 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2005 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2006 (symbol
, propname
, value
)
2007 Lisp_Object symbol
, propname
, value
;
2009 CHECK_SYMBOL (symbol
);
2010 XSYMBOL (symbol
)->plist
2011 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2015 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2016 doc
: /* Extract a value from a property list, comparing with `equal'.
2017 PLIST is a property list, which is a list of the form
2018 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2019 corresponding to the given PROP, or nil if PROP is not
2020 one of the properties on the list. */)
2028 CONSP (tail
) && CONSP (XCDR (tail
));
2029 tail
= XCDR (XCDR (tail
)))
2031 if (! NILP (Fequal (prop
, XCAR (tail
))))
2032 return XCAR (XCDR (tail
));
2037 CHECK_LIST_END (tail
, prop
);
2042 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2043 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2044 PLIST is a property list, which is a list of the form
2045 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2046 If PROP is already a property on the list, its value is set to VAL,
2047 otherwise the new PROP VAL pair is added. The new plist is returned;
2048 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2049 The PLIST is modified by side effects. */)
2052 register Lisp_Object prop
;
2055 register Lisp_Object tail
, prev
;
2056 Lisp_Object newcell
;
2058 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2059 tail
= XCDR (XCDR (tail
)))
2061 if (! NILP (Fequal (prop
, XCAR (tail
))))
2063 Fsetcar (XCDR (tail
), val
);
2070 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2074 Fsetcdr (XCDR (prev
), newcell
);
2078 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2079 doc
: /* Return t if the two args are the same Lisp object.
2080 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2082 Lisp_Object obj1
, obj2
;
2085 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2087 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2090 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2091 doc
: /* Return t if two Lisp objects have similar structure and contents.
2092 They must have the same data type.
2093 Conses are compared by comparing the cars and the cdrs.
2094 Vectors and strings are compared element by element.
2095 Numbers are compared by value, but integers cannot equal floats.
2096 (Use `=' if you want integers and floats to be able to be equal.)
2097 Symbols must match exactly. */)
2099 register Lisp_Object o1
, o2
;
2101 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2104 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2105 doc
: /* Return t if two Lisp objects have similar structure and contents.
2106 This is like `equal' except that it compares the text properties
2107 of strings. (`equal' ignores text properties.) */)
2109 register Lisp_Object o1
, o2
;
2111 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2114 /* DEPTH is current depth of recursion. Signal an error if it
2116 PROPS, if non-nil, means compare string text properties too. */
2119 internal_equal (o1
, o2
, depth
, props
)
2120 register Lisp_Object o1
, o2
;
2124 error ("Stack overflow in equal");
2130 if (XTYPE (o1
) != XTYPE (o2
))
2139 d1
= extract_float (o1
);
2140 d2
= extract_float (o2
);
2141 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2142 though they are not =. */
2143 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2147 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2154 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2158 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2160 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2163 o1
= XOVERLAY (o1
)->plist
;
2164 o2
= XOVERLAY (o2
)->plist
;
2169 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2170 && (XMARKER (o1
)->buffer
== 0
2171 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2175 case Lisp_Vectorlike
:
2178 EMACS_INT size
= ASIZE (o1
);
2179 /* Pseudovectors have the type encoded in the size field, so this test
2180 actually checks that the objects have the same type as well as the
2182 if (ASIZE (o2
) != size
)
2184 /* Boolvectors are compared much like strings. */
2185 if (BOOL_VECTOR_P (o1
))
2188 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2189 / BOOL_VECTOR_BITS_PER_CHAR
);
2191 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2193 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2198 if (WINDOW_CONFIGURATIONP (o1
))
2199 return compare_window_configurations (o1
, o2
, 0);
2201 /* Aside from them, only true vectors, char-tables, compiled
2202 functions, and fonts (font-spec, font-entity, font-ojbect)
2203 are sensible to compare, so eliminate the others now. */
2204 if (size
& PSEUDOVECTOR_FLAG
)
2206 if (!(size
& (PVEC_COMPILED
2207 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2209 size
&= PSEUDOVECTOR_SIZE_MASK
;
2211 for (i
= 0; i
< size
; i
++)
2216 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2224 if (SCHARS (o1
) != SCHARS (o2
))
2226 if (SBYTES (o1
) != SBYTES (o2
))
2228 if (bcmp (SDATA (o1
), SDATA (o2
),
2231 if (props
&& !compare_string_intervals (o1
, o2
))
2242 extern Lisp_Object
Fmake_char_internal ();
2244 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2245 doc
: /* Store each element of ARRAY with ITEM.
2246 ARRAY is a vector, string, char-table, or bool-vector. */)
2248 Lisp_Object array
, item
;
2250 register int size
, index
, charval
;
2251 if (VECTORP (array
))
2253 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2254 size
= ASIZE (array
);
2255 for (index
= 0; index
< size
; index
++)
2258 else if (CHAR_TABLE_P (array
))
2262 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2263 XCHAR_TABLE (array
)->contents
[i
] = item
;
2264 XCHAR_TABLE (array
)->defalt
= item
;
2266 else if (STRINGP (array
))
2268 register unsigned char *p
= SDATA (array
);
2269 CHECK_NUMBER (item
);
2270 charval
= XINT (item
);
2271 size
= SCHARS (array
);
2272 if (STRING_MULTIBYTE (array
))
2274 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2275 int len
= CHAR_STRING (charval
, str
);
2276 int size_byte
= SBYTES (array
);
2277 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2280 if (size
!= size_byte
)
2283 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2284 if (len
!= this_len
)
2285 error ("Attempt to change byte length of a string");
2288 for (i
= 0; i
< size_byte
; i
++)
2289 *p
++ = str
[i
% len
];
2292 for (index
= 0; index
< size
; index
++)
2295 else if (BOOL_VECTOR_P (array
))
2297 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2299 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2300 / BOOL_VECTOR_BITS_PER_CHAR
);
2302 charval
= (! NILP (item
) ? -1 : 0);
2303 for (index
= 0; index
< size_in_chars
- 1; index
++)
2305 if (index
< size_in_chars
)
2307 /* Mask out bits beyond the vector size. */
2308 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2309 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2314 wrong_type_argument (Qarrayp
, array
);
2318 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2320 doc
: /* Clear the contents of STRING.
2321 This makes STRING unibyte and may change its length. */)
2326 CHECK_STRING (string
);
2327 len
= SBYTES (string
);
2328 bzero (SDATA (string
), len
);
2329 STRING_SET_CHARS (string
, len
);
2330 STRING_SET_UNIBYTE (string
);
2339 Lisp_Object args
[2];
2342 return Fnconc (2, args
);
2345 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2346 doc
: /* Concatenate any number of lists by altering them.
2347 Only the last argument is not altered, and need not be a list.
2348 usage: (nconc &rest LISTS) */)
2353 register int argnum
;
2354 register Lisp_Object tail
, tem
, val
;
2358 for (argnum
= 0; argnum
< nargs
; argnum
++)
2361 if (NILP (tem
)) continue;
2366 if (argnum
+ 1 == nargs
) break;
2368 CHECK_LIST_CONS (tem
, tem
);
2377 tem
= args
[argnum
+ 1];
2378 Fsetcdr (tail
, tem
);
2380 args
[argnum
+ 1] = tail
;
2386 /* This is the guts of all mapping functions.
2387 Apply FN to each element of SEQ, one by one,
2388 storing the results into elements of VALS, a C vector of Lisp_Objects.
2389 LENI is the length of VALS, which should also be the length of SEQ. */
2392 mapcar1 (leni
, vals
, fn
, seq
)
2395 Lisp_Object fn
, seq
;
2397 register Lisp_Object tail
;
2400 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2404 /* Don't let vals contain any garbage when GC happens. */
2405 for (i
= 0; i
< leni
; i
++)
2408 GCPRO3 (dummy
, fn
, seq
);
2410 gcpro1
.nvars
= leni
;
2414 /* We need not explicitly protect `tail' because it is used only on lists, and
2415 1) lists are not relocated and 2) the list is marked via `seq' so will not
2420 for (i
= 0; i
< leni
; i
++)
2422 dummy
= call1 (fn
, AREF (seq
, i
));
2427 else if (BOOL_VECTOR_P (seq
))
2429 for (i
= 0; i
< leni
; i
++)
2432 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2433 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2434 dummy
= call1 (fn
, dummy
);
2439 else if (STRINGP (seq
))
2443 for (i
= 0, i_byte
= 0; i
< leni
;)
2448 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2449 XSETFASTINT (dummy
, c
);
2450 dummy
= call1 (fn
, dummy
);
2452 vals
[i_before
] = dummy
;
2455 else /* Must be a list, since Flength did not get an error */
2458 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2460 dummy
= call1 (fn
, XCAR (tail
));
2470 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2471 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2472 In between each pair of results, stick in SEPARATOR. Thus, " " as
2473 SEPARATOR results in spaces between the values returned by FUNCTION.
2474 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2475 (function
, sequence
, separator
)
2476 Lisp_Object function
, sequence
, separator
;
2481 register Lisp_Object
*args
;
2483 struct gcpro gcpro1
;
2487 len
= Flength (sequence
);
2488 if (CHAR_TABLE_P (sequence
))
2489 wrong_type_argument (Qlistp
, sequence
);
2491 nargs
= leni
+ leni
- 1;
2492 if (nargs
< 0) return empty_unibyte_string
;
2494 SAFE_ALLOCA_LISP (args
, nargs
);
2497 mapcar1 (leni
, args
, function
, sequence
);
2500 for (i
= leni
- 1; i
> 0; i
--)
2501 args
[i
+ i
] = args
[i
];
2503 for (i
= 1; i
< nargs
; i
+= 2)
2504 args
[i
] = separator
;
2506 ret
= Fconcat (nargs
, args
);
2512 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2513 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2514 The result is a list just as long as SEQUENCE.
2515 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2516 (function
, sequence
)
2517 Lisp_Object function
, sequence
;
2519 register Lisp_Object len
;
2521 register Lisp_Object
*args
;
2525 len
= Flength (sequence
);
2526 if (CHAR_TABLE_P (sequence
))
2527 wrong_type_argument (Qlistp
, sequence
);
2528 leni
= XFASTINT (len
);
2530 SAFE_ALLOCA_LISP (args
, leni
);
2532 mapcar1 (leni
, args
, function
, sequence
);
2534 ret
= Flist (leni
, args
);
2540 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2541 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2542 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2543 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2544 (function
, sequence
)
2545 Lisp_Object function
, sequence
;
2549 leni
= XFASTINT (Flength (sequence
));
2550 if (CHAR_TABLE_P (sequence
))
2551 wrong_type_argument (Qlistp
, sequence
);
2552 mapcar1 (leni
, 0, function
, sequence
);
2557 /* Anything that calls this function must protect from GC! */
2559 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2560 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2561 Takes one argument, which is the string to display to ask the question.
2562 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2563 No confirmation of the answer is requested; a single character is enough.
2564 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2565 the bindings in `query-replace-map'; see the documentation of that variable
2566 for more information. In this case, the useful bindings are `act', `skip',
2567 `recenter', and `quit'.\)
2569 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2570 is nil and `use-dialog-box' is non-nil. */)
2574 register Lisp_Object obj
, key
, def
, map
;
2575 register int answer
;
2576 Lisp_Object xprompt
;
2577 Lisp_Object args
[2];
2578 struct gcpro gcpro1
, gcpro2
;
2579 int count
= SPECPDL_INDEX ();
2581 specbind (Qcursor_in_echo_area
, Qt
);
2583 map
= Fsymbol_value (intern ("query-replace-map"));
2585 CHECK_STRING (prompt
);
2587 GCPRO2 (prompt
, xprompt
);
2589 #ifdef HAVE_WINDOW_SYSTEM
2590 if (display_hourglass_p
)
2591 cancel_hourglass ();
2598 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2599 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2603 Lisp_Object pane
, menu
;
2604 redisplay_preserve_echo_area (3);
2605 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2606 Fcons (Fcons (build_string ("No"), Qnil
),
2608 menu
= Fcons (prompt
, pane
);
2609 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2610 answer
= !NILP (obj
);
2613 #endif /* HAVE_MENUS */
2614 cursor_in_echo_area
= 1;
2615 choose_minibuf_frame ();
2618 Lisp_Object pargs
[3];
2620 /* Colorize prompt according to `minibuffer-prompt' face. */
2621 pargs
[0] = build_string ("%s(y or n) ");
2622 pargs
[1] = intern ("face");
2623 pargs
[2] = intern ("minibuffer-prompt");
2624 args
[0] = Fpropertize (3, pargs
);
2629 if (minibuffer_auto_raise
)
2631 Lisp_Object mini_frame
;
2633 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2635 Fraise_frame (mini_frame
);
2638 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2639 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2640 cursor_in_echo_area
= 0;
2641 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2644 key
= Fmake_vector (make_number (1), obj
);
2645 def
= Flookup_key (map
, key
, Qt
);
2647 if (EQ (def
, intern ("skip")))
2652 else if (EQ (def
, intern ("act")))
2657 else if (EQ (def
, intern ("recenter")))
2663 else if (EQ (def
, intern ("quit")))
2665 /* We want to exit this command for exit-prefix,
2666 and this is the only way to do it. */
2667 else if (EQ (def
, intern ("exit-prefix")))
2672 /* If we don't clear this, then the next call to read_char will
2673 return quit_char again, and we'll enter an infinite loop. */
2678 if (EQ (xprompt
, prompt
))
2680 args
[0] = build_string ("Please answer y or n. ");
2682 xprompt
= Fconcat (2, args
);
2687 if (! noninteractive
)
2689 cursor_in_echo_area
= -1;
2690 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2694 unbind_to (count
, Qnil
);
2695 return answer
? Qt
: Qnil
;
2698 /* This is how C code calls `yes-or-no-p' and allows the user
2701 Anything that calls this function must protect from GC! */
2704 do_yes_or_no_p (prompt
)
2707 return call1 (intern ("yes-or-no-p"), prompt
);
2710 /* Anything that calls this function must protect from GC! */
2712 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2713 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2714 Takes one argument, which is the string to display to ask the question.
2715 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2716 The user must confirm the answer with RET,
2717 and can edit it until it has been confirmed.
2719 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2720 is nil, and `use-dialog-box' is non-nil. */)
2724 register Lisp_Object ans
;
2725 Lisp_Object args
[2];
2726 struct gcpro gcpro1
;
2728 CHECK_STRING (prompt
);
2731 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2732 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2736 Lisp_Object pane
, menu
, obj
;
2737 redisplay_preserve_echo_area (4);
2738 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2739 Fcons (Fcons (build_string ("No"), Qnil
),
2742 menu
= Fcons (prompt
, pane
);
2743 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2747 #endif /* HAVE_MENUS */
2750 args
[1] = build_string ("(yes or no) ");
2751 prompt
= Fconcat (2, args
);
2757 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2758 Qyes_or_no_p_history
, Qnil
,
2760 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2765 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2773 message ("Please answer yes or no.");
2774 Fsleep_for (make_number (2), Qnil
);
2778 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2779 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2781 Each of the three load averages is multiplied by 100, then converted
2784 When USE-FLOATS is non-nil, floats will be used instead of integers.
2785 These floats are not multiplied by 100.
2787 If the 5-minute or 15-minute load averages are not available, return a
2788 shortened list, containing only those averages which are available.
2790 An error is thrown if the load average can't be obtained. In some
2791 cases making it work would require Emacs being installed setuid or
2792 setgid so that it can read kernel information, and that usually isn't
2795 Lisp_Object use_floats
;
2798 int loads
= getloadavg (load_ave
, 3);
2799 Lisp_Object ret
= Qnil
;
2802 error ("load-average not implemented for this operating system");
2806 Lisp_Object load
= (NILP (use_floats
) ?
2807 make_number ((int) (100.0 * load_ave
[loads
]))
2808 : make_float (load_ave
[loads
]));
2809 ret
= Fcons (load
, ret
);
2815 Lisp_Object Vfeatures
, Qsubfeatures
;
2816 extern Lisp_Object Vafter_load_alist
;
2818 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2819 doc
: /* Returns t if FEATURE is present in this Emacs.
2821 Use this to conditionalize execution of lisp code based on the
2822 presence or absence of Emacs or environment extensions.
2823 Use `provide' to declare that a feature is available. This function
2824 looks at the value of the variable `features'. The optional argument
2825 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2826 (feature
, subfeature
)
2827 Lisp_Object feature
, subfeature
;
2829 register Lisp_Object tem
;
2830 CHECK_SYMBOL (feature
);
2831 tem
= Fmemq (feature
, Vfeatures
);
2832 if (!NILP (tem
) && !NILP (subfeature
))
2833 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2834 return (NILP (tem
)) ? Qnil
: Qt
;
2837 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2838 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2839 The optional argument SUBFEATURES should be a list of symbols listing
2840 particular subfeatures supported in this version of FEATURE. */)
2841 (feature
, subfeatures
)
2842 Lisp_Object feature
, subfeatures
;
2844 register Lisp_Object tem
;
2845 CHECK_SYMBOL (feature
);
2846 CHECK_LIST (subfeatures
);
2847 if (!NILP (Vautoload_queue
))
2848 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2850 tem
= Fmemq (feature
, Vfeatures
);
2852 Vfeatures
= Fcons (feature
, Vfeatures
);
2853 if (!NILP (subfeatures
))
2854 Fput (feature
, Qsubfeatures
, subfeatures
);
2855 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2857 /* Run any load-hooks for this file. */
2858 tem
= Fassq (feature
, Vafter_load_alist
);
2860 Fprogn (XCDR (tem
));
2865 /* `require' and its subroutines. */
2867 /* List of features currently being require'd, innermost first. */
2869 Lisp_Object require_nesting_list
;
2872 require_unwind (old_value
)
2873 Lisp_Object old_value
;
2875 return require_nesting_list
= old_value
;
2878 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2879 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2880 If FEATURE is not a member of the list `features', then the feature
2881 is not loaded; so load the file FILENAME.
2882 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2883 and `load' will try to load this name appended with the suffix `.elc' or
2884 `.el', in that order. The name without appended suffix will not be used.
2885 If the optional third argument NOERROR is non-nil,
2886 then return nil if the file is not found instead of signaling an error.
2887 Normally the return value is FEATURE.
2888 The normal messages at start and end of loading FILENAME are suppressed. */)
2889 (feature
, filename
, noerror
)
2890 Lisp_Object feature
, filename
, noerror
;
2892 register Lisp_Object tem
;
2893 struct gcpro gcpro1
, gcpro2
;
2894 int from_file
= load_in_progress
;
2896 CHECK_SYMBOL (feature
);
2898 /* Record the presence of `require' in this file
2899 even if the feature specified is already loaded.
2900 But not more than once in any file,
2901 and not when we aren't loading or reading from a file. */
2903 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2904 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2909 tem
= Fcons (Qrequire
, feature
);
2910 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2911 LOADHIST_ATTACH (tem
);
2913 tem
= Fmemq (feature
, Vfeatures
);
2917 int count
= SPECPDL_INDEX ();
2920 /* This is to make sure that loadup.el gives a clear picture
2921 of what files are preloaded and when. */
2922 if (! NILP (Vpurify_flag
))
2923 error ("(require %s) while preparing to dump",
2924 SDATA (SYMBOL_NAME (feature
)));
2926 /* A certain amount of recursive `require' is legitimate,
2927 but if we require the same feature recursively 3 times,
2929 tem
= require_nesting_list
;
2930 while (! NILP (tem
))
2932 if (! NILP (Fequal (feature
, XCAR (tem
))))
2937 error ("Recursive `require' for feature `%s'",
2938 SDATA (SYMBOL_NAME (feature
)));
2940 /* Update the list for any nested `require's that occur. */
2941 record_unwind_protect (require_unwind
, require_nesting_list
);
2942 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2944 /* Value saved here is to be restored into Vautoload_queue */
2945 record_unwind_protect (un_autoload
, Vautoload_queue
);
2946 Vautoload_queue
= Qt
;
2948 /* Load the file. */
2949 GCPRO2 (feature
, filename
);
2950 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2951 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2954 /* If load failed entirely, return nil. */
2956 return unbind_to (count
, Qnil
);
2958 tem
= Fmemq (feature
, Vfeatures
);
2960 error ("Required feature `%s' was not provided",
2961 SDATA (SYMBOL_NAME (feature
)));
2963 /* Once loading finishes, don't undo it. */
2964 Vautoload_queue
= Qt
;
2965 feature
= unbind_to (count
, feature
);
2971 /* Primitives for work of the "widget" library.
2972 In an ideal world, this section would not have been necessary.
2973 However, lisp function calls being as slow as they are, it turns
2974 out that some functions in the widget library (wid-edit.el) are the
2975 bottleneck of Widget operation. Here is their translation to C,
2976 for the sole reason of efficiency. */
2978 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2979 doc
: /* Return non-nil if PLIST has the property PROP.
2980 PLIST is a property list, which is a list of the form
2981 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2982 Unlike `plist-get', this allows you to distinguish between a missing
2983 property and a property with the value nil.
2984 The value is actually the tail of PLIST whose car is PROP. */)
2986 Lisp_Object plist
, prop
;
2988 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2991 plist
= XCDR (plist
);
2992 plist
= CDR (plist
);
2997 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2998 doc
: /* In WIDGET, set PROPERTY to VALUE.
2999 The value can later be retrieved with `widget-get'. */)
3000 (widget
, property
, value
)
3001 Lisp_Object widget
, property
, value
;
3003 CHECK_CONS (widget
);
3004 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3008 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3009 doc
: /* In WIDGET, get the value of PROPERTY.
3010 The value could either be specified when the widget was created, or
3011 later with `widget-put'. */)
3013 Lisp_Object widget
, property
;
3021 CHECK_CONS (widget
);
3022 tmp
= Fplist_member (XCDR (widget
), property
);
3028 tmp
= XCAR (widget
);
3031 widget
= Fget (tmp
, Qwidget_type
);
3035 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3036 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3037 ARGS are passed as extra arguments to the function.
3038 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3043 /* This function can GC. */
3044 Lisp_Object newargs
[3];
3045 struct gcpro gcpro1
, gcpro2
;
3048 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3049 newargs
[1] = args
[0];
3050 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3051 GCPRO2 (newargs
[0], newargs
[2]);
3052 result
= Fapply (3, newargs
);
3057 #ifdef HAVE_LANGINFO_CODESET
3058 #include <langinfo.h>
3061 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3062 doc
: /* Access locale data ITEM for the current C locale, if available.
3063 ITEM should be one of the following:
3065 `codeset', returning the character set as a string (locale item CODESET);
3067 `days', returning a 7-element vector of day names (locale items DAY_n);
3069 `months', returning a 12-element vector of month names (locale items MON_n);
3071 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3072 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3074 If the system can't provide such information through a call to
3075 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3077 See also Info node `(libc)Locales'.
3079 The data read from the system are decoded using `locale-coding-system'. */)
3084 #ifdef HAVE_LANGINFO_CODESET
3086 if (EQ (item
, Qcodeset
))
3088 str
= nl_langinfo (CODESET
);
3089 return build_string (str
);
3092 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3094 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3095 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3097 struct gcpro gcpro1
;
3099 synchronize_system_time_locale ();
3100 for (i
= 0; i
< 7; i
++)
3102 str
= nl_langinfo (days
[i
]);
3103 val
= make_unibyte_string (str
, strlen (str
));
3104 /* Fixme: Is this coding system necessarily right, even if
3105 it is consistent with CODESET? If not, what to do? */
3106 Faset (v
, make_number (i
),
3107 code_convert_string_norecord (val
, Vlocale_coding_system
,
3115 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3117 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3118 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3119 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3121 struct gcpro gcpro1
;
3123 synchronize_system_time_locale ();
3124 for (i
= 0; i
< 12; i
++)
3126 str
= nl_langinfo (months
[i
]);
3127 val
= make_unibyte_string (str
, strlen (str
));
3128 Faset (v
, make_number (i
),
3129 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3135 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3136 but is in the locale files. This could be used by ps-print. */
3138 else if (EQ (item
, Qpaper
))
3140 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3141 make_number (nl_langinfo (PAPER_HEIGHT
)));
3143 #endif /* PAPER_WIDTH */
3144 #endif /* HAVE_LANGINFO_CODESET*/
3148 /* base64 encode/decode functions (RFC 2045).
3149 Based on code from GNU recode. */
3151 #define MIME_LINE_LENGTH 76
3153 #define IS_ASCII(Character) \
3155 #define IS_BASE64(Character) \
3156 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3157 #define IS_BASE64_IGNORABLE(Character) \
3158 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3159 || (Character) == '\f' || (Character) == '\r')
3161 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3162 character or return retval if there are no characters left to
3164 #define READ_QUADRUPLET_BYTE(retval) \
3169 if (nchars_return) \
3170 *nchars_return = nchars; \
3175 while (IS_BASE64_IGNORABLE (c))
3177 /* Table of characters coding the 64 values. */
3178 static const char base64_value_to_char
[64] =
3180 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3181 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3182 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3183 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3184 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3185 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3186 '8', '9', '+', '/' /* 60-63 */
3189 /* Table of base64 values for first 128 characters. */
3190 static const short base64_char_to_value
[128] =
3192 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3193 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3194 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3195 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3196 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3197 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3198 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3199 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3200 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3201 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3202 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3203 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3204 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3207 /* The following diagram shows the logical steps by which three octets
3208 get transformed into four base64 characters.
3210 .--------. .--------. .--------.
3211 |aaaaaabb| |bbbbcccc| |ccdddddd|
3212 `--------' `--------' `--------'
3214 .--------+--------+--------+--------.
3215 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3216 `--------+--------+--------+--------'
3218 .--------+--------+--------+--------.
3219 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3220 `--------+--------+--------+--------'
3222 The octets are divided into 6 bit chunks, which are then encoded into
3223 base64 characters. */
3226 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3227 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3229 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3231 doc
: /* Base64-encode the region between BEG and END.
3232 Return the length of the encoded text.
3233 Optional third argument NO-LINE-BREAK means do not break long lines
3234 into shorter lines. */)
3235 (beg
, end
, no_line_break
)
3236 Lisp_Object beg
, end
, no_line_break
;
3239 int allength
, length
;
3240 int ibeg
, iend
, encoded_length
;
3244 validate_region (&beg
, &end
);
3246 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3247 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3248 move_gap_both (XFASTINT (beg
), ibeg
);
3250 /* We need to allocate enough room for encoding the text.
3251 We need 33 1/3% more space, plus a newline every 76
3252 characters, and then we round up. */
3253 length
= iend
- ibeg
;
3254 allength
= length
+ length
/3 + 1;
3255 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3257 SAFE_ALLOCA (encoded
, char *, allength
);
3258 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3259 NILP (no_line_break
),
3260 !NILP (current_buffer
->enable_multibyte_characters
));
3261 if (encoded_length
> allength
)
3264 if (encoded_length
< 0)
3266 /* The encoding wasn't possible. */
3268 error ("Multibyte character in data for base64 encoding");
3271 /* Now we have encoded the region, so we insert the new contents
3272 and delete the old. (Insert first in order to preserve markers.) */
3273 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3274 insert (encoded
, encoded_length
);
3276 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3278 /* If point was outside of the region, restore it exactly; else just
3279 move to the beginning of the region. */
3280 if (old_pos
>= XFASTINT (end
))
3281 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3282 else if (old_pos
> XFASTINT (beg
))
3283 old_pos
= XFASTINT (beg
);
3286 /* We return the length of the encoded text. */
3287 return make_number (encoded_length
);
3290 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3292 doc
: /* Base64-encode STRING and return the result.
3293 Optional second argument NO-LINE-BREAK means do not break long lines
3294 into shorter lines. */)
3295 (string
, no_line_break
)
3296 Lisp_Object string
, no_line_break
;
3298 int allength
, length
, encoded_length
;
3300 Lisp_Object encoded_string
;
3303 CHECK_STRING (string
);
3305 /* We need to allocate enough room for encoding the text.
3306 We need 33 1/3% more space, plus a newline every 76
3307 characters, and then we round up. */
3308 length
= SBYTES (string
);
3309 allength
= length
+ length
/3 + 1;
3310 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3312 /* We need to allocate enough room for decoding the text. */
3313 SAFE_ALLOCA (encoded
, char *, allength
);
3315 encoded_length
= base64_encode_1 (SDATA (string
),
3316 encoded
, length
, NILP (no_line_break
),
3317 STRING_MULTIBYTE (string
));
3318 if (encoded_length
> allength
)
3321 if (encoded_length
< 0)
3323 /* The encoding wasn't possible. */
3325 error ("Multibyte character in data for base64 encoding");
3328 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3331 return encoded_string
;
3335 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3342 int counter
= 0, i
= 0;
3352 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3353 if (CHAR_BYTE8_P (c
))
3354 c
= CHAR_TO_BYTE8 (c
);
3362 /* Wrap line every 76 characters. */
3366 if (counter
< MIME_LINE_LENGTH
/ 4)
3375 /* Process first byte of a triplet. */
3377 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3378 value
= (0x03 & c
) << 4;
3380 /* Process second byte of a triplet. */
3384 *e
++ = base64_value_to_char
[value
];
3392 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3393 if (CHAR_BYTE8_P (c
))
3394 c
= CHAR_TO_BYTE8 (c
);
3402 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3403 value
= (0x0f & c
) << 2;
3405 /* Process third byte of a triplet. */
3409 *e
++ = base64_value_to_char
[value
];
3416 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3417 if (CHAR_BYTE8_P (c
))
3418 c
= CHAR_TO_BYTE8 (c
);
3426 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3427 *e
++ = base64_value_to_char
[0x3f & c
];
3434 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3436 doc
: /* Base64-decode the region between BEG and END.
3437 Return the length of the decoded text.
3438 If the region can't be decoded, signal an error and don't modify the buffer. */)
3440 Lisp_Object beg
, end
;
3442 int ibeg
, iend
, length
, allength
;
3447 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3450 validate_region (&beg
, &end
);
3452 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3453 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3455 length
= iend
- ibeg
;
3457 /* We need to allocate enough room for decoding the text. If we are
3458 working on a multibyte buffer, each decoded code may occupy at
3460 allength
= multibyte
? length
* 2 : length
;
3461 SAFE_ALLOCA (decoded
, char *, allength
);
3463 move_gap_both (XFASTINT (beg
), ibeg
);
3464 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3465 multibyte
, &inserted_chars
);
3466 if (decoded_length
> allength
)
3469 if (decoded_length
< 0)
3471 /* The decoding wasn't possible. */
3473 error ("Invalid base64 data");
3476 /* Now we have decoded the region, so we insert the new contents
3477 and delete the old. (Insert first in order to preserve markers.) */
3478 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3479 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3482 /* Delete the original text. */
3483 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3484 iend
+ decoded_length
, 1);
3486 /* If point was outside of the region, restore it exactly; else just
3487 move to the beginning of the region. */
3488 if (old_pos
>= XFASTINT (end
))
3489 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3490 else if (old_pos
> XFASTINT (beg
))
3491 old_pos
= XFASTINT (beg
);
3492 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3494 return make_number (inserted_chars
);
3497 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3499 doc
: /* Base64-decode STRING and return the result. */)
3504 int length
, decoded_length
;
3505 Lisp_Object decoded_string
;
3508 CHECK_STRING (string
);
3510 length
= SBYTES (string
);
3511 /* We need to allocate enough room for decoding the text. */
3512 SAFE_ALLOCA (decoded
, char *, length
);
3514 /* The decoded result should be unibyte. */
3515 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3517 if (decoded_length
> length
)
3519 else if (decoded_length
>= 0)
3520 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3522 decoded_string
= Qnil
;
3525 if (!STRINGP (decoded_string
))
3526 error ("Invalid base64 data");
3528 return decoded_string
;
3531 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3532 MULTIBYTE is nonzero, the decoded result should be in multibyte
3533 form. If NCHARS_RETRUN is not NULL, store the number of produced
3534 characters in *NCHARS_RETURN. */
3537 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3547 unsigned long value
;
3552 /* Process first byte of a quadruplet. */
3554 READ_QUADRUPLET_BYTE (e
-to
);
3558 value
= base64_char_to_value
[c
] << 18;
3560 /* Process second byte of a quadruplet. */
3562 READ_QUADRUPLET_BYTE (-1);
3566 value
|= base64_char_to_value
[c
] << 12;
3568 c
= (unsigned char) (value
>> 16);
3569 if (multibyte
&& c
>= 128)
3570 e
+= BYTE8_STRING (c
, e
);
3575 /* Process third byte of a quadruplet. */
3577 READ_QUADRUPLET_BYTE (-1);
3581 READ_QUADRUPLET_BYTE (-1);
3590 value
|= base64_char_to_value
[c
] << 6;
3592 c
= (unsigned char) (0xff & value
>> 8);
3593 if (multibyte
&& c
>= 128)
3594 e
+= BYTE8_STRING (c
, e
);
3599 /* Process fourth byte of a quadruplet. */
3601 READ_QUADRUPLET_BYTE (-1);
3608 value
|= base64_char_to_value
[c
];
3610 c
= (unsigned char) (0xff & value
);
3611 if (multibyte
&& c
>= 128)
3612 e
+= BYTE8_STRING (c
, e
);
3621 /***********************************************************************
3623 ***** Hash Tables *****
3625 ***********************************************************************/
3627 /* Implemented by gerd@gnu.org. This hash table implementation was
3628 inspired by CMUCL hash tables. */
3632 1. For small tables, association lists are probably faster than
3633 hash tables because they have lower overhead.
3635 For uses of hash tables where the O(1) behavior of table
3636 operations is not a requirement, it might therefore be a good idea
3637 not to hash. Instead, we could just do a linear search in the
3638 key_and_value vector of the hash table. This could be done
3639 if a `:linear-search t' argument is given to make-hash-table. */
3642 /* The list of all weak hash tables. Don't staticpro this one. */
3644 struct Lisp_Hash_Table
*weak_hash_tables
;
3646 /* Various symbols. */
3648 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3649 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3650 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3652 /* Function prototypes. */
3654 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3655 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3656 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3657 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3658 Lisp_Object
, unsigned));
3659 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3660 Lisp_Object
, unsigned));
3661 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3662 unsigned, Lisp_Object
, unsigned));
3663 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3664 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3665 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3666 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3668 static unsigned sxhash_string
P_ ((unsigned char *, int));
3669 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3670 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3671 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3672 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3676 /***********************************************************************
3678 ***********************************************************************/
3680 /* If OBJ is a Lisp hash table, return a pointer to its struct
3681 Lisp_Hash_Table. Otherwise, signal an error. */
3683 static struct Lisp_Hash_Table
*
3684 check_hash_table (obj
)
3687 CHECK_HASH_TABLE (obj
);
3688 return XHASH_TABLE (obj
);
3692 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3696 next_almost_prime (n
)
3709 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3710 which USED[I] is non-zero. If found at index I in ARGS, set
3711 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3712 -1. This function is used to extract a keyword/argument pair from
3713 a DEFUN parameter list. */
3716 get_key_arg (key
, nargs
, args
, used
)
3724 for (i
= 0; i
< nargs
- 1; ++i
)
3725 if (!used
[i
] && EQ (args
[i
], key
))
3740 /* Return a Lisp vector which has the same contents as VEC but has
3741 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3742 vector that are not copied from VEC are set to INIT. */
3745 larger_vector (vec
, new_size
, init
)
3750 struct Lisp_Vector
*v
;
3753 xassert (VECTORP (vec
));
3754 old_size
= ASIZE (vec
);
3755 xassert (new_size
>= old_size
);
3757 v
= allocate_vector (new_size
);
3758 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3759 old_size
* sizeof *v
->contents
);
3760 for (i
= old_size
; i
< new_size
; ++i
)
3761 v
->contents
[i
] = init
;
3762 XSETVECTOR (vec
, v
);
3767 /***********************************************************************
3769 ***********************************************************************/
3771 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3772 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3773 KEY2 are the same. */
3776 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3777 struct Lisp_Hash_Table
*h
;
3778 Lisp_Object key1
, key2
;
3779 unsigned hash1
, hash2
;
3781 return (FLOATP (key1
)
3783 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3787 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3788 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3789 KEY2 are the same. */
3792 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3793 struct Lisp_Hash_Table
*h
;
3794 Lisp_Object key1
, key2
;
3795 unsigned hash1
, hash2
;
3797 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3801 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3802 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3803 if KEY1 and KEY2 are the same. */
3806 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3807 struct Lisp_Hash_Table
*h
;
3808 Lisp_Object key1
, key2
;
3809 unsigned hash1
, hash2
;
3813 Lisp_Object args
[3];
3815 args
[0] = h
->user_cmp_function
;
3818 return !NILP (Ffuncall (3, args
));
3825 /* Value is a hash code for KEY for use in hash table H which uses
3826 `eq' to compare keys. The hash code returned is guaranteed to fit
3827 in a Lisp integer. */
3831 struct Lisp_Hash_Table
*h
;
3834 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3835 xassert ((hash
& ~INTMASK
) == 0);
3840 /* Value is a hash code for KEY for use in hash table H which uses
3841 `eql' to compare keys. The hash code returned is guaranteed to fit
3842 in a Lisp integer. */
3846 struct Lisp_Hash_Table
*h
;
3851 hash
= sxhash (key
, 0);
3853 hash
= XUINT (key
) ^ XTYPE (key
);
3854 xassert ((hash
& ~INTMASK
) == 0);
3859 /* Value is a hash code for KEY for use in hash table H which uses
3860 `equal' to compare keys. The hash code returned is guaranteed to fit
3861 in a Lisp integer. */
3864 hashfn_equal (h
, key
)
3865 struct Lisp_Hash_Table
*h
;
3868 unsigned hash
= sxhash (key
, 0);
3869 xassert ((hash
& ~INTMASK
) == 0);
3874 /* Value is a hash code for KEY for use in hash table H which uses as
3875 user-defined function to compare keys. The hash code returned is
3876 guaranteed to fit in a Lisp integer. */
3879 hashfn_user_defined (h
, key
)
3880 struct Lisp_Hash_Table
*h
;
3883 Lisp_Object args
[2], hash
;
3885 args
[0] = h
->user_hash_function
;
3887 hash
= Ffuncall (2, args
);
3888 if (!INTEGERP (hash
))
3889 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3890 return XUINT (hash
);
3894 /* Create and initialize a new hash table.
3896 TEST specifies the test the hash table will use to compare keys.
3897 It must be either one of the predefined tests `eq', `eql' or
3898 `equal' or a symbol denoting a user-defined test named TEST with
3899 test and hash functions USER_TEST and USER_HASH.
3901 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3903 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3904 new size when it becomes full is computed by adding REHASH_SIZE to
3905 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3906 table's new size is computed by multiplying its old size with
3909 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3910 be resized when the ratio of (number of entries in the table) /
3911 (table size) is >= REHASH_THRESHOLD.
3913 WEAK specifies the weakness of the table. If non-nil, it must be
3914 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3917 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3918 user_test
, user_hash
)
3919 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3920 Lisp_Object user_test
, user_hash
;
3922 struct Lisp_Hash_Table
*h
;
3924 int index_size
, i
, sz
;
3926 /* Preconditions. */
3927 xassert (SYMBOLP (test
));
3928 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3929 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3930 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3931 xassert (FLOATP (rehash_threshold
)
3932 && XFLOATINT (rehash_threshold
) > 0
3933 && XFLOATINT (rehash_threshold
) <= 1.0);
3935 if (XFASTINT (size
) == 0)
3936 size
= make_number (1);
3938 /* Allocate a table and initialize it. */
3939 h
= allocate_hash_table ();
3941 /* Initialize hash table slots. */
3942 sz
= XFASTINT (size
);
3945 if (EQ (test
, Qeql
))
3947 h
->cmpfn
= cmpfn_eql
;
3948 h
->hashfn
= hashfn_eql
;
3950 else if (EQ (test
, Qeq
))
3953 h
->hashfn
= hashfn_eq
;
3955 else if (EQ (test
, Qequal
))
3957 h
->cmpfn
= cmpfn_equal
;
3958 h
->hashfn
= hashfn_equal
;
3962 h
->user_cmp_function
= user_test
;
3963 h
->user_hash_function
= user_hash
;
3964 h
->cmpfn
= cmpfn_user_defined
;
3965 h
->hashfn
= hashfn_user_defined
;
3969 h
->rehash_threshold
= rehash_threshold
;
3970 h
->rehash_size
= rehash_size
;
3972 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3973 h
->hash
= Fmake_vector (size
, Qnil
);
3974 h
->next
= Fmake_vector (size
, Qnil
);
3975 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3976 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3977 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3979 /* Set up the free list. */
3980 for (i
= 0; i
< sz
- 1; ++i
)
3981 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3982 h
->next_free
= make_number (0);
3984 XSET_HASH_TABLE (table
, h
);
3985 xassert (HASH_TABLE_P (table
));
3986 xassert (XHASH_TABLE (table
) == h
);
3988 /* Maybe add this hash table to the list of all weak hash tables. */
3990 h
->next_weak
= NULL
;
3993 h
->next_weak
= weak_hash_tables
;
3994 weak_hash_tables
= h
;
4001 /* Return a copy of hash table H1. Keys and values are not copied,
4002 only the table itself is. */
4005 copy_hash_table (h1
)
4006 struct Lisp_Hash_Table
*h1
;
4009 struct Lisp_Hash_Table
*h2
;
4010 struct Lisp_Vector
*next
;
4012 h2
= allocate_hash_table ();
4013 next
= h2
->vec_next
;
4014 bcopy (h1
, h2
, sizeof *h2
);
4015 h2
->vec_next
= next
;
4016 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4017 h2
->hash
= Fcopy_sequence (h1
->hash
);
4018 h2
->next
= Fcopy_sequence (h1
->next
);
4019 h2
->index
= Fcopy_sequence (h1
->index
);
4020 XSET_HASH_TABLE (table
, h2
);
4022 /* Maybe add this hash table to the list of all weak hash tables. */
4023 if (!NILP (h2
->weak
))
4025 h2
->next_weak
= weak_hash_tables
;
4026 weak_hash_tables
= h2
;
4033 /* Resize hash table H if it's too full. If H cannot be resized
4034 because it's already too large, throw an error. */
4037 maybe_resize_hash_table (h
)
4038 struct Lisp_Hash_Table
*h
;
4040 if (NILP (h
->next_free
))
4042 int old_size
= HASH_TABLE_SIZE (h
);
4043 int i
, new_size
, index_size
;
4046 if (INTEGERP (h
->rehash_size
))
4047 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4049 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4050 new_size
= max (old_size
+ 1, new_size
);
4051 index_size
= next_almost_prime ((int)
4053 / XFLOATINT (h
->rehash_threshold
)));
4054 /* Assignment to EMACS_INT stops GCC whining about limited range
4056 nsize
= max (index_size
, 2 * new_size
);
4057 if (nsize
> MOST_POSITIVE_FIXNUM
)
4058 error ("Hash table too large to resize");
4060 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4061 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4062 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4063 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4065 /* Update the free list. Do it so that new entries are added at
4066 the end of the free list. This makes some operations like
4068 for (i
= old_size
; i
< new_size
- 1; ++i
)
4069 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4071 if (!NILP (h
->next_free
))
4073 Lisp_Object last
, next
;
4075 last
= h
->next_free
;
4076 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4080 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4083 XSETFASTINT (h
->next_free
, old_size
);
4086 for (i
= 0; i
< old_size
; ++i
)
4087 if (!NILP (HASH_HASH (h
, i
)))
4089 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4090 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4091 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4092 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4098 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4099 the hash code of KEY. Value is the index of the entry in H
4100 matching KEY, or -1 if not found. */
4103 hash_lookup (h
, key
, hash
)
4104 struct Lisp_Hash_Table
*h
;
4109 int start_of_bucket
;
4112 hash_code
= h
->hashfn (h
, key
);
4116 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4117 idx
= HASH_INDEX (h
, start_of_bucket
);
4119 /* We need not gcpro idx since it's either an integer or nil. */
4122 int i
= XFASTINT (idx
);
4123 if (EQ (key
, HASH_KEY (h
, i
))
4125 && h
->cmpfn (h
, key
, hash_code
,
4126 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4128 idx
= HASH_NEXT (h
, i
);
4131 return NILP (idx
) ? -1 : XFASTINT (idx
);
4135 /* Put an entry into hash table H that associates KEY with VALUE.
4136 HASH is a previously computed hash code of KEY.
4137 Value is the index of the entry in H matching KEY. */
4140 hash_put (h
, key
, value
, hash
)
4141 struct Lisp_Hash_Table
*h
;
4142 Lisp_Object key
, value
;
4145 int start_of_bucket
, i
;
4147 xassert ((hash
& ~INTMASK
) == 0);
4149 /* Increment count after resizing because resizing may fail. */
4150 maybe_resize_hash_table (h
);
4153 /* Store key/value in the key_and_value vector. */
4154 i
= XFASTINT (h
->next_free
);
4155 h
->next_free
= HASH_NEXT (h
, i
);
4156 HASH_KEY (h
, i
) = key
;
4157 HASH_VALUE (h
, i
) = value
;
4159 /* Remember its hash code. */
4160 HASH_HASH (h
, i
) = make_number (hash
);
4162 /* Add new entry to its collision chain. */
4163 start_of_bucket
= hash
% ASIZE (h
->index
);
4164 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4165 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4170 /* Remove the entry matching KEY from hash table H, if there is one. */
4173 hash_remove_from_table (h
, key
)
4174 struct Lisp_Hash_Table
*h
;
4178 int start_of_bucket
;
4179 Lisp_Object idx
, prev
;
4181 hash_code
= h
->hashfn (h
, key
);
4182 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4183 idx
= HASH_INDEX (h
, start_of_bucket
);
4186 /* We need not gcpro idx, prev since they're either integers or nil. */
4189 int i
= XFASTINT (idx
);
4191 if (EQ (key
, HASH_KEY (h
, i
))
4193 && h
->cmpfn (h
, key
, hash_code
,
4194 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4196 /* Take entry out of collision chain. */
4198 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4200 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4202 /* Clear slots in key_and_value and add the slots to
4204 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4205 HASH_NEXT (h
, i
) = h
->next_free
;
4206 h
->next_free
= make_number (i
);
4208 xassert (h
->count
>= 0);
4214 idx
= HASH_NEXT (h
, i
);
4220 /* Clear hash table H. */
4224 struct Lisp_Hash_Table
*h
;
4228 int i
, size
= HASH_TABLE_SIZE (h
);
4230 for (i
= 0; i
< size
; ++i
)
4232 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4233 HASH_KEY (h
, i
) = Qnil
;
4234 HASH_VALUE (h
, i
) = Qnil
;
4235 HASH_HASH (h
, i
) = Qnil
;
4238 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4239 ASET (h
->index
, i
, Qnil
);
4241 h
->next_free
= make_number (0);
4248 /************************************************************************
4250 ************************************************************************/
4253 init_weak_hash_tables ()
4255 weak_hash_tables
= NULL
;
4258 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4259 entries from the table that don't survive the current GC.
4260 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4261 non-zero if anything was marked. */
4264 sweep_weak_table (h
, remove_entries_p
)
4265 struct Lisp_Hash_Table
*h
;
4266 int remove_entries_p
;
4268 int bucket
, n
, marked
;
4270 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4273 for (bucket
= 0; bucket
< n
; ++bucket
)
4275 Lisp_Object idx
, next
, prev
;
4277 /* Follow collision chain, removing entries that
4278 don't survive this garbage collection. */
4280 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4282 int i
= XFASTINT (idx
);
4283 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4284 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4287 if (EQ (h
->weak
, Qkey
))
4288 remove_p
= !key_known_to_survive_p
;
4289 else if (EQ (h
->weak
, Qvalue
))
4290 remove_p
= !value_known_to_survive_p
;
4291 else if (EQ (h
->weak
, Qkey_or_value
))
4292 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4293 else if (EQ (h
->weak
, Qkey_and_value
))
4294 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4298 next
= HASH_NEXT (h
, i
);
4300 if (remove_entries_p
)
4304 /* Take out of collision chain. */
4306 HASH_INDEX (h
, bucket
) = next
;
4308 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4310 /* Add to free list. */
4311 HASH_NEXT (h
, i
) = h
->next_free
;
4314 /* Clear key, value, and hash. */
4315 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4316 HASH_HASH (h
, i
) = Qnil
;
4329 /* Make sure key and value survive. */
4330 if (!key_known_to_survive_p
)
4332 mark_object (HASH_KEY (h
, i
));
4336 if (!value_known_to_survive_p
)
4338 mark_object (HASH_VALUE (h
, i
));
4349 /* Remove elements from weak hash tables that don't survive the
4350 current garbage collection. Remove weak tables that don't survive
4351 from Vweak_hash_tables. Called from gc_sweep. */
4354 sweep_weak_hash_tables ()
4356 struct Lisp_Hash_Table
*h
, *used
, *next
;
4359 /* Mark all keys and values that are in use. Keep on marking until
4360 there is no more change. This is necessary for cases like
4361 value-weak table A containing an entry X -> Y, where Y is used in a
4362 key-weak table B, Z -> Y. If B comes after A in the list of weak
4363 tables, X -> Y might be removed from A, although when looking at B
4364 one finds that it shouldn't. */
4368 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4370 if (h
->size
& ARRAY_MARK_FLAG
)
4371 marked
|= sweep_weak_table (h
, 0);
4376 /* Remove tables and entries that aren't used. */
4377 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4379 next
= h
->next_weak
;
4381 if (h
->size
& ARRAY_MARK_FLAG
)
4383 /* TABLE is marked as used. Sweep its contents. */
4385 sweep_weak_table (h
, 1);
4387 /* Add table to the list of used weak hash tables. */
4388 h
->next_weak
= used
;
4393 weak_hash_tables
= used
;
4398 /***********************************************************************
4399 Hash Code Computation
4400 ***********************************************************************/
4402 /* Maximum depth up to which to dive into Lisp structures. */
4404 #define SXHASH_MAX_DEPTH 3
4406 /* Maximum length up to which to take list and vector elements into
4409 #define SXHASH_MAX_LEN 7
4411 /* Combine two integers X and Y for hashing. */
4413 #define SXHASH_COMBINE(X, Y) \
4414 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4418 /* Return a hash for string PTR which has length LEN. The hash
4419 code returned is guaranteed to fit in a Lisp integer. */
4422 sxhash_string (ptr
, len
)
4426 unsigned char *p
= ptr
;
4427 unsigned char *end
= p
+ len
;
4436 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4439 return hash
& INTMASK
;
4443 /* Return a hash for list LIST. DEPTH is the current depth in the
4444 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4447 sxhash_list (list
, depth
)
4454 if (depth
< SXHASH_MAX_DEPTH
)
4456 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4457 list
= XCDR (list
), ++i
)
4459 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4460 hash
= SXHASH_COMBINE (hash
, hash2
);
4465 unsigned hash2
= sxhash (list
, depth
+ 1);
4466 hash
= SXHASH_COMBINE (hash
, hash2
);
4473 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4474 the Lisp structure. */
4477 sxhash_vector (vec
, depth
)
4481 unsigned hash
= ASIZE (vec
);
4484 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4485 for (i
= 0; i
< n
; ++i
)
4487 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4488 hash
= SXHASH_COMBINE (hash
, hash2
);
4495 /* Return a hash for bool-vector VECTOR. */
4498 sxhash_bool_vector (vec
)
4501 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4504 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4505 for (i
= 0; i
< n
; ++i
)
4506 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4512 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4513 structure. Value is an unsigned integer clipped to INTMASK. */
4522 if (depth
> SXHASH_MAX_DEPTH
)
4525 switch (XTYPE (obj
))
4536 obj
= SYMBOL_NAME (obj
);
4540 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4543 /* This can be everything from a vector to an overlay. */
4544 case Lisp_Vectorlike
:
4546 /* According to the CL HyperSpec, two arrays are equal only if
4547 they are `eq', except for strings and bit-vectors. In
4548 Emacs, this works differently. We have to compare element
4550 hash
= sxhash_vector (obj
, depth
);
4551 else if (BOOL_VECTOR_P (obj
))
4552 hash
= sxhash_bool_vector (obj
);
4554 /* Others are `equal' if they are `eq', so let's take their
4560 hash
= sxhash_list (obj
, depth
);
4565 double val
= XFLOAT_DATA (obj
);
4566 unsigned char *p
= (unsigned char *) &val
;
4567 unsigned char *e
= p
+ sizeof val
;
4568 for (hash
= 0; p
< e
; ++p
)
4569 hash
= SXHASH_COMBINE (hash
, *p
);
4577 return hash
& INTMASK
;
4582 /***********************************************************************
4584 ***********************************************************************/
4587 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4588 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4592 unsigned hash
= sxhash (obj
, 0);
4593 return make_number (hash
);
4597 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4598 doc
: /* Create and return a new hash table.
4600 Arguments are specified as keyword/argument pairs. The following
4601 arguments are defined:
4603 :test TEST -- TEST must be a symbol that specifies how to compare
4604 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4605 `equal'. User-supplied test and hash functions can be specified via
4606 `define-hash-table-test'.
4608 :size SIZE -- A hint as to how many elements will be put in the table.
4611 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4612 fills up. If REHASH-SIZE is an integer, add that many space. If it
4613 is a float, it must be > 1.0, and the new size is computed by
4614 multiplying the old size with that factor. Default is 1.5.
4616 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4617 Resize the hash table when ratio of the number of entries in the
4618 table. Default is 0.8.
4620 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4621 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4622 returned is a weak table. Key/value pairs are removed from a weak
4623 hash table when there are no non-weak references pointing to their
4624 key, value, one of key or value, or both key and value, depending on
4625 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4628 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4633 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4634 Lisp_Object user_test
, user_hash
;
4638 /* The vector `used' is used to keep track of arguments that
4639 have been consumed. */
4640 used
= (char *) alloca (nargs
* sizeof *used
);
4641 bzero (used
, nargs
* sizeof *used
);
4643 /* See if there's a `:test TEST' among the arguments. */
4644 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4645 test
= i
< 0 ? Qeql
: args
[i
];
4646 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4648 /* See if it is a user-defined test. */
4651 prop
= Fget (test
, Qhash_table_test
);
4652 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4653 signal_error ("Invalid hash table test", test
);
4654 user_test
= XCAR (prop
);
4655 user_hash
= XCAR (XCDR (prop
));
4658 user_test
= user_hash
= Qnil
;
4660 /* See if there's a `:size SIZE' argument. */
4661 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4662 size
= i
< 0 ? Qnil
: args
[i
];
4664 size
= make_number (DEFAULT_HASH_SIZE
);
4665 else if (!INTEGERP (size
) || XINT (size
) < 0)
4666 signal_error ("Invalid hash table size", size
);
4668 /* Look for `:rehash-size SIZE'. */
4669 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4670 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4671 if (!NUMBERP (rehash_size
)
4672 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4673 || XFLOATINT (rehash_size
) <= 1.0)
4674 signal_error ("Invalid hash table rehash size", rehash_size
);
4676 /* Look for `:rehash-threshold THRESHOLD'. */
4677 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4678 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4679 if (!FLOATP (rehash_threshold
)
4680 || XFLOATINT (rehash_threshold
) <= 0.0
4681 || XFLOATINT (rehash_threshold
) > 1.0)
4682 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4684 /* Look for `:weakness WEAK'. */
4685 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4686 weak
= i
< 0 ? Qnil
: args
[i
];
4688 weak
= Qkey_and_value
;
4691 && !EQ (weak
, Qvalue
)
4692 && !EQ (weak
, Qkey_or_value
)
4693 && !EQ (weak
, Qkey_and_value
))
4694 signal_error ("Invalid hash table weakness", weak
);
4696 /* Now, all args should have been used up, or there's a problem. */
4697 for (i
= 0; i
< nargs
; ++i
)
4699 signal_error ("Invalid argument list", args
[i
]);
4701 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4702 user_test
, user_hash
);
4706 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4707 doc
: /* Return a copy of hash table TABLE. */)
4711 return copy_hash_table (check_hash_table (table
));
4715 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4716 doc
: /* Return the number of elements in TABLE. */)
4720 return make_number (check_hash_table (table
)->count
);
4724 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4725 Shash_table_rehash_size
, 1, 1, 0,
4726 doc
: /* Return the current rehash size of TABLE. */)
4730 return check_hash_table (table
)->rehash_size
;
4734 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4735 Shash_table_rehash_threshold
, 1, 1, 0,
4736 doc
: /* Return the current rehash threshold of TABLE. */)
4740 return check_hash_table (table
)->rehash_threshold
;
4744 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4745 doc
: /* Return the size of TABLE.
4746 The size can be used as an argument to `make-hash-table' to create
4747 a hash table than can hold as many elements of TABLE holds
4748 without need for resizing. */)
4752 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4753 return make_number (HASH_TABLE_SIZE (h
));
4757 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4758 doc
: /* Return the test TABLE uses. */)
4762 return check_hash_table (table
)->test
;
4766 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4768 doc
: /* Return the weakness of TABLE. */)
4772 return check_hash_table (table
)->weak
;
4776 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4777 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4781 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4785 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4786 doc
: /* Clear hash table TABLE and return it. */)
4790 hash_clear (check_hash_table (table
));
4791 /* Be compatible with XEmacs. */
4796 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4797 doc
: /* Look up KEY in TABLE and return its associated value.
4798 If KEY is not found, return DFLT which defaults to nil. */)
4800 Lisp_Object key
, table
, dflt
;
4802 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4803 int i
= hash_lookup (h
, key
, NULL
);
4804 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4808 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4809 doc
: /* Associate KEY with VALUE in hash table TABLE.
4810 If KEY is already present in table, replace its current value with
4813 Lisp_Object key
, value
, table
;
4815 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4819 i
= hash_lookup (h
, key
, &hash
);
4821 HASH_VALUE (h
, i
) = value
;
4823 hash_put (h
, key
, value
, hash
);
4829 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4830 doc
: /* Remove KEY from TABLE. */)
4832 Lisp_Object key
, table
;
4834 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4835 hash_remove_from_table (h
, key
);
4840 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4841 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4842 FUNCTION is called with two arguments, KEY and VALUE. */)
4844 Lisp_Object function
, table
;
4846 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4847 Lisp_Object args
[3];
4850 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4851 if (!NILP (HASH_HASH (h
, i
)))
4854 args
[1] = HASH_KEY (h
, i
);
4855 args
[2] = HASH_VALUE (h
, i
);
4863 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4864 Sdefine_hash_table_test
, 3, 3, 0,
4865 doc
: /* Define a new hash table test with name NAME, a symbol.
4867 In hash tables created with NAME specified as test, use TEST to
4868 compare keys, and HASH for computing hash codes of keys.
4870 TEST must be a function taking two arguments and returning non-nil if
4871 both arguments are the same. HASH must be a function taking one
4872 argument and return an integer that is the hash code of the argument.
4873 Hash code computation should use the whole value range of integers,
4874 including negative integers. */)
4876 Lisp_Object name
, test
, hash
;
4878 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4883 /************************************************************************
4885 ************************************************************************/
4889 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4890 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4892 A message digest is a cryptographic checksum of a document, and the
4893 algorithm to calculate it is defined in RFC 1321.
4895 The two optional arguments START and END are character positions
4896 specifying for which part of OBJECT the message digest should be
4897 computed. If nil or omitted, the digest is computed for the whole
4900 The MD5 message digest is computed from the result of encoding the
4901 text in a coding system, not directly from the internal Emacs form of
4902 the text. The optional fourth argument CODING-SYSTEM specifies which
4903 coding system to encode the text with. It should be the same coding
4904 system that you used or will use when actually writing the text into a
4907 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4908 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4909 system would be chosen by default for writing this text into a file.
4911 If OBJECT is a string, the most preferred coding system (see the
4912 command `prefer-coding-system') is used.
4914 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4915 guesswork fails. Normally, an error is signaled in such case. */)
4916 (object
, start
, end
, coding_system
, noerror
)
4917 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4919 unsigned char digest
[16];
4920 unsigned char value
[33];
4924 int start_char
= 0, end_char
= 0;
4925 int start_byte
= 0, end_byte
= 0;
4927 register struct buffer
*bp
;
4930 if (STRINGP (object
))
4932 if (NILP (coding_system
))
4934 /* Decide the coding-system to encode the data with. */
4936 if (STRING_MULTIBYTE (object
))
4937 /* use default, we can't guess correct value */
4938 coding_system
= preferred_coding_system ();
4940 coding_system
= Qraw_text
;
4943 if (NILP (Fcoding_system_p (coding_system
)))
4945 /* Invalid coding system. */
4947 if (!NILP (noerror
))
4948 coding_system
= Qraw_text
;
4950 xsignal1 (Qcoding_system_error
, coding_system
);
4953 if (STRING_MULTIBYTE (object
))
4954 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4956 size
= SCHARS (object
);
4957 size_byte
= SBYTES (object
);
4961 CHECK_NUMBER (start
);
4963 start_char
= XINT (start
);
4968 start_byte
= string_char_to_byte (object
, start_char
);
4974 end_byte
= size_byte
;
4980 end_char
= XINT (end
);
4985 end_byte
= string_char_to_byte (object
, end_char
);
4988 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4989 args_out_of_range_3 (object
, make_number (start_char
),
4990 make_number (end_char
));
4994 struct buffer
*prev
= current_buffer
;
4996 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4998 CHECK_BUFFER (object
);
5000 bp
= XBUFFER (object
);
5001 if (bp
!= current_buffer
)
5002 set_buffer_internal (bp
);
5008 CHECK_NUMBER_COERCE_MARKER (start
);
5016 CHECK_NUMBER_COERCE_MARKER (end
);
5021 temp
= b
, b
= e
, e
= temp
;
5023 if (!(BEGV
<= b
&& e
<= ZV
))
5024 args_out_of_range (start
, end
);
5026 if (NILP (coding_system
))
5028 /* Decide the coding-system to encode the data with.
5029 See fileio.c:Fwrite-region */
5031 if (!NILP (Vcoding_system_for_write
))
5032 coding_system
= Vcoding_system_for_write
;
5035 int force_raw_text
= 0;
5037 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5038 if (NILP (coding_system
)
5039 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5041 coding_system
= Qnil
;
5042 if (NILP (current_buffer
->enable_multibyte_characters
))
5046 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5048 /* Check file-coding-system-alist. */
5049 Lisp_Object args
[4], val
;
5051 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5052 args
[3] = Fbuffer_file_name(object
);
5053 val
= Ffind_operation_coding_system (4, args
);
5054 if (CONSP (val
) && !NILP (XCDR (val
)))
5055 coding_system
= XCDR (val
);
5058 if (NILP (coding_system
)
5059 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5061 /* If we still have not decided a coding system, use the
5062 default value of buffer-file-coding-system. */
5063 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5067 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5068 /* Confirm that VAL can surely encode the current region. */
5069 coding_system
= call4 (Vselect_safe_coding_system_function
,
5070 make_number (b
), make_number (e
),
5071 coding_system
, Qnil
);
5074 coding_system
= Qraw_text
;
5077 if (NILP (Fcoding_system_p (coding_system
)))
5079 /* Invalid coding system. */
5081 if (!NILP (noerror
))
5082 coding_system
= Qraw_text
;
5084 xsignal1 (Qcoding_system_error
, coding_system
);
5088 object
= make_buffer_string (b
, e
, 0);
5089 if (prev
!= current_buffer
)
5090 set_buffer_internal (prev
);
5091 /* Discard the unwind protect for recovering the current
5095 if (STRING_MULTIBYTE (object
))
5096 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5099 md5_buffer (SDATA (object
) + start_byte
,
5100 SBYTES (object
) - (size_byte
- end_byte
),
5103 for (i
= 0; i
< 16; i
++)
5104 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5107 return make_string (value
, 32);
5114 /* Hash table stuff. */
5115 Qhash_table_p
= intern_c_string ("hash-table-p");
5116 staticpro (&Qhash_table_p
);
5117 Qeq
= intern_c_string ("eq");
5119 Qeql
= intern_c_string ("eql");
5121 Qequal
= intern_c_string ("equal");
5122 staticpro (&Qequal
);
5123 QCtest
= intern_c_string (":test");
5124 staticpro (&QCtest
);
5125 QCsize
= intern_c_string (":size");
5126 staticpro (&QCsize
);
5127 QCrehash_size
= intern_c_string (":rehash-size");
5128 staticpro (&QCrehash_size
);
5129 QCrehash_threshold
= intern_c_string (":rehash-threshold");
5130 staticpro (&QCrehash_threshold
);
5131 QCweakness
= intern_c_string (":weakness");
5132 staticpro (&QCweakness
);
5133 Qkey
= intern_c_string ("key");
5135 Qvalue
= intern_c_string ("value");
5136 staticpro (&Qvalue
);
5137 Qhash_table_test
= intern_c_string ("hash-table-test");
5138 staticpro (&Qhash_table_test
);
5139 Qkey_or_value
= intern_c_string ("key-or-value");
5140 staticpro (&Qkey_or_value
);
5141 Qkey_and_value
= intern_c_string ("key-and-value");
5142 staticpro (&Qkey_and_value
);
5145 defsubr (&Smake_hash_table
);
5146 defsubr (&Scopy_hash_table
);
5147 defsubr (&Shash_table_count
);
5148 defsubr (&Shash_table_rehash_size
);
5149 defsubr (&Shash_table_rehash_threshold
);
5150 defsubr (&Shash_table_size
);
5151 defsubr (&Shash_table_test
);
5152 defsubr (&Shash_table_weakness
);
5153 defsubr (&Shash_table_p
);
5154 defsubr (&Sclrhash
);
5155 defsubr (&Sgethash
);
5156 defsubr (&Sputhash
);
5157 defsubr (&Sremhash
);
5158 defsubr (&Smaphash
);
5159 defsubr (&Sdefine_hash_table_test
);
5161 Qstring_lessp
= intern_c_string ("string-lessp");
5162 staticpro (&Qstring_lessp
);
5163 Qprovide
= intern_c_string ("provide");
5164 staticpro (&Qprovide
);
5165 Qrequire
= intern_c_string ("require");
5166 staticpro (&Qrequire
);
5167 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
5168 staticpro (&Qyes_or_no_p_history
);
5169 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
5170 staticpro (&Qcursor_in_echo_area
);
5171 Qwidget_type
= intern_c_string ("widget-type");
5172 staticpro (&Qwidget_type
);
5174 staticpro (&string_char_byte_cache_string
);
5175 string_char_byte_cache_string
= Qnil
;
5177 require_nesting_list
= Qnil
;
5178 staticpro (&require_nesting_list
);
5180 Fset (Qyes_or_no_p_history
, Qnil
);
5182 DEFVAR_LISP ("features", &Vfeatures
,
5183 doc
: /* A list of symbols which are the features of the executing Emacs.
5184 Used by `featurep' and `require', and altered by `provide'. */);
5185 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
5186 Qsubfeatures
= intern_c_string ("subfeatures");
5187 staticpro (&Qsubfeatures
);
5189 #ifdef HAVE_LANGINFO_CODESET
5190 Qcodeset
= intern_c_string ("codeset");
5191 staticpro (&Qcodeset
);
5192 Qdays
= intern_c_string ("days");
5194 Qmonths
= intern_c_string ("months");
5195 staticpro (&Qmonths
);
5196 Qpaper
= intern_c_string ("paper");
5197 staticpro (&Qpaper
);
5198 #endif /* HAVE_LANGINFO_CODESET */
5200 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5201 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5202 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5203 invoked by mouse clicks and mouse menu items.
5205 On some platforms, file selection dialogs are also enabled if this is
5209 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5210 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5211 This applies to commands from menus and tool bar buttons even when
5212 they are initiated from the keyboard. If `use-dialog-box' is nil,
5213 that disables the use of a file dialog, regardless of the value of
5215 use_file_dialog
= 1;
5217 defsubr (&Sidentity
);
5220 defsubr (&Ssafe_length
);
5221 defsubr (&Sstring_bytes
);
5222 defsubr (&Sstring_equal
);
5223 defsubr (&Scompare_strings
);
5224 defsubr (&Sstring_lessp
);
5227 defsubr (&Svconcat
);
5228 defsubr (&Scopy_sequence
);
5229 defsubr (&Sstring_make_multibyte
);
5230 defsubr (&Sstring_make_unibyte
);
5231 defsubr (&Sstring_as_multibyte
);
5232 defsubr (&Sstring_as_unibyte
);
5233 defsubr (&Sstring_to_multibyte
);
5234 defsubr (&Sstring_to_unibyte
);
5235 defsubr (&Scopy_alist
);
5236 defsubr (&Ssubstring
);
5237 defsubr (&Ssubstring_no_properties
);
5250 defsubr (&Snreverse
);
5251 defsubr (&Sreverse
);
5253 defsubr (&Splist_get
);
5255 defsubr (&Splist_put
);
5257 defsubr (&Slax_plist_get
);
5258 defsubr (&Slax_plist_put
);
5261 defsubr (&Sequal_including_properties
);
5262 defsubr (&Sfillarray
);
5263 defsubr (&Sclear_string
);
5267 defsubr (&Smapconcat
);
5268 defsubr (&Sy_or_n_p
);
5269 defsubr (&Syes_or_no_p
);
5270 defsubr (&Sload_average
);
5271 defsubr (&Sfeaturep
);
5272 defsubr (&Srequire
);
5273 defsubr (&Sprovide
);
5274 defsubr (&Splist_member
);
5275 defsubr (&Swidget_put
);
5276 defsubr (&Swidget_get
);
5277 defsubr (&Swidget_apply
);
5278 defsubr (&Sbase64_encode_region
);
5279 defsubr (&Sbase64_decode_region
);
5280 defsubr (&Sbase64_encode_string
);
5281 defsubr (&Sbase64_decode_string
);
5283 defsubr (&Slocale_info
);
5292 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5293 (do not change this comment) */