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 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)
48 #elif defined (MAC_OS)
54 #define NULL ((POINTER_TYPE *)0)
57 /* Nonzero enables use of dialog boxes for questions
58 asked by mouse commands. */
61 /* Nonzero enables use of a file dialog for file name
62 questions asked by mouse commands. */
65 extern int minibuffer_auto_raise
;
66 extern Lisp_Object minibuf_window
;
67 extern Lisp_Object Vlocale_coding_system
;
68 extern int load_in_progress
;
70 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
71 Lisp_Object Qyes_or_no_p_history
;
72 Lisp_Object Qcursor_in_echo_area
;
73 Lisp_Object Qwidget_type
;
74 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
76 extern Lisp_Object Qinput_method_function
;
78 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
80 extern long get_random ();
81 extern void seed_random
P_ ((long));
87 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
88 doc
: /* Return the argument unchanged. */)
95 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
96 doc
: /* Return a pseudo-random number.
97 All integers representable in Lisp are equally likely.
98 On most systems, this is 29 bits' worth.
99 With positive integer LIMIT, return random number in interval [0,LIMIT).
100 With argument t, set the random number seed from the current time and pid.
101 Other values of LIMIT are ignored. */)
106 Lisp_Object lispy_val
;
107 unsigned long denominator
;
110 seed_random (getpid () + time (NULL
));
111 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
113 /* Try to take our random number from the higher bits of VAL,
114 not the lower, since (says Gentzel) the low bits of `random'
115 are less random than the higher ones. We do this by using the
116 quotient rather than the remainder. At the high end of the RNG
117 it's possible to get a quotient larger than n; discarding
118 these values eliminates the bias that would otherwise appear
119 when using a large n. */
120 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
122 val
= get_random () / denominator
;
123 while (val
>= XFASTINT (limit
));
127 XSETINT (lispy_val
, val
);
131 /* Random data-structure functions */
133 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
134 doc
: /* Return the length of vector, list or string SEQUENCE.
135 A byte-code function object is also allowed.
136 If the string contains multibyte characters, this is not necessarily
137 the number of bytes in the string; it is the number of characters.
138 To get the number of bytes, use `string-bytes'. */)
140 register Lisp_Object sequence
;
142 register Lisp_Object val
;
145 if (STRINGP (sequence
))
146 XSETFASTINT (val
, SCHARS (sequence
));
147 else if (VECTORP (sequence
))
148 XSETFASTINT (val
, ASIZE (sequence
));
149 else if (CHAR_TABLE_P (sequence
))
150 XSETFASTINT (val
, MAX_CHAR
);
151 else if (BOOL_VECTOR_P (sequence
))
152 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
153 else if (COMPILEDP (sequence
))
154 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
155 else if (CONSP (sequence
))
158 while (CONSP (sequence
))
160 sequence
= XCDR (sequence
);
163 if (!CONSP (sequence
))
166 sequence
= XCDR (sequence
);
171 CHECK_LIST_END (sequence
, sequence
);
173 val
= make_number (i
);
175 else if (NILP (sequence
))
176 XSETFASTINT (val
, 0);
178 wrong_type_argument (Qsequencep
, sequence
);
183 /* This does not check for quits. That is safe since it must terminate. */
185 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
186 doc
: /* Return the length of a list, but avoid error or infinite loop.
187 This function never gets an error. If LIST is not really a list,
188 it returns 0. If LIST is circular, it returns a finite value
189 which is at least the number of distinct elements. */)
193 Lisp_Object tail
, halftail
, length
;
196 /* halftail is used to detect circular lists. */
198 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
200 if (EQ (tail
, halftail
) && len
!= 0)
204 halftail
= XCDR (halftail
);
207 XSETINT (length
, len
);
211 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
212 doc
: /* Return the number of bytes in STRING.
213 If STRING is multibyte, this may be greater than the length of STRING. */)
217 CHECK_STRING (string
);
218 return make_number (SBYTES (string
));
221 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
222 doc
: /* Return t if two strings have identical contents.
223 Case is significant, but text properties are ignored.
224 Symbols are also allowed; their print names are used instead. */)
226 register Lisp_Object s1
, s2
;
229 s1
= SYMBOL_NAME (s1
);
231 s2
= SYMBOL_NAME (s2
);
235 if (SCHARS (s1
) != SCHARS (s2
)
236 || SBYTES (s1
) != SBYTES (s2
)
237 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
242 DEFUN ("compare-strings", Fcompare_strings
,
243 Scompare_strings
, 6, 7, 0,
244 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
245 In string STR1, skip the first START1 characters and stop at END1.
246 In string STR2, skip the first START2 characters and stop at END2.
247 END1 and END2 default to the full lengths of the respective strings.
249 Case is significant in this comparison if IGNORE-CASE is nil.
250 Unibyte strings are converted to multibyte for comparison.
252 The value is t if the strings (or specified portions) match.
253 If string STR1 is less, the value is a negative number N;
254 - 1 - N is the number of characters that match at the beginning.
255 If string STR1 is greater, the value is a positive number N;
256 N - 1 is the number of characters that match at the beginning. */)
257 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
258 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
260 register int end1_char
, end2_char
;
261 register int i1
, i1_byte
, i2
, i2_byte
;
266 start1
= make_number (0);
268 start2
= make_number (0);
269 CHECK_NATNUM (start1
);
270 CHECK_NATNUM (start2
);
279 i1_byte
= string_char_to_byte (str1
, i1
);
280 i2_byte
= string_char_to_byte (str2
, i2
);
282 end1_char
= SCHARS (str1
);
283 if (! NILP (end1
) && end1_char
> XINT (end1
))
284 end1_char
= XINT (end1
);
286 end2_char
= SCHARS (str2
);
287 if (! NILP (end2
) && end2_char
> XINT (end2
))
288 end2_char
= XINT (end2
);
290 while (i1
< end1_char
&& i2
< end2_char
)
292 /* When we find a mismatch, we must compare the
293 characters, not just the bytes. */
296 if (STRING_MULTIBYTE (str1
))
297 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
300 c1
= SREF (str1
, i1
++);
301 MAKE_CHAR_MULTIBYTE (c1
);
304 if (STRING_MULTIBYTE (str2
))
305 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
308 c2
= SREF (str2
, i2
++);
309 MAKE_CHAR_MULTIBYTE (c2
);
315 if (! NILP (ignore_case
))
319 tem
= Fupcase (make_number (c1
));
321 tem
= Fupcase (make_number (c2
));
328 /* Note that I1 has already been incremented
329 past the character that we are comparing;
330 hence we don't add or subtract 1 here. */
332 return make_number (- i1
+ XINT (start1
));
334 return make_number (i1
- XINT (start1
));
338 return make_number (i1
- XINT (start1
) + 1);
340 return make_number (- i1
+ XINT (start1
) - 1);
345 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
346 doc
: /* Return t if first arg string is less than second in lexicographic order.
348 Symbols are also allowed; their print names are used instead. */)
350 register Lisp_Object s1
, s2
;
353 register int i1
, i1_byte
, i2
, i2_byte
;
356 s1
= SYMBOL_NAME (s1
);
358 s2
= SYMBOL_NAME (s2
);
362 i1
= i1_byte
= i2
= i2_byte
= 0;
365 if (end
> SCHARS (s2
))
370 /* When we find a mismatch, we must compare the
371 characters, not just the bytes. */
374 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
375 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
378 return c1
< c2
? Qt
: Qnil
;
380 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
384 /* "gcc -O3" enables automatic function inlining, which optimizes out
385 the arguments for the invocations of this function, whereas it
386 expects these values on the stack. */
387 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
388 #else /* !__GNUC__ */
389 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
401 return concat (2, args
, Lisp_String
, 0);
403 return concat (2, &s1
, Lisp_String
, 0);
404 #endif /* NO_ARG_ARRAY */
410 Lisp_Object s1
, s2
, s3
;
417 return concat (3, args
, Lisp_String
, 0);
419 return concat (3, &s1
, Lisp_String
, 0);
420 #endif /* NO_ARG_ARRAY */
423 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
424 doc
: /* Concatenate all the arguments and make the result a list.
425 The result is a list whose elements are the elements of all the arguments.
426 Each argument may be a list, vector or string.
427 The last argument is not copied, just used as the tail of the new list.
428 usage: (append &rest SEQUENCES) */)
433 return concat (nargs
, args
, Lisp_Cons
, 1);
436 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
437 doc
: /* Concatenate all the arguments and make the result a string.
438 The result is a string whose elements are the elements of all the arguments.
439 Each argument may be a string or a list or vector of characters (integers).
440 usage: (concat &rest SEQUENCES) */)
445 return concat (nargs
, args
, Lisp_String
, 0);
448 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
449 doc
: /* Concatenate all the arguments and make the result a vector.
450 The result is a vector whose elements are the elements of all the arguments.
451 Each argument may be a list, vector or string.
452 usage: (vconcat &rest SEQUENCES) */)
457 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
461 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
462 doc
: /* Return a copy of a list, vector, string or char-table.
463 The elements of a list or vector are not copied; they are shared
464 with the original. */)
468 if (NILP (arg
)) return arg
;
470 if (CHAR_TABLE_P (arg
))
472 return copy_char_table (arg
);
475 if (BOOL_VECTOR_P (arg
))
479 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
480 / BOOL_VECTOR_BITS_PER_CHAR
);
482 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
483 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
488 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
489 wrong_type_argument (Qsequencep
, arg
);
491 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
494 /* This structure holds information of an argument of `concat' that is
495 a string and has text properties to be copied. */
498 int argnum
; /* refer to ARGS (arguments of `concat') */
499 int from
; /* refer to ARGS[argnum] (argument string) */
500 int to
; /* refer to VAL (the target string) */
504 concat (nargs
, args
, target_type
, last_special
)
507 enum Lisp_Type target_type
;
511 register Lisp_Object tail
;
512 register Lisp_Object
this;
514 int toindex_byte
= 0;
515 register int result_len
;
516 register int result_len_byte
;
518 Lisp_Object last_tail
;
521 /* When we make a multibyte string, we can't copy text properties
522 while concatinating each string because the length of resulting
523 string can't be decided until we finish the whole concatination.
524 So, we record strings that have text properties to be copied
525 here, and copy the text properties after the concatination. */
526 struct textprop_rec
*textprops
= NULL
;
527 /* Number of elments in textprops. */
528 int num_textprops
= 0;
533 /* In append, the last arg isn't treated like the others */
534 if (last_special
&& nargs
> 0)
537 last_tail
= args
[nargs
];
542 /* Check each argument. */
543 for (argnum
= 0; argnum
< nargs
; argnum
++)
546 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
547 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
548 wrong_type_argument (Qsequencep
, this);
551 /* Compute total length in chars of arguments in RESULT_LEN.
552 If desired output is a string, also compute length in bytes
553 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
554 whether the result should be a multibyte string. */
558 for (argnum
= 0; argnum
< nargs
; argnum
++)
562 len
= XFASTINT (Flength (this));
563 if (target_type
== Lisp_String
)
565 /* We must count the number of bytes needed in the string
566 as well as the number of characters. */
572 for (i
= 0; i
< len
; i
++)
575 CHECK_CHARACTER (ch
);
576 this_len_byte
= CHAR_BYTES (XINT (ch
));
577 result_len_byte
+= this_len_byte
;
578 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
581 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
582 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
583 else if (CONSP (this))
584 for (; CONSP (this); this = XCDR (this))
587 CHECK_CHARACTER (ch
);
588 this_len_byte
= CHAR_BYTES (XINT (ch
));
589 result_len_byte
+= this_len_byte
;
590 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
593 else if (STRINGP (this))
595 if (STRING_MULTIBYTE (this))
598 result_len_byte
+= SBYTES (this);
601 result_len_byte
+= count_size_as_multibyte (SDATA (this),
608 error ("String overflow");
611 if (! some_multibyte
)
612 result_len_byte
= result_len
;
614 /* Create the output object. */
615 if (target_type
== Lisp_Cons
)
616 val
= Fmake_list (make_number (result_len
), Qnil
);
617 else if (target_type
== Lisp_Vectorlike
)
618 val
= Fmake_vector (make_number (result_len
), Qnil
);
619 else if (some_multibyte
)
620 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
622 val
= make_uninit_string (result_len
);
624 /* In `append', if all but last arg are nil, return last arg. */
625 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
628 /* Copy the contents of the args into the result. */
630 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
632 toindex
= 0, toindex_byte
= 0;
636 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
638 for (argnum
= 0; argnum
< nargs
; argnum
++)
642 register unsigned int thisindex
= 0;
643 register unsigned int thisindex_byte
= 0;
647 thislen
= Flength (this), thisleni
= XINT (thislen
);
649 /* Between strings of the same kind, copy fast. */
650 if (STRINGP (this) && STRINGP (val
)
651 && STRING_MULTIBYTE (this) == some_multibyte
)
653 int thislen_byte
= SBYTES (this);
655 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
657 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
659 textprops
[num_textprops
].argnum
= argnum
;
660 textprops
[num_textprops
].from
= 0;
661 textprops
[num_textprops
++].to
= toindex
;
663 toindex_byte
+= thislen_byte
;
666 /* Copy a single-byte string to a multibyte string. */
667 else if (STRINGP (this) && STRINGP (val
))
669 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
671 textprops
[num_textprops
].argnum
= argnum
;
672 textprops
[num_textprops
].from
= 0;
673 textprops
[num_textprops
++].to
= toindex
;
675 toindex_byte
+= copy_text (SDATA (this),
676 SDATA (val
) + toindex_byte
,
677 SCHARS (this), 0, 1);
681 /* Copy element by element. */
684 register Lisp_Object elt
;
686 /* Fetch next element of `this' arg into `elt', or break if
687 `this' is exhausted. */
688 if (NILP (this)) break;
690 elt
= XCAR (this), this = XCDR (this);
691 else if (thisindex
>= thisleni
)
693 else if (STRINGP (this))
696 if (STRING_MULTIBYTE (this))
698 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
701 XSETFASTINT (elt
, c
);
705 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
707 && !ASCII_CHAR_P (XINT (elt
))
708 && XINT (elt
) < 0400)
710 c
= BYTE8_TO_CHAR (XINT (elt
));
715 else if (BOOL_VECTOR_P (this))
718 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
719 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
727 elt
= AREF (this, thisindex
);
731 /* Store this element into the result. */
738 else if (VECTORP (val
))
740 ASET (val
, toindex
, elt
);
747 toindex_byte
+= CHAR_STRING (XINT (elt
),
748 SDATA (val
) + toindex_byte
);
750 SSET (val
, toindex_byte
++, XINT (elt
));
756 XSETCDR (prev
, last_tail
);
758 if (num_textprops
> 0)
761 int last_to_end
= -1;
763 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
765 this = args
[textprops
[argnum
].argnum
];
766 props
= text_property_list (this,
768 make_number (SCHARS (this)),
770 /* If successive arguments have properites, be sure that the
771 value of `composition' property be the copy. */
772 if (last_to_end
== textprops
[argnum
].to
)
773 make_composition_value_copy (props
);
774 add_text_properties_from_list (val
, props
,
775 make_number (textprops
[argnum
].to
));
776 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
784 static Lisp_Object string_char_byte_cache_string
;
785 static EMACS_INT string_char_byte_cache_charpos
;
786 static EMACS_INT string_char_byte_cache_bytepos
;
789 clear_string_char_byte_cache ()
791 string_char_byte_cache_string
= Qnil
;
794 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
797 string_char_to_byte (string
, char_index
)
799 EMACS_INT char_index
;
802 EMACS_INT best_below
, best_below_byte
;
803 EMACS_INT best_above
, best_above_byte
;
805 best_below
= best_below_byte
= 0;
806 best_above
= SCHARS (string
);
807 best_above_byte
= SBYTES (string
);
808 if (best_above
== best_above_byte
)
811 if (EQ (string
, string_char_byte_cache_string
))
813 if (string_char_byte_cache_charpos
< char_index
)
815 best_below
= string_char_byte_cache_charpos
;
816 best_below_byte
= string_char_byte_cache_bytepos
;
820 best_above
= string_char_byte_cache_charpos
;
821 best_above_byte
= string_char_byte_cache_bytepos
;
825 if (char_index
- best_below
< best_above
- char_index
)
827 unsigned char *p
= SDATA (string
) + best_below_byte
;
829 while (best_below
< char_index
)
831 p
+= BYTES_BY_CHAR_HEAD (*p
);
834 i_byte
= p
- SDATA (string
);
838 unsigned char *p
= SDATA (string
) + best_above_byte
;
840 while (best_above
> char_index
)
843 while (!CHAR_HEAD_P (*p
)) p
--;
846 i_byte
= p
- SDATA (string
);
849 string_char_byte_cache_bytepos
= i_byte
;
850 string_char_byte_cache_charpos
= char_index
;
851 string_char_byte_cache_string
= string
;
856 /* Return the character index corresponding to BYTE_INDEX in STRING. */
859 string_byte_to_char (string
, byte_index
)
861 EMACS_INT byte_index
;
864 EMACS_INT best_below
, best_below_byte
;
865 EMACS_INT best_above
, best_above_byte
;
867 best_below
= best_below_byte
= 0;
868 best_above
= SCHARS (string
);
869 best_above_byte
= SBYTES (string
);
870 if (best_above
== best_above_byte
)
873 if (EQ (string
, string_char_byte_cache_string
))
875 if (string_char_byte_cache_bytepos
< byte_index
)
877 best_below
= string_char_byte_cache_charpos
;
878 best_below_byte
= string_char_byte_cache_bytepos
;
882 best_above
= string_char_byte_cache_charpos
;
883 best_above_byte
= string_char_byte_cache_bytepos
;
887 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
889 unsigned char *p
= SDATA (string
) + best_below_byte
;
890 unsigned char *pend
= SDATA (string
) + byte_index
;
894 p
+= BYTES_BY_CHAR_HEAD (*p
);
898 i_byte
= p
- SDATA (string
);
902 unsigned char *p
= SDATA (string
) + best_above_byte
;
903 unsigned char *pbeg
= SDATA (string
) + byte_index
;
908 while (!CHAR_HEAD_P (*p
)) p
--;
912 i_byte
= p
- SDATA (string
);
915 string_char_byte_cache_bytepos
= i_byte
;
916 string_char_byte_cache_charpos
= i
;
917 string_char_byte_cache_string
= string
;
922 /* Convert STRING to a multibyte string. */
925 string_make_multibyte (string
)
933 if (STRING_MULTIBYTE (string
))
936 nbytes
= count_size_as_multibyte (SDATA (string
),
938 /* If all the chars are ASCII, they won't need any more bytes
939 once converted. In that case, we can return STRING itself. */
940 if (nbytes
== SBYTES (string
))
943 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
944 copy_text (SDATA (string
), buf
, SBYTES (string
),
947 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
954 /* Convert STRING (if unibyte) to a multibyte string without changing
955 the number of characters. Characters 0200 trough 0237 are
956 converted to eight-bit characters. */
959 string_to_multibyte (string
)
967 if (STRING_MULTIBYTE (string
))
970 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
971 /* If all the chars are ASCII, they won't need any more bytes once
973 if (nbytes
== SBYTES (string
))
974 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
976 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
977 bcopy (SDATA (string
), buf
, SBYTES (string
));
978 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
980 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
987 /* Convert STRING to a single-byte string. */
990 string_make_unibyte (string
)
998 if (! STRING_MULTIBYTE (string
))
1001 nchars
= SCHARS (string
);
1003 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1004 copy_text (SDATA (string
), buf
, SBYTES (string
),
1007 ret
= make_unibyte_string (buf
, nchars
);
1013 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1015 doc
: /* Return the multibyte equivalent of STRING.
1016 If STRING is unibyte and contains non-ASCII characters, the function
1017 `unibyte-char-to-multibyte' is used to convert each unibyte character
1018 to a multibyte character. In this case, the returned string is a
1019 newly created string with no text properties. If STRING is multibyte
1020 or entirely ASCII, it is returned unchanged. In particular, when
1021 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1022 \(When the characters are all ASCII, Emacs primitives will treat the
1023 string the same way whether it is unibyte or multibyte.) */)
1027 CHECK_STRING (string
);
1029 return string_make_multibyte (string
);
1032 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1034 doc
: /* Return the unibyte equivalent of STRING.
1035 Multibyte character codes are converted to unibyte according to
1036 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1037 If the lookup in the translation table fails, this function takes just
1038 the low 8 bits of each character. */)
1042 CHECK_STRING (string
);
1044 return string_make_unibyte (string
);
1047 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1049 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1050 If STRING is unibyte, the result is STRING itself.
1051 Otherwise it is a newly created string, with no text properties.
1052 If STRING is multibyte and contains a character of charset
1053 `eight-bit', it is converted to the corresponding single byte. */)
1057 CHECK_STRING (string
);
1059 if (STRING_MULTIBYTE (string
))
1061 int bytes
= SBYTES (string
);
1062 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1064 bcopy (SDATA (string
), str
, bytes
);
1065 bytes
= str_as_unibyte (str
, bytes
);
1066 string
= make_unibyte_string (str
, bytes
);
1072 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1074 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1075 If STRING is multibyte, the result is STRING itself.
1076 Otherwise it is a newly created string, with no text properties.
1078 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1079 part of a correct utf-8 sequence), it is converted to the corresponding
1080 multibyte character of charset `eight-bit'.
1081 See also `string-to-multibyte'.
1083 Beware, this often doesn't really do what you think it does.
1084 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1085 If you're not sure, whether to use `string-as-multibyte' or
1086 `string-to-multibyte', use `string-to-multibyte'. */)
1090 CHECK_STRING (string
);
1092 if (! STRING_MULTIBYTE (string
))
1094 Lisp_Object new_string
;
1097 parse_str_as_multibyte (SDATA (string
),
1100 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1101 bcopy (SDATA (string
), SDATA (new_string
),
1103 if (nbytes
!= SBYTES (string
))
1104 str_as_multibyte (SDATA (new_string
), nbytes
,
1105 SBYTES (string
), NULL
);
1106 string
= new_string
;
1107 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1112 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1114 doc
: /* Return a multibyte string with the same individual chars as STRING.
1115 If STRING is multibyte, the result is STRING itself.
1116 Otherwise it is a newly created string, with no text properties.
1118 If STRING is unibyte and contains an 8-bit byte, it is converted to
1119 the corresponding multibyte character of charset `eight-bit'.
1121 This differs from `string-as-multibyte' by converting each byte of a correct
1122 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1123 correct sequence. */)
1127 CHECK_STRING (string
);
1129 return string_to_multibyte (string
);
1132 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1134 doc
: /* Return a unibyte string with the same individual chars as STRING.
1135 If STRING is unibyte, the result is STRING itself.
1136 Otherwise it is a newly created string, with no text properties,
1137 where each `eight-bit' character is converted to the corresponding byte.
1138 If STRING contains a non-ASCII, non-`eight-bit' character,
1139 an error is signaled. */)
1143 CHECK_STRING (string
);
1145 if (STRING_MULTIBYTE (string
))
1147 EMACS_INT chars
= SCHARS (string
);
1148 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1149 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1151 if (converted
< chars
)
1152 error ("Can't convert the %dth character to unibyte", converted
);
1153 string
= make_unibyte_string (str
, chars
);
1160 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1161 doc
: /* Return a copy of ALIST.
1162 This is an alist which represents the same mapping from objects to objects,
1163 but does not share the alist structure with ALIST.
1164 The objects mapped (cars and cdrs of elements of the alist)
1165 are shared, however.
1166 Elements of ALIST that are not conses are also shared. */)
1170 register Lisp_Object tem
;
1175 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1176 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1178 register Lisp_Object car
;
1182 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1187 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1188 doc
: /* Return a new string whose contents are a substring of STRING.
1189 The returned string consists of the characters between index FROM
1190 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1191 zero-indexed: 0 means the first character of STRING. Negative values
1192 are counted from the end of STRING. If TO is nil, the substring runs
1193 to the end of STRING.
1195 The STRING argument may also be a vector. In that case, the return
1196 value is a new vector that contains the elements between index FROM
1197 \(inclusive) and index TO (exclusive) of that vector argument. */)
1200 register Lisp_Object from
, to
;
1205 int from_char
, to_char
;
1206 int from_byte
= 0, to_byte
= 0;
1208 CHECK_VECTOR_OR_STRING (string
);
1209 CHECK_NUMBER (from
);
1211 if (STRINGP (string
))
1213 size
= SCHARS (string
);
1214 size_byte
= SBYTES (string
);
1217 size
= ASIZE (string
);
1222 to_byte
= size_byte
;
1228 to_char
= XINT (to
);
1232 if (STRINGP (string
))
1233 to_byte
= string_char_to_byte (string
, to_char
);
1236 from_char
= XINT (from
);
1239 if (STRINGP (string
))
1240 from_byte
= string_char_to_byte (string
, from_char
);
1242 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1243 args_out_of_range_3 (string
, make_number (from_char
),
1244 make_number (to_char
));
1246 if (STRINGP (string
))
1248 res
= make_specified_string (SDATA (string
) + from_byte
,
1249 to_char
- from_char
, to_byte
- from_byte
,
1250 STRING_MULTIBYTE (string
));
1251 copy_text_properties (make_number (from_char
), make_number (to_char
),
1252 string
, make_number (0), res
, Qnil
);
1255 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1261 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1262 doc
: /* Return a substring of STRING, without text properties.
1263 It starts at index FROM and ending before TO.
1264 TO may be nil or omitted; then the substring runs to the end of STRING.
1265 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1266 If FROM or TO is negative, it counts from the end.
1268 With one argument, just copy STRING without its properties. */)
1271 register Lisp_Object from
, to
;
1273 int size
, size_byte
;
1274 int from_char
, to_char
;
1275 int from_byte
, to_byte
;
1277 CHECK_STRING (string
);
1279 size
= SCHARS (string
);
1280 size_byte
= SBYTES (string
);
1283 from_char
= from_byte
= 0;
1286 CHECK_NUMBER (from
);
1287 from_char
= XINT (from
);
1291 from_byte
= string_char_to_byte (string
, from_char
);
1297 to_byte
= size_byte
;
1303 to_char
= XINT (to
);
1307 to_byte
= string_char_to_byte (string
, to_char
);
1310 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1311 args_out_of_range_3 (string
, make_number (from_char
),
1312 make_number (to_char
));
1314 return make_specified_string (SDATA (string
) + from_byte
,
1315 to_char
- from_char
, to_byte
- from_byte
,
1316 STRING_MULTIBYTE (string
));
1319 /* Extract a substring of STRING, giving start and end positions
1320 both in characters and in bytes. */
1323 substring_both (string
, from
, from_byte
, to
, to_byte
)
1325 int from
, from_byte
, to
, to_byte
;
1331 CHECK_VECTOR_OR_STRING (string
);
1333 if (STRINGP (string
))
1335 size
= SCHARS (string
);
1336 size_byte
= SBYTES (string
);
1339 size
= ASIZE (string
);
1341 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1342 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1344 if (STRINGP (string
))
1346 res
= make_specified_string (SDATA (string
) + from_byte
,
1347 to
- from
, to_byte
- from_byte
,
1348 STRING_MULTIBYTE (string
));
1349 copy_text_properties (make_number (from
), make_number (to
),
1350 string
, make_number (0), res
, Qnil
);
1353 res
= Fvector (to
- from
, &AREF (string
, from
));
1358 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1359 doc
: /* Take cdr N times on LIST, returns the result. */)
1362 register Lisp_Object list
;
1364 register int i
, num
;
1367 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1370 CHECK_LIST_CONS (list
, list
);
1376 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1377 doc
: /* Return the Nth element of LIST.
1378 N counts from zero. If LIST is not that long, nil is returned. */)
1380 Lisp_Object n
, list
;
1382 return Fcar (Fnthcdr (n
, list
));
1385 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1386 doc
: /* Return element of SEQUENCE at index N. */)
1388 register Lisp_Object sequence
, n
;
1391 if (CONSP (sequence
) || NILP (sequence
))
1392 return Fcar (Fnthcdr (n
, sequence
));
1394 /* Faref signals a "not array" error, so check here. */
1395 CHECK_ARRAY (sequence
, Qsequencep
);
1396 return Faref (sequence
, n
);
1399 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1400 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1401 The value is actually the tail of LIST whose car is ELT. */)
1403 register Lisp_Object elt
;
1406 register Lisp_Object tail
;
1407 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1409 register Lisp_Object tem
;
1410 CHECK_LIST_CONS (tail
, list
);
1412 if (! NILP (Fequal (elt
, tem
)))
1419 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1420 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1421 The value is actually the tail of LIST whose car is ELT. */)
1423 register Lisp_Object elt
, list
;
1427 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1431 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1435 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1446 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1447 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1448 The value is actually the tail of LIST whose car is ELT. */)
1450 register Lisp_Object elt
;
1453 register Lisp_Object tail
;
1456 return Fmemq (elt
, list
);
1458 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1460 register Lisp_Object tem
;
1461 CHECK_LIST_CONS (tail
, list
);
1463 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1470 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1471 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1472 The value is actually the first element of LIST whose car is KEY.
1473 Elements of LIST that are not conses are ignored. */)
1475 Lisp_Object key
, list
;
1480 || (CONSP (XCAR (list
))
1481 && EQ (XCAR (XCAR (list
)), key
)))
1486 || (CONSP (XCAR (list
))
1487 && EQ (XCAR (XCAR (list
)), key
)))
1492 || (CONSP (XCAR (list
))
1493 && EQ (XCAR (XCAR (list
)), key
)))
1503 /* Like Fassq but never report an error and do not allow quits.
1504 Use only on lists known never to be circular. */
1507 assq_no_quit (key
, list
)
1508 Lisp_Object key
, list
;
1511 && (!CONSP (XCAR (list
))
1512 || !EQ (XCAR (XCAR (list
)), key
)))
1515 return CAR_SAFE (list
);
1518 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1519 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1520 The value is actually the first element of LIST whose car equals KEY. */)
1522 Lisp_Object key
, list
;
1529 || (CONSP (XCAR (list
))
1530 && (car
= XCAR (XCAR (list
)),
1531 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1536 || (CONSP (XCAR (list
))
1537 && (car
= XCAR (XCAR (list
)),
1538 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1543 || (CONSP (XCAR (list
))
1544 && (car
= XCAR (XCAR (list
)),
1545 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1555 /* Like Fassoc but never report an error and do not allow quits.
1556 Use only on lists known never to be circular. */
1559 assoc_no_quit (key
, list
)
1560 Lisp_Object key
, list
;
1563 && (!CONSP (XCAR (list
))
1564 || (!EQ (XCAR (XCAR (list
)), key
)
1565 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1568 return CONSP (list
) ? XCAR (list
) : Qnil
;
1571 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1572 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1573 The value is actually the first element of LIST whose cdr is KEY. */)
1575 register Lisp_Object key
;
1581 || (CONSP (XCAR (list
))
1582 && EQ (XCDR (XCAR (list
)), key
)))
1587 || (CONSP (XCAR (list
))
1588 && EQ (XCDR (XCAR (list
)), key
)))
1593 || (CONSP (XCAR (list
))
1594 && EQ (XCDR (XCAR (list
)), key
)))
1604 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1605 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1606 The value is actually the first element of LIST whose cdr equals KEY. */)
1608 Lisp_Object key
, list
;
1615 || (CONSP (XCAR (list
))
1616 && (cdr
= XCDR (XCAR (list
)),
1617 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1622 || (CONSP (XCAR (list
))
1623 && (cdr
= XCDR (XCAR (list
)),
1624 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1629 || (CONSP (XCAR (list
))
1630 && (cdr
= XCDR (XCAR (list
)),
1631 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1641 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1642 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1643 The modified LIST is returned. Comparison is done with `eq'.
1644 If the first member of LIST is ELT, there is no way to remove it by side effect;
1645 therefore, write `(setq foo (delq element foo))'
1646 to be sure of changing the value of `foo'. */)
1648 register Lisp_Object elt
;
1651 register Lisp_Object tail
, prev
;
1652 register Lisp_Object tem
;
1656 while (!NILP (tail
))
1658 CHECK_LIST_CONS (tail
, list
);
1665 Fsetcdr (prev
, XCDR (tail
));
1675 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1676 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1677 SEQ must be a list, a vector, or a string.
1678 The modified SEQ is returned. Comparison is done with `equal'.
1679 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1680 is not a side effect; it is simply using a different sequence.
1681 Therefore, write `(setq foo (delete element foo))'
1682 to be sure of changing the value of `foo'. */)
1684 Lisp_Object elt
, seq
;
1690 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1691 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1694 if (n
!= ASIZE (seq
))
1696 struct Lisp_Vector
*p
= allocate_vector (n
);
1698 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1699 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1700 p
->contents
[n
++] = AREF (seq
, i
);
1702 XSETVECTOR (seq
, p
);
1705 else if (STRINGP (seq
))
1707 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1710 for (i
= nchars
= nbytes
= ibyte
= 0;
1712 ++i
, ibyte
+= cbytes
)
1714 if (STRING_MULTIBYTE (seq
))
1716 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1717 SBYTES (seq
) - ibyte
);
1718 cbytes
= CHAR_BYTES (c
);
1726 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1733 if (nchars
!= SCHARS (seq
))
1737 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1738 if (!STRING_MULTIBYTE (seq
))
1739 STRING_SET_UNIBYTE (tem
);
1741 for (i
= nchars
= nbytes
= ibyte
= 0;
1743 ++i
, ibyte
+= cbytes
)
1745 if (STRING_MULTIBYTE (seq
))
1747 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1748 SBYTES (seq
) - ibyte
);
1749 cbytes
= CHAR_BYTES (c
);
1757 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1759 unsigned char *from
= SDATA (seq
) + ibyte
;
1760 unsigned char *to
= SDATA (tem
) + nbytes
;
1766 for (n
= cbytes
; n
--; )
1776 Lisp_Object tail
, prev
;
1778 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1780 CHECK_LIST_CONS (tail
, seq
);
1782 if (!NILP (Fequal (elt
, XCAR (tail
))))
1787 Fsetcdr (prev
, XCDR (tail
));
1798 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1799 doc
: /* Reverse LIST by modifying cdr pointers.
1800 Return the reversed list. */)
1804 register Lisp_Object prev
, tail
, next
;
1806 if (NILP (list
)) return list
;
1809 while (!NILP (tail
))
1812 CHECK_LIST_CONS (tail
, list
);
1814 Fsetcdr (tail
, prev
);
1821 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1822 doc
: /* Reverse LIST, copying. Return the reversed list.
1823 See also the function `nreverse', which is used more often. */)
1829 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1832 new = Fcons (XCAR (list
), new);
1834 CHECK_LIST_END (list
, list
);
1838 Lisp_Object
merge ();
1840 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1841 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1842 Returns the sorted list. LIST is modified by side effects.
1843 PREDICATE is called with two elements of LIST, and should return non-nil
1844 if the first element should sort before the second. */)
1846 Lisp_Object list
, predicate
;
1848 Lisp_Object front
, back
;
1849 register Lisp_Object len
, tem
;
1850 struct gcpro gcpro1
, gcpro2
;
1851 register int length
;
1854 len
= Flength (list
);
1855 length
= XINT (len
);
1859 XSETINT (len
, (length
/ 2) - 1);
1860 tem
= Fnthcdr (len
, list
);
1862 Fsetcdr (tem
, Qnil
);
1864 GCPRO2 (front
, back
);
1865 front
= Fsort (front
, predicate
);
1866 back
= Fsort (back
, predicate
);
1868 return merge (front
, back
, predicate
);
1872 merge (org_l1
, org_l2
, pred
)
1873 Lisp_Object org_l1
, org_l2
;
1877 register Lisp_Object tail
;
1879 register Lisp_Object l1
, l2
;
1880 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1887 /* It is sufficient to protect org_l1 and org_l2.
1888 When l1 and l2 are updated, we copy the new values
1889 back into the org_ vars. */
1890 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1910 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1926 Fsetcdr (tail
, tem
);
1932 #if 0 /* Unsafe version. */
1933 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1934 doc
: /* Extract a value from a property list.
1935 PLIST is a property list, which is a list of the form
1936 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1937 corresponding to the given PROP, or nil if PROP is not
1938 one of the properties on the list. */)
1946 CONSP (tail
) && CONSP (XCDR (tail
));
1947 tail
= XCDR (XCDR (tail
)))
1949 if (EQ (prop
, XCAR (tail
)))
1950 return XCAR (XCDR (tail
));
1952 /* This function can be called asynchronously
1953 (setup_coding_system). Don't QUIT in that case. */
1954 if (!interrupt_input_blocked
)
1958 CHECK_LIST_END (tail
, prop
);
1964 /* This does not check for quits. That is safe since it must terminate. */
1966 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1967 doc
: /* Extract a value from a property list.
1968 PLIST is a property list, which is a list of the form
1969 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1970 corresponding to the given PROP, or nil if PROP is not one of the
1971 properties on the list. This function never signals an error. */)
1976 Lisp_Object tail
, halftail
;
1978 /* halftail is used to detect circular lists. */
1979 tail
= halftail
= plist
;
1980 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1982 if (EQ (prop
, XCAR (tail
)))
1983 return XCAR (XCDR (tail
));
1985 tail
= XCDR (XCDR (tail
));
1986 halftail
= XCDR (halftail
);
1987 if (EQ (tail
, halftail
))
1994 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1995 doc
: /* Return the value of SYMBOL's PROPNAME property.
1996 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1998 Lisp_Object symbol
, propname
;
2000 CHECK_SYMBOL (symbol
);
2001 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2004 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2005 doc
: /* Change value in PLIST of PROP to VAL.
2006 PLIST is a property list, which is a list of the form
2007 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2008 If PROP is already a property on the list, its value is set to VAL,
2009 otherwise the new PROP VAL pair is added. The new plist is returned;
2010 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2011 The PLIST is modified by side effects. */)
2014 register Lisp_Object prop
;
2017 register Lisp_Object tail
, prev
;
2018 Lisp_Object newcell
;
2020 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2021 tail
= XCDR (XCDR (tail
)))
2023 if (EQ (prop
, XCAR (tail
)))
2025 Fsetcar (XCDR (tail
), val
);
2032 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2036 Fsetcdr (XCDR (prev
), newcell
);
2040 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2041 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2042 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2043 (symbol
, propname
, value
)
2044 Lisp_Object symbol
, propname
, value
;
2046 CHECK_SYMBOL (symbol
);
2047 XSYMBOL (symbol
)->plist
2048 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2052 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2053 doc
: /* Extract a value from a property list, comparing with `equal'.
2054 PLIST is a property list, which is a list of the form
2055 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2056 corresponding to the given PROP, or nil if PROP is not
2057 one of the properties on the list. */)
2065 CONSP (tail
) && CONSP (XCDR (tail
));
2066 tail
= XCDR (XCDR (tail
)))
2068 if (! NILP (Fequal (prop
, XCAR (tail
))))
2069 return XCAR (XCDR (tail
));
2074 CHECK_LIST_END (tail
, prop
);
2079 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2080 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2081 PLIST is a property list, which is a list of the form
2082 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2083 If PROP is already a property on the list, its value is set to VAL,
2084 otherwise the new PROP VAL pair is added. The new plist is returned;
2085 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2086 The PLIST is modified by side effects. */)
2089 register Lisp_Object prop
;
2092 register Lisp_Object tail
, prev
;
2093 Lisp_Object newcell
;
2095 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2096 tail
= XCDR (XCDR (tail
)))
2098 if (! NILP (Fequal (prop
, XCAR (tail
))))
2100 Fsetcar (XCDR (tail
), val
);
2107 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2111 Fsetcdr (XCDR (prev
), newcell
);
2115 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2116 doc
: /* Return t if the two args are the same Lisp object.
2117 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2119 Lisp_Object obj1
, obj2
;
2122 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2124 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2127 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2128 doc
: /* Return t if two Lisp objects have similar structure and contents.
2129 They must have the same data type.
2130 Conses are compared by comparing the cars and the cdrs.
2131 Vectors and strings are compared element by element.
2132 Numbers are compared by value, but integers cannot equal floats.
2133 (Use `=' if you want integers and floats to be able to be equal.)
2134 Symbols must match exactly. */)
2136 register Lisp_Object o1
, o2
;
2138 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2141 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2142 doc
: /* Return t if two Lisp objects have similar structure and contents.
2143 This is like `equal' except that it compares the text properties
2144 of strings. (`equal' ignores text properties.) */)
2146 register Lisp_Object o1
, o2
;
2148 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2151 /* DEPTH is current depth of recursion. Signal an error if it
2153 PROPS, if non-nil, means compare string text properties too. */
2156 internal_equal (o1
, o2
, depth
, props
)
2157 register Lisp_Object o1
, o2
;
2161 error ("Stack overflow in equal");
2167 if (XTYPE (o1
) != XTYPE (o2
))
2176 d1
= extract_float (o1
);
2177 d2
= extract_float (o2
);
2178 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2179 though they are not =. */
2180 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2184 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2191 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2195 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2197 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2200 o1
= XOVERLAY (o1
)->plist
;
2201 o2
= XOVERLAY (o2
)->plist
;
2206 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2207 && (XMARKER (o1
)->buffer
== 0
2208 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2212 case Lisp_Vectorlike
:
2215 EMACS_INT size
= ASIZE (o1
);
2216 /* Pseudovectors have the type encoded in the size field, so this test
2217 actually checks that the objects have the same type as well as the
2219 if (ASIZE (o2
) != size
)
2221 /* Boolvectors are compared much like strings. */
2222 if (BOOL_VECTOR_P (o1
))
2225 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2226 / BOOL_VECTOR_BITS_PER_CHAR
);
2228 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2230 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2235 if (WINDOW_CONFIGURATIONP (o1
))
2236 return compare_window_configurations (o1
, o2
, 0);
2238 /* Aside from them, only true vectors, char-tables, compiled
2239 functions, and fonts (font-spec, font-entity, font-ojbect)
2240 are sensible to compare, so eliminate the others now. */
2241 if (size
& PSEUDOVECTOR_FLAG
)
2243 if (!(size
& (PVEC_COMPILED
2244 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2246 size
&= PSEUDOVECTOR_SIZE_MASK
;
2248 for (i
= 0; i
< size
; i
++)
2253 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2261 if (SCHARS (o1
) != SCHARS (o2
))
2263 if (SBYTES (o1
) != SBYTES (o2
))
2265 if (bcmp (SDATA (o1
), SDATA (o2
),
2268 if (props
&& !compare_string_intervals (o1
, o2
))
2274 case Lisp_Type_Limit
:
2281 extern Lisp_Object
Fmake_char_internal ();
2283 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2284 doc
: /* Store each element of ARRAY with ITEM.
2285 ARRAY is a vector, string, char-table, or bool-vector. */)
2287 Lisp_Object array
, item
;
2289 register int size
, index
, charval
;
2290 if (VECTORP (array
))
2292 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2293 size
= ASIZE (array
);
2294 for (index
= 0; index
< size
; index
++)
2297 else if (CHAR_TABLE_P (array
))
2301 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2302 XCHAR_TABLE (array
)->contents
[i
] = item
;
2303 XCHAR_TABLE (array
)->defalt
= item
;
2305 else if (STRINGP (array
))
2307 register unsigned char *p
= SDATA (array
);
2308 CHECK_NUMBER (item
);
2309 charval
= XINT (item
);
2310 size
= SCHARS (array
);
2311 if (STRING_MULTIBYTE (array
))
2313 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2314 int len
= CHAR_STRING (charval
, str
);
2315 int size_byte
= SBYTES (array
);
2316 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2319 if (size
!= size_byte
)
2322 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2323 if (len
!= this_len
)
2324 error ("Attempt to change byte length of a string");
2327 for (i
= 0; i
< size_byte
; i
++)
2328 *p
++ = str
[i
% len
];
2331 for (index
= 0; index
< size
; index
++)
2334 else if (BOOL_VECTOR_P (array
))
2336 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2338 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2339 / BOOL_VECTOR_BITS_PER_CHAR
);
2341 charval
= (! NILP (item
) ? -1 : 0);
2342 for (index
= 0; index
< size_in_chars
- 1; index
++)
2344 if (index
< size_in_chars
)
2346 /* Mask out bits beyond the vector size. */
2347 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2348 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2353 wrong_type_argument (Qarrayp
, array
);
2357 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2359 doc
: /* Clear the contents of STRING.
2360 This makes STRING unibyte and may change its length. */)
2365 CHECK_STRING (string
);
2366 len
= SBYTES (string
);
2367 bzero (SDATA (string
), len
);
2368 STRING_SET_CHARS (string
, len
);
2369 STRING_SET_UNIBYTE (string
);
2379 Lisp_Object args
[2];
2382 return Fnconc (2, args
);
2384 return Fnconc (2, &s1
);
2385 #endif /* NO_ARG_ARRAY */
2388 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2389 doc
: /* Concatenate any number of lists by altering them.
2390 Only the last argument is not altered, and need not be a list.
2391 usage: (nconc &rest LISTS) */)
2396 register int argnum
;
2397 register Lisp_Object tail
, tem
, val
;
2401 for (argnum
= 0; argnum
< nargs
; argnum
++)
2404 if (NILP (tem
)) continue;
2409 if (argnum
+ 1 == nargs
) break;
2411 CHECK_LIST_CONS (tem
, tem
);
2420 tem
= args
[argnum
+ 1];
2421 Fsetcdr (tail
, tem
);
2423 args
[argnum
+ 1] = tail
;
2429 /* This is the guts of all mapping functions.
2430 Apply FN to each element of SEQ, one by one,
2431 storing the results into elements of VALS, a C vector of Lisp_Objects.
2432 LENI is the length of VALS, which should also be the length of SEQ. */
2435 mapcar1 (leni
, vals
, fn
, seq
)
2438 Lisp_Object fn
, seq
;
2440 register Lisp_Object tail
;
2443 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2447 /* Don't let vals contain any garbage when GC happens. */
2448 for (i
= 0; i
< leni
; i
++)
2451 GCPRO3 (dummy
, fn
, seq
);
2453 gcpro1
.nvars
= leni
;
2457 /* We need not explicitly protect `tail' because it is used only on lists, and
2458 1) lists are not relocated and 2) the list is marked via `seq' so will not
2463 for (i
= 0; i
< leni
; i
++)
2465 dummy
= call1 (fn
, AREF (seq
, i
));
2470 else if (BOOL_VECTOR_P (seq
))
2472 for (i
= 0; i
< leni
; i
++)
2475 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2476 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2477 dummy
= call1 (fn
, dummy
);
2482 else if (STRINGP (seq
))
2486 for (i
= 0, i_byte
= 0; i
< leni
;)
2491 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2492 XSETFASTINT (dummy
, c
);
2493 dummy
= call1 (fn
, dummy
);
2495 vals
[i_before
] = dummy
;
2498 else /* Must be a list, since Flength did not get an error */
2501 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2503 dummy
= call1 (fn
, XCAR (tail
));
2513 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2514 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2515 In between each pair of results, stick in SEPARATOR. Thus, " " as
2516 SEPARATOR results in spaces between the values returned by FUNCTION.
2517 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2518 (function
, sequence
, separator
)
2519 Lisp_Object function
, sequence
, separator
;
2524 register Lisp_Object
*args
;
2526 struct gcpro gcpro1
;
2530 len
= Flength (sequence
);
2531 if (CHAR_TABLE_P (sequence
))
2532 wrong_type_argument (Qlistp
, sequence
);
2534 nargs
= leni
+ leni
- 1;
2535 if (nargs
< 0) return empty_unibyte_string
;
2537 SAFE_ALLOCA_LISP (args
, nargs
);
2540 mapcar1 (leni
, args
, function
, sequence
);
2543 for (i
= leni
- 1; i
> 0; i
--)
2544 args
[i
+ i
] = args
[i
];
2546 for (i
= 1; i
< nargs
; i
+= 2)
2547 args
[i
] = separator
;
2549 ret
= Fconcat (nargs
, args
);
2555 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2556 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2557 The result is a list just as long as SEQUENCE.
2558 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2559 (function
, sequence
)
2560 Lisp_Object function
, sequence
;
2562 register Lisp_Object len
;
2564 register Lisp_Object
*args
;
2568 len
= Flength (sequence
);
2569 if (CHAR_TABLE_P (sequence
))
2570 wrong_type_argument (Qlistp
, sequence
);
2571 leni
= XFASTINT (len
);
2573 SAFE_ALLOCA_LISP (args
, leni
);
2575 mapcar1 (leni
, args
, function
, sequence
);
2577 ret
= Flist (leni
, args
);
2583 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2584 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2585 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2586 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2587 (function
, sequence
)
2588 Lisp_Object function
, sequence
;
2592 leni
= XFASTINT (Flength (sequence
));
2593 if (CHAR_TABLE_P (sequence
))
2594 wrong_type_argument (Qlistp
, sequence
);
2595 mapcar1 (leni
, 0, function
, sequence
);
2600 /* Anything that calls this function must protect from GC! */
2602 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2603 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2604 Takes one argument, which is the string to display to ask the question.
2605 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2606 No confirmation of the answer is requested; a single character is enough.
2607 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2608 the bindings in `query-replace-map'; see the documentation of that variable
2609 for more information. In this case, the useful bindings are `act', `skip',
2610 `recenter', and `quit'.\)
2612 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2613 is nil and `use-dialog-box' is non-nil. */)
2617 register Lisp_Object obj
, key
, def
, map
;
2618 register int answer
;
2619 Lisp_Object xprompt
;
2620 Lisp_Object args
[2];
2621 struct gcpro gcpro1
, gcpro2
;
2622 int count
= SPECPDL_INDEX ();
2624 specbind (Qcursor_in_echo_area
, Qt
);
2626 map
= Fsymbol_value (intern ("query-replace-map"));
2628 CHECK_STRING (prompt
);
2630 GCPRO2 (prompt
, xprompt
);
2632 #ifdef HAVE_WINDOW_SYSTEM
2633 if (display_hourglass_p
)
2634 cancel_hourglass ();
2641 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2642 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2646 Lisp_Object pane
, menu
;
2647 redisplay_preserve_echo_area (3);
2648 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2649 Fcons (Fcons (build_string ("No"), Qnil
),
2651 menu
= Fcons (prompt
, pane
);
2652 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2653 answer
= !NILP (obj
);
2656 #endif /* HAVE_MENUS */
2657 cursor_in_echo_area
= 1;
2658 choose_minibuf_frame ();
2661 Lisp_Object pargs
[3];
2663 /* Colorize prompt according to `minibuffer-prompt' face. */
2664 pargs
[0] = build_string ("%s(y or n) ");
2665 pargs
[1] = intern ("face");
2666 pargs
[2] = intern ("minibuffer-prompt");
2667 args
[0] = Fpropertize (3, pargs
);
2672 if (minibuffer_auto_raise
)
2674 Lisp_Object mini_frame
;
2676 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2678 Fraise_frame (mini_frame
);
2681 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2682 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2683 cursor_in_echo_area
= 0;
2684 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2687 key
= Fmake_vector (make_number (1), obj
);
2688 def
= Flookup_key (map
, key
, Qt
);
2690 if (EQ (def
, intern ("skip")))
2695 else if (EQ (def
, intern ("act")))
2700 else if (EQ (def
, intern ("recenter")))
2706 else if (EQ (def
, intern ("quit")))
2708 /* We want to exit this command for exit-prefix,
2709 and this is the only way to do it. */
2710 else if (EQ (def
, intern ("exit-prefix")))
2715 /* If we don't clear this, then the next call to read_char will
2716 return quit_char again, and we'll enter an infinite loop. */
2721 if (EQ (xprompt
, prompt
))
2723 args
[0] = build_string ("Please answer y or n. ");
2725 xprompt
= Fconcat (2, args
);
2730 if (! noninteractive
)
2732 cursor_in_echo_area
= -1;
2733 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2737 unbind_to (count
, Qnil
);
2738 return answer
? Qt
: Qnil
;
2741 /* This is how C code calls `yes-or-no-p' and allows the user
2744 Anything that calls this function must protect from GC! */
2747 do_yes_or_no_p (prompt
)
2750 return call1 (intern ("yes-or-no-p"), prompt
);
2753 /* Anything that calls this function must protect from GC! */
2755 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2756 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2757 Takes one argument, which is the string to display to ask the question.
2758 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2759 The user must confirm the answer with RET,
2760 and can edit it until it has been confirmed.
2762 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2763 is nil, and `use-dialog-box' is non-nil. */)
2767 register Lisp_Object ans
;
2768 Lisp_Object args
[2];
2769 struct gcpro gcpro1
;
2771 CHECK_STRING (prompt
);
2774 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2775 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2779 Lisp_Object pane
, menu
, obj
;
2780 redisplay_preserve_echo_area (4);
2781 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2782 Fcons (Fcons (build_string ("No"), Qnil
),
2785 menu
= Fcons (prompt
, pane
);
2786 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2790 #endif /* HAVE_MENUS */
2793 args
[1] = build_string ("(yes or no) ");
2794 prompt
= Fconcat (2, args
);
2800 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2801 Qyes_or_no_p_history
, Qnil
,
2803 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2808 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2816 message ("Please answer yes or no.");
2817 Fsleep_for (make_number (2), Qnil
);
2821 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2822 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2824 Each of the three load averages is multiplied by 100, then converted
2827 When USE-FLOATS is non-nil, floats will be used instead of integers.
2828 These floats are not multiplied by 100.
2830 If the 5-minute or 15-minute load averages are not available, return a
2831 shortened list, containing only those averages which are available.
2833 An error is thrown if the load average can't be obtained. In some
2834 cases making it work would require Emacs being installed setuid or
2835 setgid so that it can read kernel information, and that usually isn't
2838 Lisp_Object use_floats
;
2841 int loads
= getloadavg (load_ave
, 3);
2842 Lisp_Object ret
= Qnil
;
2845 error ("load-average not implemented for this operating system");
2849 Lisp_Object load
= (NILP (use_floats
) ?
2850 make_number ((int) (100.0 * load_ave
[loads
]))
2851 : make_float (load_ave
[loads
]));
2852 ret
= Fcons (load
, ret
);
2858 Lisp_Object Vfeatures
, Qsubfeatures
;
2859 extern Lisp_Object Vafter_load_alist
;
2861 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2862 doc
: /* Returns t if FEATURE is present in this Emacs.
2864 Use this to conditionalize execution of lisp code based on the
2865 presence or absence of Emacs or environment extensions.
2866 Use `provide' to declare that a feature is available. This function
2867 looks at the value of the variable `features'. The optional argument
2868 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2869 (feature
, subfeature
)
2870 Lisp_Object feature
, subfeature
;
2872 register Lisp_Object tem
;
2873 CHECK_SYMBOL (feature
);
2874 tem
= Fmemq (feature
, Vfeatures
);
2875 if (!NILP (tem
) && !NILP (subfeature
))
2876 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2877 return (NILP (tem
)) ? Qnil
: Qt
;
2880 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2881 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2882 The optional argument SUBFEATURES should be a list of symbols listing
2883 particular subfeatures supported in this version of FEATURE. */)
2884 (feature
, subfeatures
)
2885 Lisp_Object feature
, subfeatures
;
2887 register Lisp_Object tem
;
2888 CHECK_SYMBOL (feature
);
2889 CHECK_LIST (subfeatures
);
2890 if (!NILP (Vautoload_queue
))
2891 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2893 tem
= Fmemq (feature
, Vfeatures
);
2895 Vfeatures
= Fcons (feature
, Vfeatures
);
2896 if (!NILP (subfeatures
))
2897 Fput (feature
, Qsubfeatures
, subfeatures
);
2898 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2900 /* Run any load-hooks for this file. */
2901 tem
= Fassq (feature
, Vafter_load_alist
);
2903 Fprogn (XCDR (tem
));
2908 /* `require' and its subroutines. */
2910 /* List of features currently being require'd, innermost first. */
2912 Lisp_Object require_nesting_list
;
2915 require_unwind (old_value
)
2916 Lisp_Object old_value
;
2918 return require_nesting_list
= old_value
;
2921 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2922 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2923 If FEATURE is not a member of the list `features', then the feature
2924 is not loaded; so load the file FILENAME.
2925 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2926 and `load' will try to load this name appended with the suffix `.elc' or
2927 `.el', in that order. The name without appended suffix will not be used.
2928 If the optional third argument NOERROR is non-nil,
2929 then return nil if the file is not found instead of signaling an error.
2930 Normally the return value is FEATURE.
2931 The normal messages at start and end of loading FILENAME are suppressed. */)
2932 (feature
, filename
, noerror
)
2933 Lisp_Object feature
, filename
, noerror
;
2935 register Lisp_Object tem
;
2936 struct gcpro gcpro1
, gcpro2
;
2937 int from_file
= load_in_progress
;
2939 CHECK_SYMBOL (feature
);
2941 /* Record the presence of `require' in this file
2942 even if the feature specified is already loaded.
2943 But not more than once in any file,
2944 and not when we aren't loading or reading from a file. */
2946 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2947 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2952 tem
= Fcons (Qrequire
, feature
);
2953 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2954 LOADHIST_ATTACH (tem
);
2956 tem
= Fmemq (feature
, Vfeatures
);
2960 int count
= SPECPDL_INDEX ();
2963 /* This is to make sure that loadup.el gives a clear picture
2964 of what files are preloaded and when. */
2965 if (! NILP (Vpurify_flag
))
2966 error ("(require %s) while preparing to dump",
2967 SDATA (SYMBOL_NAME (feature
)));
2969 /* A certain amount of recursive `require' is legitimate,
2970 but if we require the same feature recursively 3 times,
2972 tem
= require_nesting_list
;
2973 while (! NILP (tem
))
2975 if (! NILP (Fequal (feature
, XCAR (tem
))))
2980 error ("Recursive `require' for feature `%s'",
2981 SDATA (SYMBOL_NAME (feature
)));
2983 /* Update the list for any nested `require's that occur. */
2984 record_unwind_protect (require_unwind
, require_nesting_list
);
2985 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2987 /* Value saved here is to be restored into Vautoload_queue */
2988 record_unwind_protect (un_autoload
, Vautoload_queue
);
2989 Vautoload_queue
= Qt
;
2991 /* Load the file. */
2992 GCPRO2 (feature
, filename
);
2993 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2994 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2997 /* If load failed entirely, return nil. */
2999 return unbind_to (count
, Qnil
);
3001 tem
= Fmemq (feature
, Vfeatures
);
3003 error ("Required feature `%s' was not provided",
3004 SDATA (SYMBOL_NAME (feature
)));
3006 /* Once loading finishes, don't undo it. */
3007 Vautoload_queue
= Qt
;
3008 feature
= unbind_to (count
, feature
);
3014 /* Primitives for work of the "widget" library.
3015 In an ideal world, this section would not have been necessary.
3016 However, lisp function calls being as slow as they are, it turns
3017 out that some functions in the widget library (wid-edit.el) are the
3018 bottleneck of Widget operation. Here is their translation to C,
3019 for the sole reason of efficiency. */
3021 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3022 doc
: /* Return non-nil if PLIST has the property PROP.
3023 PLIST is a property list, which is a list of the form
3024 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3025 Unlike `plist-get', this allows you to distinguish between a missing
3026 property and a property with the value nil.
3027 The value is actually the tail of PLIST whose car is PROP. */)
3029 Lisp_Object plist
, prop
;
3031 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3034 plist
= XCDR (plist
);
3035 plist
= CDR (plist
);
3040 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3041 doc
: /* In WIDGET, set PROPERTY to VALUE.
3042 The value can later be retrieved with `widget-get'. */)
3043 (widget
, property
, value
)
3044 Lisp_Object widget
, property
, value
;
3046 CHECK_CONS (widget
);
3047 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3051 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3052 doc
: /* In WIDGET, get the value of PROPERTY.
3053 The value could either be specified when the widget was created, or
3054 later with `widget-put'. */)
3056 Lisp_Object widget
, property
;
3064 CHECK_CONS (widget
);
3065 tmp
= Fplist_member (XCDR (widget
), property
);
3071 tmp
= XCAR (widget
);
3074 widget
= Fget (tmp
, Qwidget_type
);
3078 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3079 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3080 ARGS are passed as extra arguments to the function.
3081 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3086 /* This function can GC. */
3087 Lisp_Object newargs
[3];
3088 struct gcpro gcpro1
, gcpro2
;
3091 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3092 newargs
[1] = args
[0];
3093 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3094 GCPRO2 (newargs
[0], newargs
[2]);
3095 result
= Fapply (3, newargs
);
3100 #ifdef HAVE_LANGINFO_CODESET
3101 #include <langinfo.h>
3104 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3105 doc
: /* Access locale data ITEM for the current C locale, if available.
3106 ITEM should be one of the following:
3108 `codeset', returning the character set as a string (locale item CODESET);
3110 `days', returning a 7-element vector of day names (locale items DAY_n);
3112 `months', returning a 12-element vector of month names (locale items MON_n);
3114 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3115 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3117 If the system can't provide such information through a call to
3118 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3120 See also Info node `(libc)Locales'.
3122 The data read from the system are decoded using `locale-coding-system'. */)
3127 #ifdef HAVE_LANGINFO_CODESET
3129 if (EQ (item
, Qcodeset
))
3131 str
= nl_langinfo (CODESET
);
3132 return build_string (str
);
3135 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3137 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3138 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3140 struct gcpro gcpro1
;
3142 synchronize_system_time_locale ();
3143 for (i
= 0; i
< 7; i
++)
3145 str
= nl_langinfo (days
[i
]);
3146 val
= make_unibyte_string (str
, strlen (str
));
3147 /* Fixme: Is this coding system necessarily right, even if
3148 it is consistent with CODESET? If not, what to do? */
3149 Faset (v
, make_number (i
),
3150 code_convert_string_norecord (val
, Vlocale_coding_system
,
3158 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3160 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3161 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3162 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3164 struct gcpro gcpro1
;
3166 synchronize_system_time_locale ();
3167 for (i
= 0; i
< 12; i
++)
3169 str
= nl_langinfo (months
[i
]);
3170 val
= make_unibyte_string (str
, strlen (str
));
3171 Faset (v
, make_number (i
),
3172 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3178 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3179 but is in the locale files. This could be used by ps-print. */
3181 else if (EQ (item
, Qpaper
))
3183 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3184 make_number (nl_langinfo (PAPER_HEIGHT
)));
3186 #endif /* PAPER_WIDTH */
3187 #endif /* HAVE_LANGINFO_CODESET*/
3191 /* base64 encode/decode functions (RFC 2045).
3192 Based on code from GNU recode. */
3194 #define MIME_LINE_LENGTH 76
3196 #define IS_ASCII(Character) \
3198 #define IS_BASE64(Character) \
3199 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3200 #define IS_BASE64_IGNORABLE(Character) \
3201 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3202 || (Character) == '\f' || (Character) == '\r')
3204 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3205 character or return retval if there are no characters left to
3207 #define READ_QUADRUPLET_BYTE(retval) \
3212 if (nchars_return) \
3213 *nchars_return = nchars; \
3218 while (IS_BASE64_IGNORABLE (c))
3220 /* Table of characters coding the 64 values. */
3221 static char base64_value_to_char
[64] =
3223 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3224 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3225 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3226 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3227 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3228 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3229 '8', '9', '+', '/' /* 60-63 */
3232 /* Table of base64 values for first 128 characters. */
3233 static short base64_char_to_value
[128] =
3235 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3236 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3237 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3238 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3239 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3240 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3241 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3242 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3243 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3244 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3245 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3246 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3247 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3250 /* The following diagram shows the logical steps by which three octets
3251 get transformed into four base64 characters.
3253 .--------. .--------. .--------.
3254 |aaaaaabb| |bbbbcccc| |ccdddddd|
3255 `--------' `--------' `--------'
3257 .--------+--------+--------+--------.
3258 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3259 `--------+--------+--------+--------'
3261 .--------+--------+--------+--------.
3262 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3263 `--------+--------+--------+--------'
3265 The octets are divided into 6 bit chunks, which are then encoded into
3266 base64 characters. */
3269 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3270 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3272 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3274 doc
: /* Base64-encode the region between BEG and END.
3275 Return the length of the encoded text.
3276 Optional third argument NO-LINE-BREAK means do not break long lines
3277 into shorter lines. */)
3278 (beg
, end
, no_line_break
)
3279 Lisp_Object beg
, end
, no_line_break
;
3282 int allength
, length
;
3283 int ibeg
, iend
, encoded_length
;
3287 validate_region (&beg
, &end
);
3289 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3290 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3291 move_gap_both (XFASTINT (beg
), ibeg
);
3293 /* We need to allocate enough room for encoding the text.
3294 We need 33 1/3% more space, plus a newline every 76
3295 characters, and then we round up. */
3296 length
= iend
- ibeg
;
3297 allength
= length
+ length
/3 + 1;
3298 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3300 SAFE_ALLOCA (encoded
, char *, allength
);
3301 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3302 NILP (no_line_break
),
3303 !NILP (current_buffer
->enable_multibyte_characters
));
3304 if (encoded_length
> allength
)
3307 if (encoded_length
< 0)
3309 /* The encoding wasn't possible. */
3311 error ("Multibyte character in data for base64 encoding");
3314 /* Now we have encoded the region, so we insert the new contents
3315 and delete the old. (Insert first in order to preserve markers.) */
3316 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3317 insert (encoded
, encoded_length
);
3319 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3321 /* If point was outside of the region, restore it exactly; else just
3322 move to the beginning of the region. */
3323 if (old_pos
>= XFASTINT (end
))
3324 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3325 else if (old_pos
> XFASTINT (beg
))
3326 old_pos
= XFASTINT (beg
);
3329 /* We return the length of the encoded text. */
3330 return make_number (encoded_length
);
3333 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3335 doc
: /* Base64-encode STRING and return the result.
3336 Optional second argument NO-LINE-BREAK means do not break long lines
3337 into shorter lines. */)
3338 (string
, no_line_break
)
3339 Lisp_Object string
, no_line_break
;
3341 int allength
, length
, encoded_length
;
3343 Lisp_Object encoded_string
;
3346 CHECK_STRING (string
);
3348 /* We need to allocate enough room for encoding the text.
3349 We need 33 1/3% more space, plus a newline every 76
3350 characters, and then we round up. */
3351 length
= SBYTES (string
);
3352 allength
= length
+ length
/3 + 1;
3353 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3355 /* We need to allocate enough room for decoding the text. */
3356 SAFE_ALLOCA (encoded
, char *, allength
);
3358 encoded_length
= base64_encode_1 (SDATA (string
),
3359 encoded
, length
, NILP (no_line_break
),
3360 STRING_MULTIBYTE (string
));
3361 if (encoded_length
> allength
)
3364 if (encoded_length
< 0)
3366 /* The encoding wasn't possible. */
3368 error ("Multibyte character in data for base64 encoding");
3371 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3374 return encoded_string
;
3378 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3385 int counter
= 0, i
= 0;
3395 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3396 if (CHAR_BYTE8_P (c
))
3397 c
= CHAR_TO_BYTE8 (c
);
3405 /* Wrap line every 76 characters. */
3409 if (counter
< MIME_LINE_LENGTH
/ 4)
3418 /* Process first byte of a triplet. */
3420 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3421 value
= (0x03 & c
) << 4;
3423 /* Process second byte of a triplet. */
3427 *e
++ = base64_value_to_char
[value
];
3435 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3436 if (CHAR_BYTE8_P (c
))
3437 c
= CHAR_TO_BYTE8 (c
);
3445 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3446 value
= (0x0f & c
) << 2;
3448 /* Process third byte of a triplet. */
3452 *e
++ = base64_value_to_char
[value
];
3459 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3460 if (CHAR_BYTE8_P (c
))
3461 c
= CHAR_TO_BYTE8 (c
);
3469 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3470 *e
++ = base64_value_to_char
[0x3f & c
];
3477 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3479 doc
: /* Base64-decode the region between BEG and END.
3480 Return the length of the decoded text.
3481 If the region can't be decoded, signal an error and don't modify the buffer. */)
3483 Lisp_Object beg
, end
;
3485 int ibeg
, iend
, length
, allength
;
3490 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3493 validate_region (&beg
, &end
);
3495 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3496 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3498 length
= iend
- ibeg
;
3500 /* We need to allocate enough room for decoding the text. If we are
3501 working on a multibyte buffer, each decoded code may occupy at
3503 allength
= multibyte
? length
* 2 : length
;
3504 SAFE_ALLOCA (decoded
, char *, allength
);
3506 move_gap_both (XFASTINT (beg
), ibeg
);
3507 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3508 multibyte
, &inserted_chars
);
3509 if (decoded_length
> allength
)
3512 if (decoded_length
< 0)
3514 /* The decoding wasn't possible. */
3516 error ("Invalid base64 data");
3519 /* Now we have decoded the region, so we insert the new contents
3520 and delete the old. (Insert first in order to preserve markers.) */
3521 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3522 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3525 /* Delete the original text. */
3526 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3527 iend
+ decoded_length
, 1);
3529 /* If point was outside of the region, restore it exactly; else just
3530 move to the beginning of the region. */
3531 if (old_pos
>= XFASTINT (end
))
3532 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3533 else if (old_pos
> XFASTINT (beg
))
3534 old_pos
= XFASTINT (beg
);
3535 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3537 return make_number (inserted_chars
);
3540 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3542 doc
: /* Base64-decode STRING and return the result. */)
3547 int length
, decoded_length
;
3548 Lisp_Object decoded_string
;
3551 CHECK_STRING (string
);
3553 length
= SBYTES (string
);
3554 /* We need to allocate enough room for decoding the text. */
3555 SAFE_ALLOCA (decoded
, char *, length
);
3557 /* The decoded result should be unibyte. */
3558 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3560 if (decoded_length
> length
)
3562 else if (decoded_length
>= 0)
3563 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3565 decoded_string
= Qnil
;
3568 if (!STRINGP (decoded_string
))
3569 error ("Invalid base64 data");
3571 return decoded_string
;
3574 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3575 MULTIBYTE is nonzero, the decoded result should be in multibyte
3576 form. If NCHARS_RETRUN is not NULL, store the number of produced
3577 characters in *NCHARS_RETURN. */
3580 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3590 unsigned long value
;
3595 /* Process first byte of a quadruplet. */
3597 READ_QUADRUPLET_BYTE (e
-to
);
3601 value
= base64_char_to_value
[c
] << 18;
3603 /* Process second byte of a quadruplet. */
3605 READ_QUADRUPLET_BYTE (-1);
3609 value
|= base64_char_to_value
[c
] << 12;
3611 c
= (unsigned char) (value
>> 16);
3612 if (multibyte
&& c
>= 128)
3613 e
+= BYTE8_STRING (c
, e
);
3618 /* Process third byte of a quadruplet. */
3620 READ_QUADRUPLET_BYTE (-1);
3624 READ_QUADRUPLET_BYTE (-1);
3633 value
|= base64_char_to_value
[c
] << 6;
3635 c
= (unsigned char) (0xff & value
>> 8);
3636 if (multibyte
&& c
>= 128)
3637 e
+= BYTE8_STRING (c
, e
);
3642 /* Process fourth byte of a quadruplet. */
3644 READ_QUADRUPLET_BYTE (-1);
3651 value
|= base64_char_to_value
[c
];
3653 c
= (unsigned char) (0xff & value
);
3654 if (multibyte
&& c
>= 128)
3655 e
+= BYTE8_STRING (c
, e
);
3664 /***********************************************************************
3666 ***** Hash Tables *****
3668 ***********************************************************************/
3670 /* Implemented by gerd@gnu.org. This hash table implementation was
3671 inspired by CMUCL hash tables. */
3675 1. For small tables, association lists are probably faster than
3676 hash tables because they have lower overhead.
3678 For uses of hash tables where the O(1) behavior of table
3679 operations is not a requirement, it might therefore be a good idea
3680 not to hash. Instead, we could just do a linear search in the
3681 key_and_value vector of the hash table. This could be done
3682 if a `:linear-search t' argument is given to make-hash-table. */
3685 /* The list of all weak hash tables. Don't staticpro this one. */
3687 struct Lisp_Hash_Table
*weak_hash_tables
;
3689 /* Various symbols. */
3691 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3692 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3693 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3695 /* Function prototypes. */
3697 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3698 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3699 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3700 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3701 Lisp_Object
, unsigned));
3702 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3703 Lisp_Object
, unsigned));
3704 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3705 unsigned, Lisp_Object
, unsigned));
3706 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3707 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3708 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3709 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3711 static unsigned sxhash_string
P_ ((unsigned char *, int));
3712 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3713 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3714 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3715 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3719 /***********************************************************************
3721 ***********************************************************************/
3723 /* If OBJ is a Lisp hash table, return a pointer to its struct
3724 Lisp_Hash_Table. Otherwise, signal an error. */
3726 static struct Lisp_Hash_Table
*
3727 check_hash_table (obj
)
3730 CHECK_HASH_TABLE (obj
);
3731 return XHASH_TABLE (obj
);
3735 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3739 next_almost_prime (n
)
3752 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3753 which USED[I] is non-zero. If found at index I in ARGS, set
3754 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3755 -1. This function is used to extract a keyword/argument pair from
3756 a DEFUN parameter list. */
3759 get_key_arg (key
, nargs
, args
, used
)
3767 for (i
= 0; i
< nargs
- 1; ++i
)
3768 if (!used
[i
] && EQ (args
[i
], key
))
3783 /* Return a Lisp vector which has the same contents as VEC but has
3784 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3785 vector that are not copied from VEC are set to INIT. */
3788 larger_vector (vec
, new_size
, init
)
3793 struct Lisp_Vector
*v
;
3796 xassert (VECTORP (vec
));
3797 old_size
= ASIZE (vec
);
3798 xassert (new_size
>= old_size
);
3800 v
= allocate_vector (new_size
);
3801 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3802 old_size
* sizeof *v
->contents
);
3803 for (i
= old_size
; i
< new_size
; ++i
)
3804 v
->contents
[i
] = init
;
3805 XSETVECTOR (vec
, v
);
3810 /***********************************************************************
3812 ***********************************************************************/
3814 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3815 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3816 KEY2 are the same. */
3819 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3820 struct Lisp_Hash_Table
*h
;
3821 Lisp_Object key1
, key2
;
3822 unsigned hash1
, hash2
;
3824 return (FLOATP (key1
)
3826 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3830 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3831 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3832 KEY2 are the same. */
3835 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3836 struct Lisp_Hash_Table
*h
;
3837 Lisp_Object key1
, key2
;
3838 unsigned hash1
, hash2
;
3840 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3844 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3845 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3846 if KEY1 and KEY2 are the same. */
3849 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3850 struct Lisp_Hash_Table
*h
;
3851 Lisp_Object key1
, key2
;
3852 unsigned hash1
, hash2
;
3856 Lisp_Object args
[3];
3858 args
[0] = h
->user_cmp_function
;
3861 return !NILP (Ffuncall (3, args
));
3868 /* Value is a hash code for KEY for use in hash table H which uses
3869 `eq' to compare keys. The hash code returned is guaranteed to fit
3870 in a Lisp integer. */
3874 struct Lisp_Hash_Table
*h
;
3877 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3878 xassert ((hash
& ~INTMASK
) == 0);
3883 /* Value is a hash code for KEY for use in hash table H which uses
3884 `eql' to compare keys. The hash code returned is guaranteed to fit
3885 in a Lisp integer. */
3889 struct Lisp_Hash_Table
*h
;
3894 hash
= sxhash (key
, 0);
3896 hash
= XUINT (key
) ^ XTYPE (key
);
3897 xassert ((hash
& ~INTMASK
) == 0);
3902 /* Value is a hash code for KEY for use in hash table H which uses
3903 `equal' to compare keys. The hash code returned is guaranteed to fit
3904 in a Lisp integer. */
3907 hashfn_equal (h
, key
)
3908 struct Lisp_Hash_Table
*h
;
3911 unsigned hash
= sxhash (key
, 0);
3912 xassert ((hash
& ~INTMASK
) == 0);
3917 /* Value is a hash code for KEY for use in hash table H which uses as
3918 user-defined function to compare keys. The hash code returned is
3919 guaranteed to fit in a Lisp integer. */
3922 hashfn_user_defined (h
, key
)
3923 struct Lisp_Hash_Table
*h
;
3926 Lisp_Object args
[2], hash
;
3928 args
[0] = h
->user_hash_function
;
3930 hash
= Ffuncall (2, args
);
3931 if (!INTEGERP (hash
))
3932 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3933 return XUINT (hash
);
3937 /* Create and initialize a new hash table.
3939 TEST specifies the test the hash table will use to compare keys.
3940 It must be either one of the predefined tests `eq', `eql' or
3941 `equal' or a symbol denoting a user-defined test named TEST with
3942 test and hash functions USER_TEST and USER_HASH.
3944 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3946 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3947 new size when it becomes full is computed by adding REHASH_SIZE to
3948 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3949 table's new size is computed by multiplying its old size with
3952 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3953 be resized when the ratio of (number of entries in the table) /
3954 (table size) is >= REHASH_THRESHOLD.
3956 WEAK specifies the weakness of the table. If non-nil, it must be
3957 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3960 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3961 user_test
, user_hash
)
3962 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3963 Lisp_Object user_test
, user_hash
;
3965 struct Lisp_Hash_Table
*h
;
3967 int index_size
, i
, sz
;
3969 /* Preconditions. */
3970 xassert (SYMBOLP (test
));
3971 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3972 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3973 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3974 xassert (FLOATP (rehash_threshold
)
3975 && XFLOATINT (rehash_threshold
) > 0
3976 && XFLOATINT (rehash_threshold
) <= 1.0);
3978 if (XFASTINT (size
) == 0)
3979 size
= make_number (1);
3981 /* Allocate a table and initialize it. */
3982 h
= allocate_hash_table ();
3984 /* Initialize hash table slots. */
3985 sz
= XFASTINT (size
);
3988 if (EQ (test
, Qeql
))
3990 h
->cmpfn
= cmpfn_eql
;
3991 h
->hashfn
= hashfn_eql
;
3993 else if (EQ (test
, Qeq
))
3996 h
->hashfn
= hashfn_eq
;
3998 else if (EQ (test
, Qequal
))
4000 h
->cmpfn
= cmpfn_equal
;
4001 h
->hashfn
= hashfn_equal
;
4005 h
->user_cmp_function
= user_test
;
4006 h
->user_hash_function
= user_hash
;
4007 h
->cmpfn
= cmpfn_user_defined
;
4008 h
->hashfn
= hashfn_user_defined
;
4012 h
->rehash_threshold
= rehash_threshold
;
4013 h
->rehash_size
= rehash_size
;
4015 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4016 h
->hash
= Fmake_vector (size
, Qnil
);
4017 h
->next
= Fmake_vector (size
, Qnil
);
4018 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4019 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4020 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4022 /* Set up the free list. */
4023 for (i
= 0; i
< sz
- 1; ++i
)
4024 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4025 h
->next_free
= make_number (0);
4027 XSET_HASH_TABLE (table
, h
);
4028 xassert (HASH_TABLE_P (table
));
4029 xassert (XHASH_TABLE (table
) == h
);
4031 /* Maybe add this hash table to the list of all weak hash tables. */
4033 h
->next_weak
= NULL
;
4036 h
->next_weak
= weak_hash_tables
;
4037 weak_hash_tables
= h
;
4044 /* Return a copy of hash table H1. Keys and values are not copied,
4045 only the table itself is. */
4048 copy_hash_table (h1
)
4049 struct Lisp_Hash_Table
*h1
;
4052 struct Lisp_Hash_Table
*h2
;
4053 struct Lisp_Vector
*next
;
4055 h2
= allocate_hash_table ();
4056 next
= h2
->vec_next
;
4057 bcopy (h1
, h2
, sizeof *h2
);
4058 h2
->vec_next
= next
;
4059 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4060 h2
->hash
= Fcopy_sequence (h1
->hash
);
4061 h2
->next
= Fcopy_sequence (h1
->next
);
4062 h2
->index
= Fcopy_sequence (h1
->index
);
4063 XSET_HASH_TABLE (table
, h2
);
4065 /* Maybe add this hash table to the list of all weak hash tables. */
4066 if (!NILP (h2
->weak
))
4068 h2
->next_weak
= weak_hash_tables
;
4069 weak_hash_tables
= h2
;
4076 /* Resize hash table H if it's too full. If H cannot be resized
4077 because it's already too large, throw an error. */
4080 maybe_resize_hash_table (h
)
4081 struct Lisp_Hash_Table
*h
;
4083 if (NILP (h
->next_free
))
4085 int old_size
= HASH_TABLE_SIZE (h
);
4086 int i
, new_size
, index_size
;
4089 if (INTEGERP (h
->rehash_size
))
4090 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4092 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4093 new_size
= max (old_size
+ 1, new_size
);
4094 index_size
= next_almost_prime ((int)
4096 / XFLOATINT (h
->rehash_threshold
)));
4097 /* Assignment to EMACS_INT stops GCC whining about limited range
4099 nsize
= max (index_size
, 2 * new_size
);
4100 if (nsize
> MOST_POSITIVE_FIXNUM
)
4101 error ("Hash table too large to resize");
4103 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4104 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4105 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4106 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4108 /* Update the free list. Do it so that new entries are added at
4109 the end of the free list. This makes some operations like
4111 for (i
= old_size
; i
< new_size
- 1; ++i
)
4112 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4114 if (!NILP (h
->next_free
))
4116 Lisp_Object last
, next
;
4118 last
= h
->next_free
;
4119 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4123 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4126 XSETFASTINT (h
->next_free
, old_size
);
4129 for (i
= 0; i
< old_size
; ++i
)
4130 if (!NILP (HASH_HASH (h
, i
)))
4132 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4133 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4134 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4135 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4141 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4142 the hash code of KEY. Value is the index of the entry in H
4143 matching KEY, or -1 if not found. */
4146 hash_lookup (h
, key
, hash
)
4147 struct Lisp_Hash_Table
*h
;
4152 int start_of_bucket
;
4155 hash_code
= h
->hashfn (h
, key
);
4159 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4160 idx
= HASH_INDEX (h
, start_of_bucket
);
4162 /* We need not gcpro idx since it's either an integer or nil. */
4165 int i
= XFASTINT (idx
);
4166 if (EQ (key
, HASH_KEY (h
, i
))
4168 && h
->cmpfn (h
, key
, hash_code
,
4169 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4171 idx
= HASH_NEXT (h
, i
);
4174 return NILP (idx
) ? -1 : XFASTINT (idx
);
4178 /* Put an entry into hash table H that associates KEY with VALUE.
4179 HASH is a previously computed hash code of KEY.
4180 Value is the index of the entry in H matching KEY. */
4183 hash_put (h
, key
, value
, hash
)
4184 struct Lisp_Hash_Table
*h
;
4185 Lisp_Object key
, value
;
4188 int start_of_bucket
, i
;
4190 xassert ((hash
& ~INTMASK
) == 0);
4192 /* Increment count after resizing because resizing may fail. */
4193 maybe_resize_hash_table (h
);
4196 /* Store key/value in the key_and_value vector. */
4197 i
= XFASTINT (h
->next_free
);
4198 h
->next_free
= HASH_NEXT (h
, i
);
4199 HASH_KEY (h
, i
) = key
;
4200 HASH_VALUE (h
, i
) = value
;
4202 /* Remember its hash code. */
4203 HASH_HASH (h
, i
) = make_number (hash
);
4205 /* Add new entry to its collision chain. */
4206 start_of_bucket
= hash
% ASIZE (h
->index
);
4207 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4208 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4213 /* Remove the entry matching KEY from hash table H, if there is one. */
4216 hash_remove_from_table (h
, key
)
4217 struct Lisp_Hash_Table
*h
;
4221 int start_of_bucket
;
4222 Lisp_Object idx
, prev
;
4224 hash_code
= h
->hashfn (h
, key
);
4225 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4226 idx
= HASH_INDEX (h
, start_of_bucket
);
4229 /* We need not gcpro idx, prev since they're either integers or nil. */
4232 int i
= XFASTINT (idx
);
4234 if (EQ (key
, HASH_KEY (h
, i
))
4236 && h
->cmpfn (h
, key
, hash_code
,
4237 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4239 /* Take entry out of collision chain. */
4241 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4243 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4245 /* Clear slots in key_and_value and add the slots to
4247 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4248 HASH_NEXT (h
, i
) = h
->next_free
;
4249 h
->next_free
= make_number (i
);
4251 xassert (h
->count
>= 0);
4257 idx
= HASH_NEXT (h
, i
);
4263 /* Clear hash table H. */
4267 struct Lisp_Hash_Table
*h
;
4271 int i
, size
= HASH_TABLE_SIZE (h
);
4273 for (i
= 0; i
< size
; ++i
)
4275 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4276 HASH_KEY (h
, i
) = Qnil
;
4277 HASH_VALUE (h
, i
) = Qnil
;
4278 HASH_HASH (h
, i
) = Qnil
;
4281 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4282 ASET (h
->index
, i
, Qnil
);
4284 h
->next_free
= make_number (0);
4291 /************************************************************************
4293 ************************************************************************/
4296 init_weak_hash_tables ()
4298 weak_hash_tables
= NULL
;
4301 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4302 entries from the table that don't survive the current GC.
4303 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4304 non-zero if anything was marked. */
4307 sweep_weak_table (h
, remove_entries_p
)
4308 struct Lisp_Hash_Table
*h
;
4309 int remove_entries_p
;
4311 int bucket
, n
, marked
;
4313 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4316 for (bucket
= 0; bucket
< n
; ++bucket
)
4318 Lisp_Object idx
, next
, prev
;
4320 /* Follow collision chain, removing entries that
4321 don't survive this garbage collection. */
4323 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4325 int i
= XFASTINT (idx
);
4326 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4327 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4330 if (EQ (h
->weak
, Qkey
))
4331 remove_p
= !key_known_to_survive_p
;
4332 else if (EQ (h
->weak
, Qvalue
))
4333 remove_p
= !value_known_to_survive_p
;
4334 else if (EQ (h
->weak
, Qkey_or_value
))
4335 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4336 else if (EQ (h
->weak
, Qkey_and_value
))
4337 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4341 next
= HASH_NEXT (h
, i
);
4343 if (remove_entries_p
)
4347 /* Take out of collision chain. */
4349 HASH_INDEX (h
, bucket
) = next
;
4351 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4353 /* Add to free list. */
4354 HASH_NEXT (h
, i
) = h
->next_free
;
4357 /* Clear key, value, and hash. */
4358 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4359 HASH_HASH (h
, i
) = Qnil
;
4372 /* Make sure key and value survive. */
4373 if (!key_known_to_survive_p
)
4375 mark_object (HASH_KEY (h
, i
));
4379 if (!value_known_to_survive_p
)
4381 mark_object (HASH_VALUE (h
, i
));
4392 /* Remove elements from weak hash tables that don't survive the
4393 current garbage collection. Remove weak tables that don't survive
4394 from Vweak_hash_tables. Called from gc_sweep. */
4397 sweep_weak_hash_tables ()
4399 struct Lisp_Hash_Table
*h
, *used
, *next
;
4402 /* Mark all keys and values that are in use. Keep on marking until
4403 there is no more change. This is necessary for cases like
4404 value-weak table A containing an entry X -> Y, where Y is used in a
4405 key-weak table B, Z -> Y. If B comes after A in the list of weak
4406 tables, X -> Y might be removed from A, although when looking at B
4407 one finds that it shouldn't. */
4411 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4413 if (h
->size
& ARRAY_MARK_FLAG
)
4414 marked
|= sweep_weak_table (h
, 0);
4419 /* Remove tables and entries that aren't used. */
4420 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4422 next
= h
->next_weak
;
4424 if (h
->size
& ARRAY_MARK_FLAG
)
4426 /* TABLE is marked as used. Sweep its contents. */
4428 sweep_weak_table (h
, 1);
4430 /* Add table to the list of used weak hash tables. */
4431 h
->next_weak
= used
;
4436 weak_hash_tables
= used
;
4441 /***********************************************************************
4442 Hash Code Computation
4443 ***********************************************************************/
4445 /* Maximum depth up to which to dive into Lisp structures. */
4447 #define SXHASH_MAX_DEPTH 3
4449 /* Maximum length up to which to take list and vector elements into
4452 #define SXHASH_MAX_LEN 7
4454 /* Combine two integers X and Y for hashing. */
4456 #define SXHASH_COMBINE(X, Y) \
4457 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4461 /* Return a hash for string PTR which has length LEN. The hash
4462 code returned is guaranteed to fit in a Lisp integer. */
4465 sxhash_string (ptr
, len
)
4469 unsigned char *p
= ptr
;
4470 unsigned char *end
= p
+ len
;
4479 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4482 return hash
& INTMASK
;
4486 /* Return a hash for list LIST. DEPTH is the current depth in the
4487 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4490 sxhash_list (list
, depth
)
4497 if (depth
< SXHASH_MAX_DEPTH
)
4499 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4500 list
= XCDR (list
), ++i
)
4502 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4503 hash
= SXHASH_COMBINE (hash
, hash2
);
4508 unsigned hash2
= sxhash (list
, depth
+ 1);
4509 hash
= SXHASH_COMBINE (hash
, hash2
);
4516 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4517 the Lisp structure. */
4520 sxhash_vector (vec
, depth
)
4524 unsigned hash
= ASIZE (vec
);
4527 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4528 for (i
= 0; i
< n
; ++i
)
4530 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4531 hash
= SXHASH_COMBINE (hash
, hash2
);
4538 /* Return a hash for bool-vector VECTOR. */
4541 sxhash_bool_vector (vec
)
4544 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4547 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4548 for (i
= 0; i
< n
; ++i
)
4549 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4555 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4556 structure. Value is an unsigned integer clipped to INTMASK. */
4565 if (depth
> SXHASH_MAX_DEPTH
)
4568 switch (XTYPE (obj
))
4579 obj
= SYMBOL_NAME (obj
);
4583 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4586 /* This can be everything from a vector to an overlay. */
4587 case Lisp_Vectorlike
:
4589 /* According to the CL HyperSpec, two arrays are equal only if
4590 they are `eq', except for strings and bit-vectors. In
4591 Emacs, this works differently. We have to compare element
4593 hash
= sxhash_vector (obj
, depth
);
4594 else if (BOOL_VECTOR_P (obj
))
4595 hash
= sxhash_bool_vector (obj
);
4597 /* Others are `equal' if they are `eq', so let's take their
4603 hash
= sxhash_list (obj
, depth
);
4608 double val
= XFLOAT_DATA (obj
);
4609 unsigned char *p
= (unsigned char *) &val
;
4610 unsigned char *e
= p
+ sizeof val
;
4611 for (hash
= 0; p
< e
; ++p
)
4612 hash
= SXHASH_COMBINE (hash
, *p
);
4620 return hash
& INTMASK
;
4625 /***********************************************************************
4627 ***********************************************************************/
4630 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4631 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4635 unsigned hash
= sxhash (obj
, 0);
4636 return make_number (hash
);
4640 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4641 doc
: /* Create and return a new hash table.
4643 Arguments are specified as keyword/argument pairs. The following
4644 arguments are defined:
4646 :test TEST -- TEST must be a symbol that specifies how to compare
4647 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4648 `equal'. User-supplied test and hash functions can be specified via
4649 `define-hash-table-test'.
4651 :size SIZE -- A hint as to how many elements will be put in the table.
4654 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4655 fills up. If REHASH-SIZE is an integer, add that many space. If it
4656 is a float, it must be > 1.0, and the new size is computed by
4657 multiplying the old size with that factor. Default is 1.5.
4659 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4660 Resize the hash table when ratio of the number of entries in the
4661 table. Default is 0.8.
4663 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4664 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4665 returned is a weak table. Key/value pairs are removed from a weak
4666 hash table when there are no non-weak references pointing to their
4667 key, value, one of key or value, or both key and value, depending on
4668 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4671 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4676 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4677 Lisp_Object user_test
, user_hash
;
4681 /* The vector `used' is used to keep track of arguments that
4682 have been consumed. */
4683 used
= (char *) alloca (nargs
* sizeof *used
);
4684 bzero (used
, nargs
* sizeof *used
);
4686 /* See if there's a `:test TEST' among the arguments. */
4687 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4688 test
= i
< 0 ? Qeql
: args
[i
];
4689 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4691 /* See if it is a user-defined test. */
4694 prop
= Fget (test
, Qhash_table_test
);
4695 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4696 signal_error ("Invalid hash table test", test
);
4697 user_test
= XCAR (prop
);
4698 user_hash
= XCAR (XCDR (prop
));
4701 user_test
= user_hash
= Qnil
;
4703 /* See if there's a `:size SIZE' argument. */
4704 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4705 size
= i
< 0 ? Qnil
: args
[i
];
4707 size
= make_number (DEFAULT_HASH_SIZE
);
4708 else if (!INTEGERP (size
) || XINT (size
) < 0)
4709 signal_error ("Invalid hash table size", size
);
4711 /* Look for `:rehash-size SIZE'. */
4712 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4713 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4714 if (!NUMBERP (rehash_size
)
4715 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4716 || XFLOATINT (rehash_size
) <= 1.0)
4717 signal_error ("Invalid hash table rehash size", rehash_size
);
4719 /* Look for `:rehash-threshold THRESHOLD'. */
4720 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4721 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4722 if (!FLOATP (rehash_threshold
)
4723 || XFLOATINT (rehash_threshold
) <= 0.0
4724 || XFLOATINT (rehash_threshold
) > 1.0)
4725 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4727 /* Look for `:weakness WEAK'. */
4728 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4729 weak
= i
< 0 ? Qnil
: args
[i
];
4731 weak
= Qkey_and_value
;
4734 && !EQ (weak
, Qvalue
)
4735 && !EQ (weak
, Qkey_or_value
)
4736 && !EQ (weak
, Qkey_and_value
))
4737 signal_error ("Invalid hash table weakness", weak
);
4739 /* Now, all args should have been used up, or there's a problem. */
4740 for (i
= 0; i
< nargs
; ++i
)
4742 signal_error ("Invalid argument list", args
[i
]);
4744 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4745 user_test
, user_hash
);
4749 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4750 doc
: /* Return a copy of hash table TABLE. */)
4754 return copy_hash_table (check_hash_table (table
));
4758 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4759 doc
: /* Return the number of elements in TABLE. */)
4763 return make_number (check_hash_table (table
)->count
);
4767 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4768 Shash_table_rehash_size
, 1, 1, 0,
4769 doc
: /* Return the current rehash size of TABLE. */)
4773 return check_hash_table (table
)->rehash_size
;
4777 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4778 Shash_table_rehash_threshold
, 1, 1, 0,
4779 doc
: /* Return the current rehash threshold of TABLE. */)
4783 return check_hash_table (table
)->rehash_threshold
;
4787 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4788 doc
: /* Return the size of TABLE.
4789 The size can be used as an argument to `make-hash-table' to create
4790 a hash table than can hold as many elements of TABLE holds
4791 without need for resizing. */)
4795 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4796 return make_number (HASH_TABLE_SIZE (h
));
4800 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4801 doc
: /* Return the test TABLE uses. */)
4805 return check_hash_table (table
)->test
;
4809 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4811 doc
: /* Return the weakness of TABLE. */)
4815 return check_hash_table (table
)->weak
;
4819 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4820 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4824 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4828 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4829 doc
: /* Clear hash table TABLE and return it. */)
4833 hash_clear (check_hash_table (table
));
4834 /* Be compatible with XEmacs. */
4839 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4840 doc
: /* Look up KEY in TABLE and return its associated value.
4841 If KEY is not found, return DFLT which defaults to nil. */)
4843 Lisp_Object key
, table
, dflt
;
4845 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4846 int i
= hash_lookup (h
, key
, NULL
);
4847 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4851 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4852 doc
: /* Associate KEY with VALUE in hash table TABLE.
4853 If KEY is already present in table, replace its current value with
4856 Lisp_Object key
, value
, table
;
4858 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4862 i
= hash_lookup (h
, key
, &hash
);
4864 HASH_VALUE (h
, i
) = value
;
4866 hash_put (h
, key
, value
, hash
);
4872 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4873 doc
: /* Remove KEY from TABLE. */)
4875 Lisp_Object key
, table
;
4877 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4878 hash_remove_from_table (h
, key
);
4883 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4884 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4885 FUNCTION is called with two arguments, KEY and VALUE. */)
4887 Lisp_Object function
, table
;
4889 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4890 Lisp_Object args
[3];
4893 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4894 if (!NILP (HASH_HASH (h
, i
)))
4897 args
[1] = HASH_KEY (h
, i
);
4898 args
[2] = HASH_VALUE (h
, i
);
4906 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4907 Sdefine_hash_table_test
, 3, 3, 0,
4908 doc
: /* Define a new hash table test with name NAME, a symbol.
4910 In hash tables created with NAME specified as test, use TEST to
4911 compare keys, and HASH for computing hash codes of keys.
4913 TEST must be a function taking two arguments and returning non-nil if
4914 both arguments are the same. HASH must be a function taking one
4915 argument and return an integer that is the hash code of the argument.
4916 Hash code computation should use the whole value range of integers,
4917 including negative integers. */)
4919 Lisp_Object name
, test
, hash
;
4921 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4926 /************************************************************************
4928 ************************************************************************/
4932 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4933 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4935 A message digest is a cryptographic checksum of a document, and the
4936 algorithm to calculate it is defined in RFC 1321.
4938 The two optional arguments START and END are character positions
4939 specifying for which part of OBJECT the message digest should be
4940 computed. If nil or omitted, the digest is computed for the whole
4943 The MD5 message digest is computed from the result of encoding the
4944 text in a coding system, not directly from the internal Emacs form of
4945 the text. The optional fourth argument CODING-SYSTEM specifies which
4946 coding system to encode the text with. It should be the same coding
4947 system that you used or will use when actually writing the text into a
4950 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4951 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4952 system would be chosen by default for writing this text into a file.
4954 If OBJECT is a string, the most preferred coding system (see the
4955 command `prefer-coding-system') is used.
4957 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4958 guesswork fails. Normally, an error is signaled in such case. */)
4959 (object
, start
, end
, coding_system
, noerror
)
4960 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4962 unsigned char digest
[16];
4963 unsigned char value
[33];
4967 int start_char
= 0, end_char
= 0;
4968 int start_byte
= 0, end_byte
= 0;
4970 register struct buffer
*bp
;
4973 if (STRINGP (object
))
4975 if (NILP (coding_system
))
4977 /* Decide the coding-system to encode the data with. */
4979 if (STRING_MULTIBYTE (object
))
4980 /* use default, we can't guess correct value */
4981 coding_system
= preferred_coding_system ();
4983 coding_system
= Qraw_text
;
4986 if (NILP (Fcoding_system_p (coding_system
)))
4988 /* Invalid coding system. */
4990 if (!NILP (noerror
))
4991 coding_system
= Qraw_text
;
4993 xsignal1 (Qcoding_system_error
, coding_system
);
4996 if (STRING_MULTIBYTE (object
))
4997 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4999 size
= SCHARS (object
);
5000 size_byte
= SBYTES (object
);
5004 CHECK_NUMBER (start
);
5006 start_char
= XINT (start
);
5011 start_byte
= string_char_to_byte (object
, start_char
);
5017 end_byte
= size_byte
;
5023 end_char
= XINT (end
);
5028 end_byte
= string_char_to_byte (object
, end_char
);
5031 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5032 args_out_of_range_3 (object
, make_number (start_char
),
5033 make_number (end_char
));
5037 struct buffer
*prev
= current_buffer
;
5039 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5041 CHECK_BUFFER (object
);
5043 bp
= XBUFFER (object
);
5044 if (bp
!= current_buffer
)
5045 set_buffer_internal (bp
);
5051 CHECK_NUMBER_COERCE_MARKER (start
);
5059 CHECK_NUMBER_COERCE_MARKER (end
);
5064 temp
= b
, b
= e
, e
= temp
;
5066 if (!(BEGV
<= b
&& e
<= ZV
))
5067 args_out_of_range (start
, end
);
5069 if (NILP (coding_system
))
5071 /* Decide the coding-system to encode the data with.
5072 See fileio.c:Fwrite-region */
5074 if (!NILP (Vcoding_system_for_write
))
5075 coding_system
= Vcoding_system_for_write
;
5078 int force_raw_text
= 0;
5080 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5081 if (NILP (coding_system
)
5082 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5084 coding_system
= Qnil
;
5085 if (NILP (current_buffer
->enable_multibyte_characters
))
5089 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5091 /* Check file-coding-system-alist. */
5092 Lisp_Object args
[4], val
;
5094 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5095 args
[3] = Fbuffer_file_name(object
);
5096 val
= Ffind_operation_coding_system (4, args
);
5097 if (CONSP (val
) && !NILP (XCDR (val
)))
5098 coding_system
= XCDR (val
);
5101 if (NILP (coding_system
)
5102 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5104 /* If we still have not decided a coding system, use the
5105 default value of buffer-file-coding-system. */
5106 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5110 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5111 /* Confirm that VAL can surely encode the current region. */
5112 coding_system
= call4 (Vselect_safe_coding_system_function
,
5113 make_number (b
), make_number (e
),
5114 coding_system
, Qnil
);
5117 coding_system
= Qraw_text
;
5120 if (NILP (Fcoding_system_p (coding_system
)))
5122 /* Invalid coding system. */
5124 if (!NILP (noerror
))
5125 coding_system
= Qraw_text
;
5127 xsignal1 (Qcoding_system_error
, coding_system
);
5131 object
= make_buffer_string (b
, e
, 0);
5132 if (prev
!= current_buffer
)
5133 set_buffer_internal (prev
);
5134 /* Discard the unwind protect for recovering the current
5138 if (STRING_MULTIBYTE (object
))
5139 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5142 md5_buffer (SDATA (object
) + start_byte
,
5143 SBYTES (object
) - (size_byte
- end_byte
),
5146 for (i
= 0; i
< 16; i
++)
5147 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5150 return make_string (value
, 32);
5157 /* Hash table stuff. */
5158 Qhash_table_p
= intern ("hash-table-p");
5159 staticpro (&Qhash_table_p
);
5160 Qeq
= intern ("eq");
5162 Qeql
= intern ("eql");
5164 Qequal
= intern ("equal");
5165 staticpro (&Qequal
);
5166 QCtest
= intern (":test");
5167 staticpro (&QCtest
);
5168 QCsize
= intern (":size");
5169 staticpro (&QCsize
);
5170 QCrehash_size
= intern (":rehash-size");
5171 staticpro (&QCrehash_size
);
5172 QCrehash_threshold
= intern (":rehash-threshold");
5173 staticpro (&QCrehash_threshold
);
5174 QCweakness
= intern (":weakness");
5175 staticpro (&QCweakness
);
5176 Qkey
= intern ("key");
5178 Qvalue
= intern ("value");
5179 staticpro (&Qvalue
);
5180 Qhash_table_test
= intern ("hash-table-test");
5181 staticpro (&Qhash_table_test
);
5182 Qkey_or_value
= intern ("key-or-value");
5183 staticpro (&Qkey_or_value
);
5184 Qkey_and_value
= intern ("key-and-value");
5185 staticpro (&Qkey_and_value
);
5188 defsubr (&Smake_hash_table
);
5189 defsubr (&Scopy_hash_table
);
5190 defsubr (&Shash_table_count
);
5191 defsubr (&Shash_table_rehash_size
);
5192 defsubr (&Shash_table_rehash_threshold
);
5193 defsubr (&Shash_table_size
);
5194 defsubr (&Shash_table_test
);
5195 defsubr (&Shash_table_weakness
);
5196 defsubr (&Shash_table_p
);
5197 defsubr (&Sclrhash
);
5198 defsubr (&Sgethash
);
5199 defsubr (&Sputhash
);
5200 defsubr (&Sremhash
);
5201 defsubr (&Smaphash
);
5202 defsubr (&Sdefine_hash_table_test
);
5204 Qstring_lessp
= intern ("string-lessp");
5205 staticpro (&Qstring_lessp
);
5206 Qprovide
= intern ("provide");
5207 staticpro (&Qprovide
);
5208 Qrequire
= intern ("require");
5209 staticpro (&Qrequire
);
5210 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5211 staticpro (&Qyes_or_no_p_history
);
5212 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5213 staticpro (&Qcursor_in_echo_area
);
5214 Qwidget_type
= intern ("widget-type");
5215 staticpro (&Qwidget_type
);
5217 staticpro (&string_char_byte_cache_string
);
5218 string_char_byte_cache_string
= Qnil
;
5220 require_nesting_list
= Qnil
;
5221 staticpro (&require_nesting_list
);
5223 Fset (Qyes_or_no_p_history
, Qnil
);
5225 DEFVAR_LISP ("features", &Vfeatures
,
5226 doc
: /* A list of symbols which are the features of the executing Emacs.
5227 Used by `featurep' and `require', and altered by `provide'. */);
5228 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5229 Qsubfeatures
= intern ("subfeatures");
5230 staticpro (&Qsubfeatures
);
5232 #ifdef HAVE_LANGINFO_CODESET
5233 Qcodeset
= intern ("codeset");
5234 staticpro (&Qcodeset
);
5235 Qdays
= intern ("days");
5237 Qmonths
= intern ("months");
5238 staticpro (&Qmonths
);
5239 Qpaper
= intern ("paper");
5240 staticpro (&Qpaper
);
5241 #endif /* HAVE_LANGINFO_CODESET */
5243 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5244 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5245 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5246 invoked by mouse clicks and mouse menu items.
5248 On some platforms, file selection dialogs are also enabled if this is
5252 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5253 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5254 This applies to commands from menus and tool bar buttons even when
5255 they are initiated from the keyboard. If `use-dialog-box' is nil,
5256 that disables the use of a file dialog, regardless of the value of
5258 use_file_dialog
= 1;
5260 defsubr (&Sidentity
);
5263 defsubr (&Ssafe_length
);
5264 defsubr (&Sstring_bytes
);
5265 defsubr (&Sstring_equal
);
5266 defsubr (&Scompare_strings
);
5267 defsubr (&Sstring_lessp
);
5270 defsubr (&Svconcat
);
5271 defsubr (&Scopy_sequence
);
5272 defsubr (&Sstring_make_multibyte
);
5273 defsubr (&Sstring_make_unibyte
);
5274 defsubr (&Sstring_as_multibyte
);
5275 defsubr (&Sstring_as_unibyte
);
5276 defsubr (&Sstring_to_multibyte
);
5277 defsubr (&Sstring_to_unibyte
);
5278 defsubr (&Scopy_alist
);
5279 defsubr (&Ssubstring
);
5280 defsubr (&Ssubstring_no_properties
);
5293 defsubr (&Snreverse
);
5294 defsubr (&Sreverse
);
5296 defsubr (&Splist_get
);
5298 defsubr (&Splist_put
);
5300 defsubr (&Slax_plist_get
);
5301 defsubr (&Slax_plist_put
);
5304 defsubr (&Sequal_including_properties
);
5305 defsubr (&Sfillarray
);
5306 defsubr (&Sclear_string
);
5310 defsubr (&Smapconcat
);
5311 defsubr (&Sy_or_n_p
);
5312 defsubr (&Syes_or_no_p
);
5313 defsubr (&Sload_average
);
5314 defsubr (&Sfeaturep
);
5315 defsubr (&Srequire
);
5316 defsubr (&Sprovide
);
5317 defsubr (&Splist_member
);
5318 defsubr (&Swidget_put
);
5319 defsubr (&Swidget_get
);
5320 defsubr (&Swidget_apply
);
5321 defsubr (&Sbase64_encode_region
);
5322 defsubr (&Sbase64_decode_region
);
5323 defsubr (&Sbase64_encode_string
);
5324 defsubr (&Sbase64_decode_string
);
5326 defsubr (&Slocale_info
);
5335 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5336 (do not change this comment) */