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/>. */
28 /* Note on some machines this defines `vector' as a typedef,
29 so make sure we don't use that name in this file. */
35 #include "character.h"
40 #include "intervals.h"
43 #include "blockinput.h"
45 #if defined (HAVE_X_WINDOWS)
47 #elif defined (MAC_OS)
53 #define NULL ((POINTER_TYPE *)0)
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 /* Nonzero enables use of a file dialog for file name
61 questions asked by mouse commands. */
64 extern int minibuffer_auto_raise
;
65 extern Lisp_Object minibuf_window
;
66 extern Lisp_Object Vlocale_coding_system
;
67 extern int load_in_progress
;
69 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
70 Lisp_Object Qyes_or_no_p_history
;
71 Lisp_Object Qcursor_in_echo_area
;
72 Lisp_Object Qwidget_type
;
73 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
75 extern Lisp_Object Qinput_method_function
;
77 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
79 extern long get_random ();
80 extern void seed_random
P_ ((long));
86 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
87 doc
: /* Return the argument unchanged. */)
94 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
95 doc
: /* Return a pseudo-random number.
96 All integers representable in Lisp are equally likely.
97 On most systems, this is 29 bits' worth.
98 With positive integer LIMIT, return random number in interval [0,LIMIT).
99 With argument t, set the random number seed from the current time and pid.
100 Other values of LIMIT are ignored. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (limit
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
144 if (STRINGP (sequence
))
145 XSETFASTINT (val
, SCHARS (sequence
));
146 else if (VECTORP (sequence
))
147 XSETFASTINT (val
, ASIZE (sequence
));
148 else if (CHAR_TABLE_P (sequence
))
149 XSETFASTINT (val
, MAX_CHAR
);
150 else if (BOOL_VECTOR_P (sequence
))
151 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
152 else if (COMPILEDP (sequence
))
153 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
154 else if (CONSP (sequence
))
157 while (CONSP (sequence
))
159 sequence
= XCDR (sequence
);
162 if (!CONSP (sequence
))
165 sequence
= XCDR (sequence
);
170 CHECK_LIST_END (sequence
, sequence
);
172 val
= make_number (i
);
174 else if (NILP (sequence
))
175 XSETFASTINT (val
, 0);
177 wrong_type_argument (Qsequencep
, sequence
);
182 /* This does not check for quits. That is safe since it must terminate. */
184 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
185 doc
: /* Return the length of a list, but avoid error or infinite loop.
186 This function never gets an error. If LIST is not really a list,
187 it returns 0. If LIST is circular, it returns a finite value
188 which is at least the number of distinct elements. */)
192 Lisp_Object tail
, halftail
, length
;
195 /* halftail is used to detect circular lists. */
197 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
199 if (EQ (tail
, halftail
) && len
!= 0)
203 halftail
= XCDR (halftail
);
206 XSETINT (length
, len
);
210 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
211 doc
: /* Return the number of bytes in STRING.
212 If STRING is multibyte, this may be greater than the length of STRING. */)
216 CHECK_STRING (string
);
217 return make_number (SBYTES (string
));
220 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
221 doc
: /* Return t if two strings have identical contents.
222 Case is significant, but text properties are ignored.
223 Symbols are also allowed; their print names are used instead. */)
225 register Lisp_Object s1
, s2
;
228 s1
= SYMBOL_NAME (s1
);
230 s2
= SYMBOL_NAME (s2
);
234 if (SCHARS (s1
) != SCHARS (s2
)
235 || SBYTES (s1
) != SBYTES (s2
)
236 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
241 DEFUN ("compare-strings", Fcompare_strings
,
242 Scompare_strings
, 6, 7, 0,
243 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
244 In string STR1, skip the first START1 characters and stop at END1.
245 In string STR2, skip the first START2 characters and stop at END2.
246 END1 and END2 default to the full lengths of the respective strings.
248 Case is significant in this comparison if IGNORE-CASE is nil.
249 Unibyte strings are converted to multibyte for comparison.
251 The value is t if the strings (or specified portions) match.
252 If string STR1 is less, the value is a negative number N;
253 - 1 - N is the number of characters that match at the beginning.
254 If string STR1 is greater, the value is a positive number N;
255 N - 1 is the number of characters that match at the beginning. */)
256 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
257 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
259 register int end1_char
, end2_char
;
260 register int i1
, i1_byte
, i2
, i2_byte
;
265 start1
= make_number (0);
267 start2
= make_number (0);
268 CHECK_NATNUM (start1
);
269 CHECK_NATNUM (start2
);
278 i1_byte
= string_char_to_byte (str1
, i1
);
279 i2_byte
= string_char_to_byte (str2
, i2
);
281 end1_char
= SCHARS (str1
);
282 if (! NILP (end1
) && end1_char
> XINT (end1
))
283 end1_char
= XINT (end1
);
285 end2_char
= SCHARS (str2
);
286 if (! NILP (end2
) && end2_char
> XINT (end2
))
287 end2_char
= XINT (end2
);
289 while (i1
< end1_char
&& i2
< end2_char
)
291 /* When we find a mismatch, we must compare the
292 characters, not just the bytes. */
295 if (STRING_MULTIBYTE (str1
))
296 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
299 c1
= SREF (str1
, i1
++);
300 c1
= unibyte_char_to_multibyte (c1
);
303 if (STRING_MULTIBYTE (str2
))
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
307 c2
= SREF (str2
, i2
++);
308 c2
= unibyte_char_to_multibyte (c2
);
314 if (! NILP (ignore_case
))
318 tem
= Fupcase (make_number (c1
));
320 tem
= Fupcase (make_number (c2
));
327 /* Note that I1 has already been incremented
328 past the character that we are comparing;
329 hence we don't add or subtract 1 here. */
331 return make_number (- i1
+ XINT (start1
));
333 return make_number (i1
- XINT (start1
));
337 return make_number (i1
- XINT (start1
) + 1);
339 return make_number (- i1
+ XINT (start1
) - 1);
344 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
345 doc
: /* Return t if first arg string is less than second in lexicographic order.
347 Symbols are also allowed; their print names are used instead. */)
349 register Lisp_Object s1
, s2
;
352 register int i1
, i1_byte
, i2
, i2_byte
;
355 s1
= SYMBOL_NAME (s1
);
357 s2
= SYMBOL_NAME (s2
);
361 i1
= i1_byte
= i2
= i2_byte
= 0;
364 if (end
> SCHARS (s2
))
369 /* When we find a mismatch, we must compare the
370 characters, not just the bytes. */
373 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
374 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
377 return c1
< c2
? Qt
: Qnil
;
379 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
383 /* "gcc -O3" enables automatic function inlining, which optimizes out
384 the arguments for the invocations of this function, whereas it
385 expects these values on the stack. */
386 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
387 #else /* !__GNUC__ */
388 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
400 return concat (2, args
, Lisp_String
, 0);
402 return concat (2, &s1
, Lisp_String
, 0);
403 #endif /* NO_ARG_ARRAY */
409 Lisp_Object s1
, s2
, s3
;
416 return concat (3, args
, Lisp_String
, 0);
418 return concat (3, &s1
, Lisp_String
, 0);
419 #endif /* NO_ARG_ARRAY */
422 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
423 doc
: /* Concatenate all the arguments and make the result a list.
424 The result is a list whose elements are the elements of all the arguments.
425 Each argument may be a list, vector or string.
426 The last argument is not copied, just used as the tail of the new list.
427 usage: (append &rest SEQUENCES) */)
432 return concat (nargs
, args
, Lisp_Cons
, 1);
435 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
436 doc
: /* Concatenate all the arguments and make the result a string.
437 The result is a string whose elements are the elements of all the arguments.
438 Each argument may be a string or a list or vector of characters (integers).
439 usage: (concat &rest SEQUENCES) */)
444 return concat (nargs
, args
, Lisp_String
, 0);
447 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
448 doc
: /* Concatenate all the arguments and make the result a vector.
449 The result is a vector whose elements are the elements of all the arguments.
450 Each argument may be a list, vector or string.
451 usage: (vconcat &rest SEQUENCES) */)
456 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
460 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
461 doc
: /* Return a copy of a list, vector, string or char-table.
462 The elements of a list or vector are not copied; they are shared
463 with the original. */)
467 if (NILP (arg
)) return arg
;
469 if (CHAR_TABLE_P (arg
))
471 return copy_char_table (arg
);
474 if (BOOL_VECTOR_P (arg
))
478 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
479 / BOOL_VECTOR_BITS_PER_CHAR
);
481 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
482 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
487 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
488 wrong_type_argument (Qsequencep
, arg
);
490 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
493 /* This structure holds information of an argument of `concat' that is
494 a string and has text properties to be copied. */
497 int argnum
; /* refer to ARGS (arguments of `concat') */
498 int from
; /* refer to ARGS[argnum] (argument string) */
499 int to
; /* refer to VAL (the target string) */
503 concat (nargs
, args
, target_type
, last_special
)
506 enum Lisp_Type target_type
;
510 register Lisp_Object tail
;
511 register Lisp_Object
this;
513 int toindex_byte
= 0;
514 register int result_len
;
515 register int result_len_byte
;
517 Lisp_Object last_tail
;
520 /* When we make a multibyte string, we can't copy text properties
521 while concatinating each string because the length of resulting
522 string can't be decided until we finish the whole concatination.
523 So, we record strings that have text properties to be copied
524 here, and copy the text properties after the concatination. */
525 struct textprop_rec
*textprops
= NULL
;
526 /* Number of elments in textprops. */
527 int num_textprops
= 0;
532 /* In append, the last arg isn't treated like the others */
533 if (last_special
&& nargs
> 0)
536 last_tail
= args
[nargs
];
541 /* Check each argument. */
542 for (argnum
= 0; argnum
< nargs
; argnum
++)
545 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
546 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
547 wrong_type_argument (Qsequencep
, this);
550 /* Compute total length in chars of arguments in RESULT_LEN.
551 If desired output is a string, also compute length in bytes
552 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
553 whether the result should be a multibyte string. */
557 for (argnum
= 0; argnum
< nargs
; argnum
++)
561 len
= XFASTINT (Flength (this));
562 if (target_type
== Lisp_String
)
564 /* We must count the number of bytes needed in the string
565 as well as the number of characters. */
571 for (i
= 0; i
< len
; i
++)
574 CHECK_CHARACTER (ch
);
575 this_len_byte
= CHAR_BYTES (XINT (ch
));
576 result_len_byte
+= this_len_byte
;
577 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
580 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
581 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
582 else if (CONSP (this))
583 for (; CONSP (this); this = XCDR (this))
586 CHECK_CHARACTER (ch
);
587 this_len_byte
= CHAR_BYTES (XINT (ch
));
588 result_len_byte
+= this_len_byte
;
589 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
592 else if (STRINGP (this))
594 if (STRING_MULTIBYTE (this))
597 result_len_byte
+= SBYTES (this);
600 result_len_byte
+= count_size_as_multibyte (SDATA (this),
608 if (! some_multibyte
)
609 result_len_byte
= result_len
;
611 /* Create the output object. */
612 if (target_type
== Lisp_Cons
)
613 val
= Fmake_list (make_number (result_len
), Qnil
);
614 else if (target_type
== Lisp_Vectorlike
)
615 val
= Fmake_vector (make_number (result_len
), Qnil
);
616 else if (some_multibyte
)
617 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
619 val
= make_uninit_string (result_len
);
621 /* In `append', if all but last arg are nil, return last arg. */
622 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
625 /* Copy the contents of the args into the result. */
627 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
629 toindex
= 0, toindex_byte
= 0;
633 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
635 for (argnum
= 0; argnum
< nargs
; argnum
++)
639 register unsigned int thisindex
= 0;
640 register unsigned int thisindex_byte
= 0;
644 thislen
= Flength (this), thisleni
= XINT (thislen
);
646 /* Between strings of the same kind, copy fast. */
647 if (STRINGP (this) && STRINGP (val
)
648 && STRING_MULTIBYTE (this) == some_multibyte
)
650 int thislen_byte
= SBYTES (this);
652 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
654 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
656 textprops
[num_textprops
].argnum
= argnum
;
657 textprops
[num_textprops
].from
= 0;
658 textprops
[num_textprops
++].to
= toindex
;
660 toindex_byte
+= thislen_byte
;
662 STRING_SET_CHARS (val
, SCHARS (val
));
664 /* Copy a single-byte string to a multibyte string. */
665 else if (STRINGP (this) && STRINGP (val
))
667 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
669 textprops
[num_textprops
].argnum
= argnum
;
670 textprops
[num_textprops
].from
= 0;
671 textprops
[num_textprops
++].to
= toindex
;
673 toindex_byte
+= copy_text (SDATA (this),
674 SDATA (val
) + toindex_byte
,
675 SCHARS (this), 0, 1);
679 /* Copy element by element. */
682 register Lisp_Object elt
;
684 /* Fetch next element of `this' arg into `elt', or break if
685 `this' is exhausted. */
686 if (NILP (this)) break;
688 elt
= XCAR (this), this = XCDR (this);
689 else if (thisindex
>= thisleni
)
691 else if (STRINGP (this))
694 if (STRING_MULTIBYTE (this))
696 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
699 XSETFASTINT (elt
, c
);
703 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
705 && XINT (elt
) >= 0200
706 && XINT (elt
) < 0400)
708 c
= unibyte_char_to_multibyte (XINT (elt
));
713 else if (BOOL_VECTOR_P (this))
716 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
717 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
725 elt
= AREF (this, thisindex
);
729 /* Store this element into the result. */
736 else if (VECTORP (val
))
738 ASET (val
, toindex
, elt
);
745 toindex_byte
+= CHAR_STRING (XINT (elt
),
746 SDATA (val
) + toindex_byte
);
748 SSET (val
, toindex_byte
++, XINT (elt
));
754 XSETCDR (prev
, last_tail
);
756 if (num_textprops
> 0)
759 int last_to_end
= -1;
761 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
763 this = args
[textprops
[argnum
].argnum
];
764 props
= text_property_list (this,
766 make_number (SCHARS (this)),
768 /* If successive arguments have properites, be sure that the
769 value of `composition' property be the copy. */
770 if (last_to_end
== textprops
[argnum
].to
)
771 make_composition_value_copy (props
);
772 add_text_properties_from_list (val
, props
,
773 make_number (textprops
[argnum
].to
));
774 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
782 static Lisp_Object string_char_byte_cache_string
;
783 static EMACS_INT string_char_byte_cache_charpos
;
784 static EMACS_INT string_char_byte_cache_bytepos
;
787 clear_string_char_byte_cache ()
789 string_char_byte_cache_string
= Qnil
;
792 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
795 string_char_to_byte (string
, char_index
)
797 EMACS_INT char_index
;
800 EMACS_INT best_below
, best_below_byte
;
801 EMACS_INT best_above
, best_above_byte
;
803 best_below
= best_below_byte
= 0;
804 best_above
= SCHARS (string
);
805 best_above_byte
= SBYTES (string
);
806 if (best_above
== best_above_byte
)
809 if (EQ (string
, string_char_byte_cache_string
))
811 if (string_char_byte_cache_charpos
< char_index
)
813 best_below
= string_char_byte_cache_charpos
;
814 best_below_byte
= string_char_byte_cache_bytepos
;
818 best_above
= string_char_byte_cache_charpos
;
819 best_above_byte
= string_char_byte_cache_bytepos
;
823 if (char_index
- best_below
< best_above
- char_index
)
825 unsigned char *p
= SDATA (string
) + best_below_byte
;
827 while (best_below
< char_index
)
829 p
+= BYTES_BY_CHAR_HEAD (*p
);
832 i_byte
= p
- SDATA (string
);
836 unsigned char *p
= SDATA (string
) + best_above_byte
;
838 while (best_above
> char_index
)
841 while (!CHAR_HEAD_P (*p
)) p
--;
844 i_byte
= p
- SDATA (string
);
847 string_char_byte_cache_bytepos
= i_byte
;
848 string_char_byte_cache_charpos
= char_index
;
849 string_char_byte_cache_string
= string
;
854 /* Return the character index corresponding to BYTE_INDEX in STRING. */
857 string_byte_to_char (string
, byte_index
)
859 EMACS_INT byte_index
;
862 EMACS_INT best_below
, best_below_byte
;
863 EMACS_INT best_above
, best_above_byte
;
865 best_below
= best_below_byte
= 0;
866 best_above
= SCHARS (string
);
867 best_above_byte
= SBYTES (string
);
868 if (best_above
== best_above_byte
)
871 if (EQ (string
, string_char_byte_cache_string
))
873 if (string_char_byte_cache_bytepos
< byte_index
)
875 best_below
= string_char_byte_cache_charpos
;
876 best_below_byte
= string_char_byte_cache_bytepos
;
880 best_above
= string_char_byte_cache_charpos
;
881 best_above_byte
= string_char_byte_cache_bytepos
;
885 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
887 unsigned char *p
= SDATA (string
) + best_below_byte
;
888 unsigned char *pend
= SDATA (string
) + byte_index
;
892 p
+= BYTES_BY_CHAR_HEAD (*p
);
896 i_byte
= p
- SDATA (string
);
900 unsigned char *p
= SDATA (string
) + best_above_byte
;
901 unsigned char *pbeg
= SDATA (string
) + byte_index
;
906 while (!CHAR_HEAD_P (*p
)) p
--;
910 i_byte
= p
- SDATA (string
);
913 string_char_byte_cache_bytepos
= i_byte
;
914 string_char_byte_cache_charpos
= i
;
915 string_char_byte_cache_string
= string
;
920 /* Convert STRING to a multibyte string. */
923 string_make_multibyte (string
)
931 if (STRING_MULTIBYTE (string
))
934 nbytes
= count_size_as_multibyte (SDATA (string
),
936 /* If all the chars are ASCII, they won't need any more bytes
937 once converted. In that case, we can return STRING itself. */
938 if (nbytes
== SBYTES (string
))
941 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
942 copy_text (SDATA (string
), buf
, SBYTES (string
),
945 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
952 /* Convert STRING (if unibyte) to a multibyte string without changing
953 the number of characters. Characters 0200 trough 0237 are
954 converted to eight-bit characters. */
957 string_to_multibyte (string
)
965 if (STRING_MULTIBYTE (string
))
968 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
969 /* If all the chars are ASCII, they won't need any more bytes once
971 if (nbytes
== SBYTES (string
))
972 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
974 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
975 bcopy (SDATA (string
), buf
, SBYTES (string
));
976 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
978 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
985 /* Convert STRING to a single-byte string. */
988 string_make_unibyte (string
)
996 if (! STRING_MULTIBYTE (string
))
999 nchars
= SCHARS (string
);
1001 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1002 copy_text (SDATA (string
), buf
, SBYTES (string
),
1005 ret
= make_unibyte_string (buf
, nchars
);
1011 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1013 doc
: /* Return the multibyte equivalent of STRING.
1014 If STRING is unibyte and contains non-ASCII characters, the function
1015 `unibyte-char-to-multibyte' is used to convert each unibyte character
1016 to a multibyte character. In this case, the returned string is a
1017 newly created string with no text properties. If STRING is multibyte
1018 or entirely ASCII, it is returned unchanged. In particular, when
1019 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1020 \(When the characters are all ASCII, Emacs primitives will treat the
1021 string the same way whether it is unibyte or multibyte.) */)
1025 CHECK_STRING (string
);
1027 return string_make_multibyte (string
);
1030 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1032 doc
: /* Return the unibyte equivalent of STRING.
1033 Multibyte character codes are converted to unibyte according to
1034 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1035 If the lookup in the translation table fails, this function takes just
1036 the low 8 bits of each character. */)
1040 CHECK_STRING (string
);
1042 return string_make_unibyte (string
);
1045 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1047 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1048 If STRING is unibyte, the result is STRING itself.
1049 Otherwise it is a newly created string, with no text properties.
1050 If STRING is multibyte and contains a character of charset
1051 `eight-bit', it is converted to the corresponding single byte. */)
1055 CHECK_STRING (string
);
1057 if (STRING_MULTIBYTE (string
))
1059 int bytes
= SBYTES (string
);
1060 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1062 bcopy (SDATA (string
), str
, bytes
);
1063 bytes
= str_as_unibyte (str
, bytes
);
1064 string
= make_unibyte_string (str
, bytes
);
1070 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1072 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1073 If STRING is multibyte, the result is STRING itself.
1074 Otherwise it is a newly created string, with no text properties.
1076 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1077 part of a correct utf-8 sequence), it is converted to the corresponding
1078 multibyte character of charset `eight-bit'.
1079 See also `string-to-multibyte'.
1081 Beware, this often doesn't really do what you think it does.
1082 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1083 If you're not sure, whether to use `string-as-multibyte' or
1084 `string-to-multibyte', use `string-to-multibyte'. */)
1088 CHECK_STRING (string
);
1090 if (! STRING_MULTIBYTE (string
))
1092 Lisp_Object new_string
;
1095 parse_str_as_multibyte (SDATA (string
),
1098 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1099 bcopy (SDATA (string
), SDATA (new_string
),
1101 if (nbytes
!= SBYTES (string
))
1102 str_as_multibyte (SDATA (new_string
), nbytes
,
1103 SBYTES (string
), NULL
);
1104 string
= new_string
;
1105 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1110 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1112 doc
: /* Return a multibyte string with the same individual chars as STRING.
1113 If STRING is multibyte, the result is STRING itself.
1114 Otherwise it is a newly created string, with no text properties.
1116 If STRING is unibyte and contains an 8-bit byte, it is converted to
1117 the corresponding multibyte character of charset `eight-bit'.
1119 This differs from `string-as-multibyte' by converting each byte of a correct
1120 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1121 correct sequence. */)
1125 CHECK_STRING (string
);
1127 return string_to_multibyte (string
);
1130 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1132 doc
: /* Return a unibyte string with the same individual chars as STRING.
1133 If STRING is unibyte, the result is STRING itself.
1134 Otherwise it is a newly created string, with no text properties,
1135 where each `eight-bit' character is converted to the corresponding byte.
1136 If STRING contains a non-ASCII, non-`eight-bit' character,
1137 an error is signaled. */)
1141 CHECK_STRING (string
);
1143 if (STRING_MULTIBYTE (string
))
1145 EMACS_INT chars
= SCHARS (string
);
1146 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1147 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1149 if (converted
< chars
)
1150 error ("Can't convert the %dth character to unibyte", converted
);
1151 string
= make_unibyte_string (str
, chars
);
1158 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1159 doc
: /* Return a copy of ALIST.
1160 This is an alist which represents the same mapping from objects to objects,
1161 but does not share the alist structure with ALIST.
1162 The objects mapped (cars and cdrs of elements of the alist)
1163 are shared, however.
1164 Elements of ALIST that are not conses are also shared. */)
1168 register Lisp_Object tem
;
1173 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1174 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1176 register Lisp_Object car
;
1180 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1185 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1186 doc
: /* Return a new string whose contents are a substring of STRING.
1187 The returned string consists of the characters between index FROM
1188 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1189 zero-indexed: 0 means the first character of STRING. Negative values
1190 are counted from the end of STRING. If TO is nil, the substring runs
1191 to the end of STRING.
1193 The STRING argument may also be a vector. In that case, the return
1194 value is a new vector that contains the elements between index FROM
1195 \(inclusive) and index TO (exclusive) of that vector argument. */)
1198 register Lisp_Object from
, to
;
1203 int from_char
, to_char
;
1204 int from_byte
= 0, to_byte
= 0;
1206 CHECK_VECTOR_OR_STRING (string
);
1207 CHECK_NUMBER (from
);
1209 if (STRINGP (string
))
1211 size
= SCHARS (string
);
1212 size_byte
= SBYTES (string
);
1215 size
= ASIZE (string
);
1220 to_byte
= size_byte
;
1226 to_char
= XINT (to
);
1230 if (STRINGP (string
))
1231 to_byte
= string_char_to_byte (string
, to_char
);
1234 from_char
= XINT (from
);
1237 if (STRINGP (string
))
1238 from_byte
= string_char_to_byte (string
, from_char
);
1240 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1241 args_out_of_range_3 (string
, make_number (from_char
),
1242 make_number (to_char
));
1244 if (STRINGP (string
))
1246 res
= make_specified_string (SDATA (string
) + from_byte
,
1247 to_char
- from_char
, to_byte
- from_byte
,
1248 STRING_MULTIBYTE (string
));
1249 copy_text_properties (make_number (from_char
), make_number (to_char
),
1250 string
, make_number (0), res
, Qnil
);
1253 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1259 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1260 doc
: /* Return a substring of STRING, without text properties.
1261 It starts at index FROM and ending before TO.
1262 TO may be nil or omitted; then the substring runs to the end of STRING.
1263 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1264 If FROM or TO is negative, it counts from the end.
1266 With one argument, just copy STRING without its properties. */)
1269 register Lisp_Object from
, to
;
1271 int size
, size_byte
;
1272 int from_char
, to_char
;
1273 int from_byte
, to_byte
;
1275 CHECK_STRING (string
);
1277 size
= SCHARS (string
);
1278 size_byte
= SBYTES (string
);
1281 from_char
= from_byte
= 0;
1284 CHECK_NUMBER (from
);
1285 from_char
= XINT (from
);
1289 from_byte
= string_char_to_byte (string
, from_char
);
1295 to_byte
= size_byte
;
1301 to_char
= XINT (to
);
1305 to_byte
= string_char_to_byte (string
, to_char
);
1308 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1309 args_out_of_range_3 (string
, make_number (from_char
),
1310 make_number (to_char
));
1312 return make_specified_string (SDATA (string
) + from_byte
,
1313 to_char
- from_char
, to_byte
- from_byte
,
1314 STRING_MULTIBYTE (string
));
1317 /* Extract a substring of STRING, giving start and end positions
1318 both in characters and in bytes. */
1321 substring_both (string
, from
, from_byte
, to
, to_byte
)
1323 int from
, from_byte
, to
, to_byte
;
1329 CHECK_VECTOR_OR_STRING (string
);
1331 if (STRINGP (string
))
1333 size
= SCHARS (string
);
1334 size_byte
= SBYTES (string
);
1337 size
= ASIZE (string
);
1339 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1340 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1342 if (STRINGP (string
))
1344 res
= make_specified_string (SDATA (string
) + from_byte
,
1345 to
- from
, to_byte
- from_byte
,
1346 STRING_MULTIBYTE (string
));
1347 copy_text_properties (make_number (from
), make_number (to
),
1348 string
, make_number (0), res
, Qnil
);
1351 res
= Fvector (to
- from
, &AREF (string
, from
));
1356 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1357 doc
: /* Take cdr N times on LIST, returns the result. */)
1360 register Lisp_Object list
;
1362 register int i
, num
;
1365 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1368 CHECK_LIST_CONS (list
, list
);
1374 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1375 doc
: /* Return the Nth element of LIST.
1376 N counts from zero. If LIST is not that long, nil is returned. */)
1378 Lisp_Object n
, list
;
1380 return Fcar (Fnthcdr (n
, list
));
1383 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1384 doc
: /* Return element of SEQUENCE at index N. */)
1386 register Lisp_Object sequence
, n
;
1389 if (CONSP (sequence
) || NILP (sequence
))
1390 return Fcar (Fnthcdr (n
, sequence
));
1392 /* Faref signals a "not array" error, so check here. */
1393 CHECK_ARRAY (sequence
, Qsequencep
);
1394 return Faref (sequence
, n
);
1397 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1398 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1399 The value is actually the tail of LIST whose car is ELT. */)
1401 register Lisp_Object elt
;
1404 register Lisp_Object tail
;
1405 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1407 register Lisp_Object tem
;
1408 CHECK_LIST_CONS (tail
, list
);
1410 if (! NILP (Fequal (elt
, tem
)))
1417 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1418 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1419 The value is actually the tail of LIST whose car is ELT. */)
1421 register Lisp_Object elt
, list
;
1425 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1429 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1433 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1444 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1445 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1446 The value is actually the tail of LIST whose car is ELT. */)
1448 register Lisp_Object elt
;
1451 register Lisp_Object tail
;
1454 return Fmemq (elt
, list
);
1456 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1458 register Lisp_Object tem
;
1459 CHECK_LIST_CONS (tail
, list
);
1461 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1468 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1469 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1470 The value is actually the first element of LIST whose car is KEY.
1471 Elements of LIST that are not conses are ignored. */)
1473 Lisp_Object key
, list
;
1478 || (CONSP (XCAR (list
))
1479 && EQ (XCAR (XCAR (list
)), key
)))
1484 || (CONSP (XCAR (list
))
1485 && EQ (XCAR (XCAR (list
)), key
)))
1490 || (CONSP (XCAR (list
))
1491 && EQ (XCAR (XCAR (list
)), key
)))
1501 /* Like Fassq but never report an error and do not allow quits.
1502 Use only on lists known never to be circular. */
1505 assq_no_quit (key
, list
)
1506 Lisp_Object key
, list
;
1509 && (!CONSP (XCAR (list
))
1510 || !EQ (XCAR (XCAR (list
)), key
)))
1513 return CAR_SAFE (list
);
1516 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1517 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1518 The value is actually the first element of LIST whose car equals KEY. */)
1520 Lisp_Object key
, list
;
1527 || (CONSP (XCAR (list
))
1528 && (car
= XCAR (XCAR (list
)),
1529 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1534 || (CONSP (XCAR (list
))
1535 && (car
= XCAR (XCAR (list
)),
1536 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1541 || (CONSP (XCAR (list
))
1542 && (car
= XCAR (XCAR (list
)),
1543 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1553 /* Like Fassoc but never report an error and do not allow quits.
1554 Use only on lists known never to be circular. */
1557 assoc_no_quit (key
, list
)
1558 Lisp_Object key
, list
;
1561 && (!CONSP (XCAR (list
))
1562 || (!EQ (XCAR (XCAR (list
)), key
)
1563 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1566 return CONSP (list
) ? XCAR (list
) : Qnil
;
1569 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1570 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1571 The value is actually the first element of LIST whose cdr is KEY. */)
1573 register Lisp_Object key
;
1579 || (CONSP (XCAR (list
))
1580 && EQ (XCDR (XCAR (list
)), key
)))
1585 || (CONSP (XCAR (list
))
1586 && EQ (XCDR (XCAR (list
)), key
)))
1591 || (CONSP (XCAR (list
))
1592 && EQ (XCDR (XCAR (list
)), key
)))
1602 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1603 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1604 The value is actually the first element of LIST whose cdr equals KEY. */)
1606 Lisp_Object key
, list
;
1613 || (CONSP (XCAR (list
))
1614 && (cdr
= XCDR (XCAR (list
)),
1615 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1620 || (CONSP (XCAR (list
))
1621 && (cdr
= XCDR (XCAR (list
)),
1622 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1627 || (CONSP (XCAR (list
))
1628 && (cdr
= XCDR (XCAR (list
)),
1629 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1639 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1640 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1641 The modified LIST is returned. Comparison is done with `eq'.
1642 If the first member of LIST is ELT, there is no way to remove it by side effect;
1643 therefore, write `(setq foo (delq element foo))'
1644 to be sure of changing the value of `foo'. */)
1646 register Lisp_Object elt
;
1649 register Lisp_Object tail
, prev
;
1650 register Lisp_Object tem
;
1654 while (!NILP (tail
))
1656 CHECK_LIST_CONS (tail
, list
);
1663 Fsetcdr (prev
, XCDR (tail
));
1673 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1674 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1675 SEQ must be a list, a vector, or a string.
1676 The modified SEQ is returned. Comparison is done with `equal'.
1677 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1678 is not a side effect; it is simply using a different sequence.
1679 Therefore, write `(setq foo (delete element foo))'
1680 to be sure of changing the value of `foo'. */)
1682 Lisp_Object elt
, seq
;
1688 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1689 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1692 if (n
!= ASIZE (seq
))
1694 struct Lisp_Vector
*p
= allocate_vector (n
);
1696 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1697 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1698 p
->contents
[n
++] = AREF (seq
, i
);
1700 XSETVECTOR (seq
, p
);
1703 else if (STRINGP (seq
))
1705 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1708 for (i
= nchars
= nbytes
= ibyte
= 0;
1710 ++i
, ibyte
+= cbytes
)
1712 if (STRING_MULTIBYTE (seq
))
1714 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1715 SBYTES (seq
) - ibyte
);
1716 cbytes
= CHAR_BYTES (c
);
1724 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1731 if (nchars
!= SCHARS (seq
))
1735 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1736 if (!STRING_MULTIBYTE (seq
))
1737 STRING_SET_UNIBYTE (tem
);
1739 for (i
= nchars
= nbytes
= ibyte
= 0;
1741 ++i
, ibyte
+= cbytes
)
1743 if (STRING_MULTIBYTE (seq
))
1745 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1746 SBYTES (seq
) - ibyte
);
1747 cbytes
= CHAR_BYTES (c
);
1755 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1757 unsigned char *from
= SDATA (seq
) + ibyte
;
1758 unsigned char *to
= SDATA (tem
) + nbytes
;
1764 for (n
= cbytes
; n
--; )
1774 Lisp_Object tail
, prev
;
1776 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1778 CHECK_LIST_CONS (tail
, seq
);
1780 if (!NILP (Fequal (elt
, XCAR (tail
))))
1785 Fsetcdr (prev
, XCDR (tail
));
1796 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1797 doc
: /* Reverse LIST by modifying cdr pointers.
1798 Return the reversed list. */)
1802 register Lisp_Object prev
, tail
, next
;
1804 if (NILP (list
)) return list
;
1807 while (!NILP (tail
))
1810 CHECK_LIST_CONS (tail
, list
);
1812 Fsetcdr (tail
, prev
);
1819 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1820 doc
: /* Reverse LIST, copying. Return the reversed list.
1821 See also the function `nreverse', which is used more often. */)
1827 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1830 new = Fcons (XCAR (list
), new);
1832 CHECK_LIST_END (list
, list
);
1836 Lisp_Object
merge ();
1838 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1839 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1840 Returns the sorted list. LIST is modified by side effects.
1841 PREDICATE is called with two elements of LIST, and should return non-nil
1842 if the first element should sort before the second. */)
1844 Lisp_Object list
, predicate
;
1846 Lisp_Object front
, back
;
1847 register Lisp_Object len
, tem
;
1848 struct gcpro gcpro1
, gcpro2
;
1849 register int length
;
1852 len
= Flength (list
);
1853 length
= XINT (len
);
1857 XSETINT (len
, (length
/ 2) - 1);
1858 tem
= Fnthcdr (len
, list
);
1860 Fsetcdr (tem
, Qnil
);
1862 GCPRO2 (front
, back
);
1863 front
= Fsort (front
, predicate
);
1864 back
= Fsort (back
, predicate
);
1866 return merge (front
, back
, predicate
);
1870 merge (org_l1
, org_l2
, pred
)
1871 Lisp_Object org_l1
, org_l2
;
1875 register Lisp_Object tail
;
1877 register Lisp_Object l1
, l2
;
1878 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1885 /* It is sufficient to protect org_l1 and org_l2.
1886 When l1 and l2 are updated, we copy the new values
1887 back into the org_ vars. */
1888 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1908 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1924 Fsetcdr (tail
, tem
);
1930 #if 0 /* Unsafe version. */
1931 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1932 doc
: /* Extract a value from a property list.
1933 PLIST is a property list, which is a list of the form
1934 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1935 corresponding to the given PROP, or nil if PROP is not
1936 one of the properties on the list. */)
1944 CONSP (tail
) && CONSP (XCDR (tail
));
1945 tail
= XCDR (XCDR (tail
)))
1947 if (EQ (prop
, XCAR (tail
)))
1948 return XCAR (XCDR (tail
));
1950 /* This function can be called asynchronously
1951 (setup_coding_system). Don't QUIT in that case. */
1952 if (!interrupt_input_blocked
)
1956 CHECK_LIST_END (tail
, prop
);
1962 /* This does not check for quits. That is safe since it must terminate. */
1964 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1965 doc
: /* Extract a value from a property list.
1966 PLIST is a property list, which is a list of the form
1967 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1968 corresponding to the given PROP, or nil if PROP is not one of the
1969 properties on the list. This function never signals an error. */)
1974 Lisp_Object tail
, halftail
;
1976 /* halftail is used to detect circular lists. */
1977 tail
= halftail
= plist
;
1978 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1980 if (EQ (prop
, XCAR (tail
)))
1981 return XCAR (XCDR (tail
));
1983 tail
= XCDR (XCDR (tail
));
1984 halftail
= XCDR (halftail
);
1985 if (EQ (tail
, halftail
))
1992 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1993 doc
: /* Return the value of SYMBOL's PROPNAME property.
1994 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1996 Lisp_Object symbol
, propname
;
1998 CHECK_SYMBOL (symbol
);
1999 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2002 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2003 doc
: /* Change value in PLIST of PROP to VAL.
2004 PLIST is a property list, which is a list of the form
2005 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2006 If PROP is already a property on the list, its value is set to VAL,
2007 otherwise the new PROP VAL pair is added. The new plist is returned;
2008 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2009 The PLIST is modified by side effects. */)
2012 register Lisp_Object prop
;
2015 register Lisp_Object tail
, prev
;
2016 Lisp_Object newcell
;
2018 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2019 tail
= XCDR (XCDR (tail
)))
2021 if (EQ (prop
, XCAR (tail
)))
2023 Fsetcar (XCDR (tail
), val
);
2030 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2034 Fsetcdr (XCDR (prev
), newcell
);
2038 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2039 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2040 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2041 (symbol
, propname
, value
)
2042 Lisp_Object symbol
, propname
, value
;
2044 CHECK_SYMBOL (symbol
);
2045 XSYMBOL (symbol
)->plist
2046 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2050 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2051 doc
: /* Extract a value from a property list, comparing with `equal'.
2052 PLIST is a property list, which is a list of the form
2053 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2054 corresponding to the given PROP, or nil if PROP is not
2055 one of the properties on the list. */)
2063 CONSP (tail
) && CONSP (XCDR (tail
));
2064 tail
= XCDR (XCDR (tail
)))
2066 if (! NILP (Fequal (prop
, XCAR (tail
))))
2067 return XCAR (XCDR (tail
));
2072 CHECK_LIST_END (tail
, prop
);
2077 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2078 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2079 PLIST is a property list, which is a list of the form
2080 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2081 If PROP is already a property on the list, its value is set to VAL,
2082 otherwise the new PROP VAL pair is added. The new plist is returned;
2083 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2084 The PLIST is modified by side effects. */)
2087 register Lisp_Object prop
;
2090 register Lisp_Object tail
, prev
;
2091 Lisp_Object newcell
;
2093 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2094 tail
= XCDR (XCDR (tail
)))
2096 if (! NILP (Fequal (prop
, XCAR (tail
))))
2098 Fsetcar (XCDR (tail
), val
);
2105 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2109 Fsetcdr (XCDR (prev
), newcell
);
2113 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2114 doc
: /* Return t if the two args are the same Lisp object.
2115 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2117 Lisp_Object obj1
, obj2
;
2120 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2122 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2125 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2126 doc
: /* Return t if two Lisp objects have similar structure and contents.
2127 They must have the same data type.
2128 Conses are compared by comparing the cars and the cdrs.
2129 Vectors and strings are compared element by element.
2130 Numbers are compared by value, but integers cannot equal floats.
2131 (Use `=' if you want integers and floats to be able to be equal.)
2132 Symbols must match exactly. */)
2134 register Lisp_Object o1
, o2
;
2136 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2139 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2140 doc
: /* Return t if two Lisp objects have similar structure and contents.
2141 This is like `equal' except that it compares the text properties
2142 of strings. (`equal' ignores text properties.) */)
2144 register Lisp_Object o1
, o2
;
2146 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2149 /* DEPTH is current depth of recursion. Signal an error if it
2151 PROPS, if non-nil, means compare string text properties too. */
2154 internal_equal (o1
, o2
, depth
, props
)
2155 register Lisp_Object o1
, o2
;
2159 error ("Stack overflow in equal");
2165 if (XTYPE (o1
) != XTYPE (o2
))
2174 d1
= extract_float (o1
);
2175 d2
= extract_float (o2
);
2176 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2177 though they are not =. */
2178 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2182 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2189 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2193 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2195 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2198 o1
= XOVERLAY (o1
)->plist
;
2199 o2
= XOVERLAY (o2
)->plist
;
2204 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2205 && (XMARKER (o1
)->buffer
== 0
2206 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2210 case Lisp_Vectorlike
:
2213 EMACS_INT size
= ASIZE (o1
);
2214 /* Pseudovectors have the type encoded in the size field, so this test
2215 actually checks that the objects have the same type as well as the
2217 if (ASIZE (o2
) != size
)
2219 /* Boolvectors are compared much like strings. */
2220 if (BOOL_VECTOR_P (o1
))
2223 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2224 / BOOL_VECTOR_BITS_PER_CHAR
);
2226 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2228 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2233 if (WINDOW_CONFIGURATIONP (o1
))
2234 return compare_window_configurations (o1
, o2
, 0);
2236 /* Aside from them, only true vectors, char-tables, compiled
2237 functions, and fonts (font-spec, font-entity, font-ojbect)
2238 are sensible to compare, so eliminate the others now. */
2239 if (size
& PSEUDOVECTOR_FLAG
)
2241 if (!(size
& (PVEC_COMPILED
2242 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2244 size
&= PSEUDOVECTOR_SIZE_MASK
;
2246 for (i
= 0; i
< size
; i
++)
2251 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2259 if (SCHARS (o1
) != SCHARS (o2
))
2261 if (SBYTES (o1
) != SBYTES (o2
))
2263 if (bcmp (SDATA (o1
), SDATA (o2
),
2266 if (props
&& !compare_string_intervals (o1
, o2
))
2272 case Lisp_Type_Limit
:
2279 extern Lisp_Object
Fmake_char_internal ();
2281 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2282 doc
: /* Store each element of ARRAY with ITEM.
2283 ARRAY is a vector, string, char-table, or bool-vector. */)
2285 Lisp_Object array
, item
;
2287 register int size
, index
, charval
;
2288 if (VECTORP (array
))
2290 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2291 size
= ASIZE (array
);
2292 for (index
= 0; index
< size
; index
++)
2295 else if (CHAR_TABLE_P (array
))
2299 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2300 XCHAR_TABLE (array
)->contents
[i
] = item
;
2301 XCHAR_TABLE (array
)->defalt
= item
;
2303 else if (STRINGP (array
))
2305 register unsigned char *p
= SDATA (array
);
2306 CHECK_NUMBER (item
);
2307 charval
= XINT (item
);
2308 size
= SCHARS (array
);
2309 if (STRING_MULTIBYTE (array
))
2311 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2312 int len
= CHAR_STRING (charval
, str
);
2313 int size_byte
= SBYTES (array
);
2314 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2317 if (size
!= size_byte
)
2320 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2321 if (len
!= this_len
)
2322 error ("Attempt to change byte length of a string");
2325 for (i
= 0; i
< size_byte
; i
++)
2326 *p
++ = str
[i
% len
];
2329 for (index
= 0; index
< size
; index
++)
2332 else if (BOOL_VECTOR_P (array
))
2334 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2336 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2337 / BOOL_VECTOR_BITS_PER_CHAR
);
2339 charval
= (! NILP (item
) ? -1 : 0);
2340 for (index
= 0; index
< size_in_chars
- 1; index
++)
2342 if (index
< size_in_chars
)
2344 /* Mask out bits beyond the vector size. */
2345 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2346 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2351 wrong_type_argument (Qarrayp
, array
);
2355 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2357 doc
: /* Clear the contents of STRING.
2358 This makes STRING unibyte and may change its length. */)
2363 CHECK_STRING (string
);
2364 len
= SBYTES (string
);
2365 bzero (SDATA (string
), len
);
2366 STRING_SET_CHARS (string
, len
);
2367 STRING_SET_UNIBYTE (string
);
2377 Lisp_Object args
[2];
2380 return Fnconc (2, args
);
2382 return Fnconc (2, &s1
);
2383 #endif /* NO_ARG_ARRAY */
2386 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2387 doc
: /* Concatenate any number of lists by altering them.
2388 Only the last argument is not altered, and need not be a list.
2389 usage: (nconc &rest LISTS) */)
2394 register int argnum
;
2395 register Lisp_Object tail
, tem
, val
;
2399 for (argnum
= 0; argnum
< nargs
; argnum
++)
2402 if (NILP (tem
)) continue;
2407 if (argnum
+ 1 == nargs
) break;
2409 CHECK_LIST_CONS (tem
, tem
);
2418 tem
= args
[argnum
+ 1];
2419 Fsetcdr (tail
, tem
);
2421 args
[argnum
+ 1] = tail
;
2427 /* This is the guts of all mapping functions.
2428 Apply FN to each element of SEQ, one by one,
2429 storing the results into elements of VALS, a C vector of Lisp_Objects.
2430 LENI is the length of VALS, which should also be the length of SEQ. */
2433 mapcar1 (leni
, vals
, fn
, seq
)
2436 Lisp_Object fn
, seq
;
2438 register Lisp_Object tail
;
2441 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2445 /* Don't let vals contain any garbage when GC happens. */
2446 for (i
= 0; i
< leni
; i
++)
2449 GCPRO3 (dummy
, fn
, seq
);
2451 gcpro1
.nvars
= leni
;
2455 /* We need not explicitly protect `tail' because it is used only on lists, and
2456 1) lists are not relocated and 2) the list is marked via `seq' so will not
2461 for (i
= 0; i
< leni
; i
++)
2463 dummy
= call1 (fn
, AREF (seq
, i
));
2468 else if (BOOL_VECTOR_P (seq
))
2470 for (i
= 0; i
< leni
; i
++)
2473 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2474 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2475 dummy
= call1 (fn
, dummy
);
2480 else if (STRINGP (seq
))
2484 for (i
= 0, i_byte
= 0; i
< leni
;)
2489 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2490 XSETFASTINT (dummy
, c
);
2491 dummy
= call1 (fn
, dummy
);
2493 vals
[i_before
] = dummy
;
2496 else /* Must be a list, since Flength did not get an error */
2499 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2501 dummy
= call1 (fn
, XCAR (tail
));
2511 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2512 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2513 In between each pair of results, stick in SEPARATOR. Thus, " " as
2514 SEPARATOR results in spaces between the values returned by FUNCTION.
2515 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2516 (function
, sequence
, separator
)
2517 Lisp_Object function
, sequence
, separator
;
2522 register Lisp_Object
*args
;
2524 struct gcpro gcpro1
;
2528 len
= Flength (sequence
);
2529 if (CHAR_TABLE_P (sequence
))
2530 wrong_type_argument (Qlistp
, sequence
);
2532 nargs
= leni
+ leni
- 1;
2533 if (nargs
< 0) return empty_unibyte_string
;
2535 SAFE_ALLOCA_LISP (args
, nargs
);
2538 mapcar1 (leni
, args
, function
, sequence
);
2541 for (i
= leni
- 1; i
> 0; i
--)
2542 args
[i
+ i
] = args
[i
];
2544 for (i
= 1; i
< nargs
; i
+= 2)
2545 args
[i
] = separator
;
2547 ret
= Fconcat (nargs
, args
);
2553 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2554 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2555 The result is a list just as long as SEQUENCE.
2556 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2557 (function
, sequence
)
2558 Lisp_Object function
, sequence
;
2560 register Lisp_Object len
;
2562 register Lisp_Object
*args
;
2566 len
= Flength (sequence
);
2567 if (CHAR_TABLE_P (sequence
))
2568 wrong_type_argument (Qlistp
, sequence
);
2569 leni
= XFASTINT (len
);
2571 SAFE_ALLOCA_LISP (args
, leni
);
2573 mapcar1 (leni
, args
, function
, sequence
);
2575 ret
= Flist (leni
, args
);
2581 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2582 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2583 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2584 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2585 (function
, sequence
)
2586 Lisp_Object function
, sequence
;
2590 leni
= XFASTINT (Flength (sequence
));
2591 if (CHAR_TABLE_P (sequence
))
2592 wrong_type_argument (Qlistp
, sequence
);
2593 mapcar1 (leni
, 0, function
, sequence
);
2598 /* Anything that calls this function must protect from GC! */
2600 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2601 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2602 Takes one argument, which is the string to display to ask the question.
2603 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2604 No confirmation of the answer is requested; a single character is enough.
2605 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2606 the bindings in `query-replace-map'; see the documentation of that variable
2607 for more information. In this case, the useful bindings are `act', `skip',
2608 `recenter', and `quit'.\)
2610 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2611 is nil and `use-dialog-box' is non-nil. */)
2615 register Lisp_Object obj
, key
, def
, map
;
2616 register int answer
;
2617 Lisp_Object xprompt
;
2618 Lisp_Object args
[2];
2619 struct gcpro gcpro1
, gcpro2
;
2620 int count
= SPECPDL_INDEX ();
2622 specbind (Qcursor_in_echo_area
, Qt
);
2624 map
= Fsymbol_value (intern ("query-replace-map"));
2626 CHECK_STRING (prompt
);
2628 GCPRO2 (prompt
, xprompt
);
2630 #ifdef HAVE_WINDOW_SYSTEM
2631 if (display_hourglass_p
)
2632 cancel_hourglass ();
2639 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2640 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2644 Lisp_Object pane
, menu
;
2645 redisplay_preserve_echo_area (3);
2646 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2647 Fcons (Fcons (build_string ("No"), Qnil
),
2649 menu
= Fcons (prompt
, pane
);
2650 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2651 answer
= !NILP (obj
);
2654 #endif /* HAVE_MENUS */
2655 cursor_in_echo_area
= 1;
2656 choose_minibuf_frame ();
2659 Lisp_Object pargs
[3];
2661 /* Colorize prompt according to `minibuffer-prompt' face. */
2662 pargs
[0] = build_string ("%s(y or n) ");
2663 pargs
[1] = intern ("face");
2664 pargs
[2] = intern ("minibuffer-prompt");
2665 args
[0] = Fpropertize (3, pargs
);
2670 if (minibuffer_auto_raise
)
2672 Lisp_Object mini_frame
;
2674 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2676 Fraise_frame (mini_frame
);
2679 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2680 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2681 cursor_in_echo_area
= 0;
2682 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2685 key
= Fmake_vector (make_number (1), obj
);
2686 def
= Flookup_key (map
, key
, Qt
);
2688 if (EQ (def
, intern ("skip")))
2693 else if (EQ (def
, intern ("act")))
2698 else if (EQ (def
, intern ("recenter")))
2704 else if (EQ (def
, intern ("quit")))
2706 /* We want to exit this command for exit-prefix,
2707 and this is the only way to do it. */
2708 else if (EQ (def
, intern ("exit-prefix")))
2713 /* If we don't clear this, then the next call to read_char will
2714 return quit_char again, and we'll enter an infinite loop. */
2719 if (EQ (xprompt
, prompt
))
2721 args
[0] = build_string ("Please answer y or n. ");
2723 xprompt
= Fconcat (2, args
);
2728 if (! noninteractive
)
2730 cursor_in_echo_area
= -1;
2731 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2735 unbind_to (count
, Qnil
);
2736 return answer
? Qt
: Qnil
;
2739 /* This is how C code calls `yes-or-no-p' and allows the user
2742 Anything that calls this function must protect from GC! */
2745 do_yes_or_no_p (prompt
)
2748 return call1 (intern ("yes-or-no-p"), prompt
);
2751 /* Anything that calls this function must protect from GC! */
2753 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2754 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2755 Takes one argument, which is the string to display to ask the question.
2756 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2757 The user must confirm the answer with RET,
2758 and can edit it until it has been confirmed.
2760 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2761 is nil, and `use-dialog-box' is non-nil. */)
2765 register Lisp_Object ans
;
2766 Lisp_Object args
[2];
2767 struct gcpro gcpro1
;
2769 CHECK_STRING (prompt
);
2772 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2773 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2777 Lisp_Object pane
, menu
, obj
;
2778 redisplay_preserve_echo_area (4);
2779 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2780 Fcons (Fcons (build_string ("No"), Qnil
),
2783 menu
= Fcons (prompt
, pane
);
2784 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2788 #endif /* HAVE_MENUS */
2791 args
[1] = build_string ("(yes or no) ");
2792 prompt
= Fconcat (2, args
);
2798 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2799 Qyes_or_no_p_history
, Qnil
,
2801 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2806 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2814 message ("Please answer yes or no.");
2815 Fsleep_for (make_number (2), Qnil
);
2819 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2820 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2822 Each of the three load averages is multiplied by 100, then converted
2825 When USE-FLOATS is non-nil, floats will be used instead of integers.
2826 These floats are not multiplied by 100.
2828 If the 5-minute or 15-minute load averages are not available, return a
2829 shortened list, containing only those averages which are available.
2831 An error is thrown if the load average can't be obtained. In some
2832 cases making it work would require Emacs being installed setuid or
2833 setgid so that it can read kernel information, and that usually isn't
2836 Lisp_Object use_floats
;
2839 int loads
= getloadavg (load_ave
, 3);
2840 Lisp_Object ret
= Qnil
;
2843 error ("load-average not implemented for this operating system");
2847 Lisp_Object load
= (NILP (use_floats
) ?
2848 make_number ((int) (100.0 * load_ave
[loads
]))
2849 : make_float (load_ave
[loads
]));
2850 ret
= Fcons (load
, ret
);
2856 Lisp_Object Vfeatures
, Qsubfeatures
;
2857 extern Lisp_Object Vafter_load_alist
;
2859 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2860 doc
: /* Returns t if FEATURE is present in this Emacs.
2862 Use this to conditionalize execution of lisp code based on the
2863 presence or absence of Emacs or environment extensions.
2864 Use `provide' to declare that a feature is available. This function
2865 looks at the value of the variable `features'. The optional argument
2866 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2867 (feature
, subfeature
)
2868 Lisp_Object feature
, subfeature
;
2870 register Lisp_Object tem
;
2871 CHECK_SYMBOL (feature
);
2872 tem
= Fmemq (feature
, Vfeatures
);
2873 if (!NILP (tem
) && !NILP (subfeature
))
2874 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2875 return (NILP (tem
)) ? Qnil
: Qt
;
2878 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2879 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2880 The optional argument SUBFEATURES should be a list of symbols listing
2881 particular subfeatures supported in this version of FEATURE. */)
2882 (feature
, subfeatures
)
2883 Lisp_Object feature
, subfeatures
;
2885 register Lisp_Object tem
;
2886 CHECK_SYMBOL (feature
);
2887 CHECK_LIST (subfeatures
);
2888 if (!NILP (Vautoload_queue
))
2889 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2891 tem
= Fmemq (feature
, Vfeatures
);
2893 Vfeatures
= Fcons (feature
, Vfeatures
);
2894 if (!NILP (subfeatures
))
2895 Fput (feature
, Qsubfeatures
, subfeatures
);
2896 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2898 /* Run any load-hooks for this file. */
2899 tem
= Fassq (feature
, Vafter_load_alist
);
2901 Fprogn (XCDR (tem
));
2906 /* `require' and its subroutines. */
2908 /* List of features currently being require'd, innermost first. */
2910 Lisp_Object require_nesting_list
;
2913 require_unwind (old_value
)
2914 Lisp_Object old_value
;
2916 return require_nesting_list
= old_value
;
2919 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2920 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2921 If FEATURE is not a member of the list `features', then the feature
2922 is not loaded; so load the file FILENAME.
2923 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2924 and `load' will try to load this name appended with the suffix `.elc' or
2925 `.el', in that order. The name without appended suffix will not be used.
2926 If the optional third argument NOERROR is non-nil,
2927 then return nil if the file is not found instead of signaling an error.
2928 Normally the return value is FEATURE.
2929 The normal messages at start and end of loading FILENAME are suppressed. */)
2930 (feature
, filename
, noerror
)
2931 Lisp_Object feature
, filename
, noerror
;
2933 register Lisp_Object tem
;
2934 struct gcpro gcpro1
, gcpro2
;
2935 int from_file
= load_in_progress
;
2937 CHECK_SYMBOL (feature
);
2939 /* Record the presence of `require' in this file
2940 even if the feature specified is already loaded.
2941 But not more than once in any file,
2942 and not when we aren't loading or reading from a file. */
2944 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2945 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2950 tem
= Fcons (Qrequire
, feature
);
2951 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2952 LOADHIST_ATTACH (tem
);
2954 tem
= Fmemq (feature
, Vfeatures
);
2958 int count
= SPECPDL_INDEX ();
2961 /* This is to make sure that loadup.el gives a clear picture
2962 of what files are preloaded and when. */
2963 if (! NILP (Vpurify_flag
))
2964 error ("(require %s) while preparing to dump",
2965 SDATA (SYMBOL_NAME (feature
)));
2967 /* A certain amount of recursive `require' is legitimate,
2968 but if we require the same feature recursively 3 times,
2970 tem
= require_nesting_list
;
2971 while (! NILP (tem
))
2973 if (! NILP (Fequal (feature
, XCAR (tem
))))
2978 error ("Recursive `require' for feature `%s'",
2979 SDATA (SYMBOL_NAME (feature
)));
2981 /* Update the list for any nested `require's that occur. */
2982 record_unwind_protect (require_unwind
, require_nesting_list
);
2983 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2985 /* Value saved here is to be restored into Vautoload_queue */
2986 record_unwind_protect (un_autoload
, Vautoload_queue
);
2987 Vautoload_queue
= Qt
;
2989 /* Load the file. */
2990 GCPRO2 (feature
, filename
);
2991 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2992 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2995 /* If load failed entirely, return nil. */
2997 return unbind_to (count
, Qnil
);
2999 tem
= Fmemq (feature
, Vfeatures
);
3001 error ("Required feature `%s' was not provided",
3002 SDATA (SYMBOL_NAME (feature
)));
3004 /* Once loading finishes, don't undo it. */
3005 Vautoload_queue
= Qt
;
3006 feature
= unbind_to (count
, feature
);
3012 /* Primitives for work of the "widget" library.
3013 In an ideal world, this section would not have been necessary.
3014 However, lisp function calls being as slow as they are, it turns
3015 out that some functions in the widget library (wid-edit.el) are the
3016 bottleneck of Widget operation. Here is their translation to C,
3017 for the sole reason of efficiency. */
3019 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3020 doc
: /* Return non-nil if PLIST has the property PROP.
3021 PLIST is a property list, which is a list of the form
3022 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3023 Unlike `plist-get', this allows you to distinguish between a missing
3024 property and a property with the value nil.
3025 The value is actually the tail of PLIST whose car is PROP. */)
3027 Lisp_Object plist
, prop
;
3029 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3032 plist
= XCDR (plist
);
3033 plist
= CDR (plist
);
3038 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3039 doc
: /* In WIDGET, set PROPERTY to VALUE.
3040 The value can later be retrieved with `widget-get'. */)
3041 (widget
, property
, value
)
3042 Lisp_Object widget
, property
, value
;
3044 CHECK_CONS (widget
);
3045 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3049 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3050 doc
: /* In WIDGET, get the value of PROPERTY.
3051 The value could either be specified when the widget was created, or
3052 later with `widget-put'. */)
3054 Lisp_Object widget
, property
;
3062 CHECK_CONS (widget
);
3063 tmp
= Fplist_member (XCDR (widget
), property
);
3069 tmp
= XCAR (widget
);
3072 widget
= Fget (tmp
, Qwidget_type
);
3076 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3077 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3078 ARGS are passed as extra arguments to the function.
3079 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3084 /* This function can GC. */
3085 Lisp_Object newargs
[3];
3086 struct gcpro gcpro1
, gcpro2
;
3089 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3090 newargs
[1] = args
[0];
3091 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3092 GCPRO2 (newargs
[0], newargs
[2]);
3093 result
= Fapply (3, newargs
);
3098 #ifdef HAVE_LANGINFO_CODESET
3099 #include <langinfo.h>
3102 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3103 doc
: /* Access locale data ITEM for the current C locale, if available.
3104 ITEM should be one of the following:
3106 `codeset', returning the character set as a string (locale item CODESET);
3108 `days', returning a 7-element vector of day names (locale items DAY_n);
3110 `months', returning a 12-element vector of month names (locale items MON_n);
3112 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3113 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3115 If the system can't provide such information through a call to
3116 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3118 See also Info node `(libc)Locales'.
3120 The data read from the system are decoded using `locale-coding-system'. */)
3125 #ifdef HAVE_LANGINFO_CODESET
3127 if (EQ (item
, Qcodeset
))
3129 str
= nl_langinfo (CODESET
);
3130 return build_string (str
);
3133 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3135 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3136 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3138 synchronize_system_time_locale ();
3139 for (i
= 0; i
< 7; i
++)
3141 str
= nl_langinfo (days
[i
]);
3142 val
= make_unibyte_string (str
, strlen (str
));
3143 /* Fixme: Is this coding system necessarily right, even if
3144 it is consistent with CODESET? If not, what to do? */
3145 Faset (v
, make_number (i
),
3146 code_convert_string_norecord (val
, Vlocale_coding_system
,
3153 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3155 struct Lisp_Vector
*p
= allocate_vector (12);
3156 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3157 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3159 synchronize_system_time_locale ();
3160 for (i
= 0; i
< 12; i
++)
3162 str
= nl_langinfo (months
[i
]);
3163 val
= make_unibyte_string (str
, strlen (str
));
3165 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3167 XSETVECTOR (val
, p
);
3171 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3172 but is in the locale files. This could be used by ps-print. */
3174 else if (EQ (item
, Qpaper
))
3176 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3177 make_number (nl_langinfo (PAPER_HEIGHT
)));
3179 #endif /* PAPER_WIDTH */
3180 #endif /* HAVE_LANGINFO_CODESET*/
3184 /* base64 encode/decode functions (RFC 2045).
3185 Based on code from GNU recode. */
3187 #define MIME_LINE_LENGTH 76
3189 #define IS_ASCII(Character) \
3191 #define IS_BASE64(Character) \
3192 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3193 #define IS_BASE64_IGNORABLE(Character) \
3194 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3195 || (Character) == '\f' || (Character) == '\r')
3197 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3198 character or return retval if there are no characters left to
3200 #define READ_QUADRUPLET_BYTE(retval) \
3205 if (nchars_return) \
3206 *nchars_return = nchars; \
3211 while (IS_BASE64_IGNORABLE (c))
3213 /* Table of characters coding the 64 values. */
3214 static char base64_value_to_char
[64] =
3216 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3217 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3218 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3219 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3220 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3221 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3222 '8', '9', '+', '/' /* 60-63 */
3225 /* Table of base64 values for first 128 characters. */
3226 static short base64_char_to_value
[128] =
3228 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3229 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3230 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3231 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3232 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3233 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3234 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3235 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3236 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3237 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3238 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3239 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3240 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3243 /* The following diagram shows the logical steps by which three octets
3244 get transformed into four base64 characters.
3246 .--------. .--------. .--------.
3247 |aaaaaabb| |bbbbcccc| |ccdddddd|
3248 `--------' `--------' `--------'
3250 .--------+--------+--------+--------.
3251 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3252 `--------+--------+--------+--------'
3254 .--------+--------+--------+--------.
3255 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3256 `--------+--------+--------+--------'
3258 The octets are divided into 6 bit chunks, which are then encoded into
3259 base64 characters. */
3262 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3263 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3265 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3267 doc
: /* Base64-encode the region between BEG and END.
3268 Return the length of the encoded text.
3269 Optional third argument NO-LINE-BREAK means do not break long lines
3270 into shorter lines. */)
3271 (beg
, end
, no_line_break
)
3272 Lisp_Object beg
, end
, no_line_break
;
3275 int allength
, length
;
3276 int ibeg
, iend
, encoded_length
;
3280 validate_region (&beg
, &end
);
3282 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3283 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3284 move_gap_both (XFASTINT (beg
), ibeg
);
3286 /* We need to allocate enough room for encoding the text.
3287 We need 33 1/3% more space, plus a newline every 76
3288 characters, and then we round up. */
3289 length
= iend
- ibeg
;
3290 allength
= length
+ length
/3 + 1;
3291 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3293 SAFE_ALLOCA (encoded
, char *, allength
);
3294 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3295 NILP (no_line_break
),
3296 !NILP (current_buffer
->enable_multibyte_characters
));
3297 if (encoded_length
> allength
)
3300 if (encoded_length
< 0)
3302 /* The encoding wasn't possible. */
3304 error ("Multibyte character in data for base64 encoding");
3307 /* Now we have encoded the region, so we insert the new contents
3308 and delete the old. (Insert first in order to preserve markers.) */
3309 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3310 insert (encoded
, encoded_length
);
3312 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3314 /* If point was outside of the region, restore it exactly; else just
3315 move to the beginning of the region. */
3316 if (old_pos
>= XFASTINT (end
))
3317 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3318 else if (old_pos
> XFASTINT (beg
))
3319 old_pos
= XFASTINT (beg
);
3322 /* We return the length of the encoded text. */
3323 return make_number (encoded_length
);
3326 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3328 doc
: /* Base64-encode STRING and return the result.
3329 Optional second argument NO-LINE-BREAK means do not break long lines
3330 into shorter lines. */)
3331 (string
, no_line_break
)
3332 Lisp_Object string
, no_line_break
;
3334 int allength
, length
, encoded_length
;
3336 Lisp_Object encoded_string
;
3339 CHECK_STRING (string
);
3341 /* We need to allocate enough room for encoding the text.
3342 We need 33 1/3% more space, plus a newline every 76
3343 characters, and then we round up. */
3344 length
= SBYTES (string
);
3345 allength
= length
+ length
/3 + 1;
3346 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3348 /* We need to allocate enough room for decoding the text. */
3349 SAFE_ALLOCA (encoded
, char *, allength
);
3351 encoded_length
= base64_encode_1 (SDATA (string
),
3352 encoded
, length
, NILP (no_line_break
),
3353 STRING_MULTIBYTE (string
));
3354 if (encoded_length
> allength
)
3357 if (encoded_length
< 0)
3359 /* The encoding wasn't possible. */
3361 error ("Multibyte character in data for base64 encoding");
3364 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3367 return encoded_string
;
3371 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3378 int counter
= 0, i
= 0;
3388 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3389 if (CHAR_BYTE8_P (c
))
3390 c
= CHAR_TO_BYTE8 (c
);
3398 /* Wrap line every 76 characters. */
3402 if (counter
< MIME_LINE_LENGTH
/ 4)
3411 /* Process first byte of a triplet. */
3413 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3414 value
= (0x03 & c
) << 4;
3416 /* Process second byte of a triplet. */
3420 *e
++ = base64_value_to_char
[value
];
3428 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3429 if (CHAR_BYTE8_P (c
))
3430 c
= CHAR_TO_BYTE8 (c
);
3438 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3439 value
= (0x0f & c
) << 2;
3441 /* Process third byte of a triplet. */
3445 *e
++ = base64_value_to_char
[value
];
3452 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3453 if (CHAR_BYTE8_P (c
))
3454 c
= CHAR_TO_BYTE8 (c
);
3462 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3463 *e
++ = base64_value_to_char
[0x3f & c
];
3470 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3472 doc
: /* Base64-decode the region between BEG and END.
3473 Return the length of the decoded text.
3474 If the region can't be decoded, signal an error and don't modify the buffer. */)
3476 Lisp_Object beg
, end
;
3478 int ibeg
, iend
, length
, allength
;
3483 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3486 validate_region (&beg
, &end
);
3488 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3489 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3491 length
= iend
- ibeg
;
3493 /* We need to allocate enough room for decoding the text. If we are
3494 working on a multibyte buffer, each decoded code may occupy at
3496 allength
= multibyte
? length
* 2 : length
;
3497 SAFE_ALLOCA (decoded
, char *, allength
);
3499 move_gap_both (XFASTINT (beg
), ibeg
);
3500 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3501 multibyte
, &inserted_chars
);
3502 if (decoded_length
> allength
)
3505 if (decoded_length
< 0)
3507 /* The decoding wasn't possible. */
3509 error ("Invalid base64 data");
3512 /* Now we have decoded the region, so we insert the new contents
3513 and delete the old. (Insert first in order to preserve markers.) */
3514 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3515 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3518 /* Delete the original text. */
3519 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3520 iend
+ decoded_length
, 1);
3522 /* If point was outside of the region, restore it exactly; else just
3523 move to the beginning of the region. */
3524 if (old_pos
>= XFASTINT (end
))
3525 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3526 else if (old_pos
> XFASTINT (beg
))
3527 old_pos
= XFASTINT (beg
);
3528 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3530 return make_number (inserted_chars
);
3533 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3535 doc
: /* Base64-decode STRING and return the result. */)
3540 int length
, decoded_length
;
3541 Lisp_Object decoded_string
;
3544 CHECK_STRING (string
);
3546 length
= SBYTES (string
);
3547 /* We need to allocate enough room for decoding the text. */
3548 SAFE_ALLOCA (decoded
, char *, length
);
3550 /* The decoded result should be unibyte. */
3551 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3553 if (decoded_length
> length
)
3555 else if (decoded_length
>= 0)
3556 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3558 decoded_string
= Qnil
;
3561 if (!STRINGP (decoded_string
))
3562 error ("Invalid base64 data");
3564 return decoded_string
;
3567 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3568 MULTIBYTE is nonzero, the decoded result should be in multibyte
3569 form. If NCHARS_RETRUN is not NULL, store the number of produced
3570 characters in *NCHARS_RETURN. */
3573 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3583 unsigned long value
;
3588 /* Process first byte of a quadruplet. */
3590 READ_QUADRUPLET_BYTE (e
-to
);
3594 value
= base64_char_to_value
[c
] << 18;
3596 /* Process second byte of a quadruplet. */
3598 READ_QUADRUPLET_BYTE (-1);
3602 value
|= base64_char_to_value
[c
] << 12;
3604 c
= (unsigned char) (value
>> 16);
3605 if (multibyte
&& c
>= 128)
3606 e
+= BYTE8_STRING (c
, e
);
3611 /* Process third byte of a quadruplet. */
3613 READ_QUADRUPLET_BYTE (-1);
3617 READ_QUADRUPLET_BYTE (-1);
3626 value
|= base64_char_to_value
[c
] << 6;
3628 c
= (unsigned char) (0xff & value
>> 8);
3629 if (multibyte
&& c
>= 128)
3630 e
+= BYTE8_STRING (c
, e
);
3635 /* Process fourth byte of a quadruplet. */
3637 READ_QUADRUPLET_BYTE (-1);
3644 value
|= base64_char_to_value
[c
];
3646 c
= (unsigned char) (0xff & value
);
3647 if (multibyte
&& c
>= 128)
3648 e
+= BYTE8_STRING (c
, e
);
3657 /***********************************************************************
3659 ***** Hash Tables *****
3661 ***********************************************************************/
3663 /* Implemented by gerd@gnu.org. This hash table implementation was
3664 inspired by CMUCL hash tables. */
3668 1. For small tables, association lists are probably faster than
3669 hash tables because they have lower overhead.
3671 For uses of hash tables where the O(1) behavior of table
3672 operations is not a requirement, it might therefore be a good idea
3673 not to hash. Instead, we could just do a linear search in the
3674 key_and_value vector of the hash table. This could be done
3675 if a `:linear-search t' argument is given to make-hash-table. */
3678 /* The list of all weak hash tables. Don't staticpro this one. */
3680 struct Lisp_Hash_Table
*weak_hash_tables
;
3682 /* Various symbols. */
3684 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3685 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3686 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3688 /* Function prototypes. */
3690 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3691 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3692 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3693 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3694 Lisp_Object
, unsigned));
3695 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3696 Lisp_Object
, unsigned));
3697 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3698 unsigned, Lisp_Object
, unsigned));
3699 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3700 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3701 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3702 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3704 static unsigned sxhash_string
P_ ((unsigned char *, int));
3705 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3706 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3707 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3708 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3712 /***********************************************************************
3714 ***********************************************************************/
3716 /* If OBJ is a Lisp hash table, return a pointer to its struct
3717 Lisp_Hash_Table. Otherwise, signal an error. */
3719 static struct Lisp_Hash_Table
*
3720 check_hash_table (obj
)
3723 CHECK_HASH_TABLE (obj
);
3724 return XHASH_TABLE (obj
);
3728 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3732 next_almost_prime (n
)
3745 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3746 which USED[I] is non-zero. If found at index I in ARGS, set
3747 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3748 -1. This function is used to extract a keyword/argument pair from
3749 a DEFUN parameter list. */
3752 get_key_arg (key
, nargs
, args
, used
)
3760 for (i
= 0; i
< nargs
- 1; ++i
)
3761 if (!used
[i
] && EQ (args
[i
], key
))
3776 /* Return a Lisp vector which has the same contents as VEC but has
3777 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3778 vector that are not copied from VEC are set to INIT. */
3781 larger_vector (vec
, new_size
, init
)
3786 struct Lisp_Vector
*v
;
3789 xassert (VECTORP (vec
));
3790 old_size
= ASIZE (vec
);
3791 xassert (new_size
>= old_size
);
3793 v
= allocate_vector (new_size
);
3794 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3795 old_size
* sizeof *v
->contents
);
3796 for (i
= old_size
; i
< new_size
; ++i
)
3797 v
->contents
[i
] = init
;
3798 XSETVECTOR (vec
, v
);
3803 /***********************************************************************
3805 ***********************************************************************/
3807 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3808 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3809 KEY2 are the same. */
3812 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3813 struct Lisp_Hash_Table
*h
;
3814 Lisp_Object key1
, key2
;
3815 unsigned hash1
, hash2
;
3817 return (FLOATP (key1
)
3819 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3823 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3824 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3825 KEY2 are the same. */
3828 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3829 struct Lisp_Hash_Table
*h
;
3830 Lisp_Object key1
, key2
;
3831 unsigned hash1
, hash2
;
3833 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3837 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3838 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3839 if KEY1 and KEY2 are the same. */
3842 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3843 struct Lisp_Hash_Table
*h
;
3844 Lisp_Object key1
, key2
;
3845 unsigned hash1
, hash2
;
3849 Lisp_Object args
[3];
3851 args
[0] = h
->user_cmp_function
;
3854 return !NILP (Ffuncall (3, args
));
3861 /* Value is a hash code for KEY for use in hash table H which uses
3862 `eq' to compare keys. The hash code returned is guaranteed to fit
3863 in a Lisp integer. */
3867 struct Lisp_Hash_Table
*h
;
3870 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3871 xassert ((hash
& ~INTMASK
) == 0);
3876 /* Value is a hash code for KEY for use in hash table H which uses
3877 `eql' to compare keys. The hash code returned is guaranteed to fit
3878 in a Lisp integer. */
3882 struct Lisp_Hash_Table
*h
;
3887 hash
= sxhash (key
, 0);
3889 hash
= XUINT (key
) ^ XTYPE (key
);
3890 xassert ((hash
& ~INTMASK
) == 0);
3895 /* Value is a hash code for KEY for use in hash table H which uses
3896 `equal' to compare keys. The hash code returned is guaranteed to fit
3897 in a Lisp integer. */
3900 hashfn_equal (h
, key
)
3901 struct Lisp_Hash_Table
*h
;
3904 unsigned hash
= sxhash (key
, 0);
3905 xassert ((hash
& ~INTMASK
) == 0);
3910 /* Value is a hash code for KEY for use in hash table H which uses as
3911 user-defined function to compare keys. The hash code returned is
3912 guaranteed to fit in a Lisp integer. */
3915 hashfn_user_defined (h
, key
)
3916 struct Lisp_Hash_Table
*h
;
3919 Lisp_Object args
[2], hash
;
3921 args
[0] = h
->user_hash_function
;
3923 hash
= Ffuncall (2, args
);
3924 if (!INTEGERP (hash
))
3925 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3926 return XUINT (hash
);
3930 /* Create and initialize a new hash table.
3932 TEST specifies the test the hash table will use to compare keys.
3933 It must be either one of the predefined tests `eq', `eql' or
3934 `equal' or a symbol denoting a user-defined test named TEST with
3935 test and hash functions USER_TEST and USER_HASH.
3937 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3939 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3940 new size when it becomes full is computed by adding REHASH_SIZE to
3941 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3942 table's new size is computed by multiplying its old size with
3945 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3946 be resized when the ratio of (number of entries in the table) /
3947 (table size) is >= REHASH_THRESHOLD.
3949 WEAK specifies the weakness of the table. If non-nil, it must be
3950 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3953 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3954 user_test
, user_hash
)
3955 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3956 Lisp_Object user_test
, user_hash
;
3958 struct Lisp_Hash_Table
*h
;
3960 int index_size
, i
, sz
;
3962 /* Preconditions. */
3963 xassert (SYMBOLP (test
));
3964 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3965 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3966 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3967 xassert (FLOATP (rehash_threshold
)
3968 && XFLOATINT (rehash_threshold
) > 0
3969 && XFLOATINT (rehash_threshold
) <= 1.0);
3971 if (XFASTINT (size
) == 0)
3972 size
= make_number (1);
3974 /* Allocate a table and initialize it. */
3975 h
= allocate_hash_table ();
3977 /* Initialize hash table slots. */
3978 sz
= XFASTINT (size
);
3981 if (EQ (test
, Qeql
))
3983 h
->cmpfn
= cmpfn_eql
;
3984 h
->hashfn
= hashfn_eql
;
3986 else if (EQ (test
, Qeq
))
3989 h
->hashfn
= hashfn_eq
;
3991 else if (EQ (test
, Qequal
))
3993 h
->cmpfn
= cmpfn_equal
;
3994 h
->hashfn
= hashfn_equal
;
3998 h
->user_cmp_function
= user_test
;
3999 h
->user_hash_function
= user_hash
;
4000 h
->cmpfn
= cmpfn_user_defined
;
4001 h
->hashfn
= hashfn_user_defined
;
4005 h
->rehash_threshold
= rehash_threshold
;
4006 h
->rehash_size
= rehash_size
;
4008 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4009 h
->hash
= Fmake_vector (size
, Qnil
);
4010 h
->next
= Fmake_vector (size
, Qnil
);
4011 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4012 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4013 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4015 /* Set up the free list. */
4016 for (i
= 0; i
< sz
- 1; ++i
)
4017 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4018 h
->next_free
= make_number (0);
4020 XSET_HASH_TABLE (table
, h
);
4021 xassert (HASH_TABLE_P (table
));
4022 xassert (XHASH_TABLE (table
) == h
);
4024 /* Maybe add this hash table to the list of all weak hash tables. */
4026 h
->next_weak
= NULL
;
4029 h
->next_weak
= weak_hash_tables
;
4030 weak_hash_tables
= h
;
4037 /* Return a copy of hash table H1. Keys and values are not copied,
4038 only the table itself is. */
4041 copy_hash_table (h1
)
4042 struct Lisp_Hash_Table
*h1
;
4045 struct Lisp_Hash_Table
*h2
;
4046 struct Lisp_Vector
*next
;
4048 h2
= allocate_hash_table ();
4049 next
= h2
->vec_next
;
4050 bcopy (h1
, h2
, sizeof *h2
);
4051 h2
->vec_next
= next
;
4052 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4053 h2
->hash
= Fcopy_sequence (h1
->hash
);
4054 h2
->next
= Fcopy_sequence (h1
->next
);
4055 h2
->index
= Fcopy_sequence (h1
->index
);
4056 XSET_HASH_TABLE (table
, h2
);
4058 /* Maybe add this hash table to the list of all weak hash tables. */
4059 if (!NILP (h2
->weak
))
4061 h2
->next_weak
= weak_hash_tables
;
4062 weak_hash_tables
= h2
;
4069 /* Resize hash table H if it's too full. If H cannot be resized
4070 because it's already too large, throw an error. */
4073 maybe_resize_hash_table (h
)
4074 struct Lisp_Hash_Table
*h
;
4076 if (NILP (h
->next_free
))
4078 int old_size
= HASH_TABLE_SIZE (h
);
4079 int i
, new_size
, index_size
;
4082 if (INTEGERP (h
->rehash_size
))
4083 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4085 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4086 new_size
= max (old_size
+ 1, new_size
);
4087 index_size
= next_almost_prime ((int)
4089 / XFLOATINT (h
->rehash_threshold
)));
4090 /* Assignment to EMACS_INT stops GCC whining about limited range
4092 nsize
= max (index_size
, 2 * new_size
);
4093 if (nsize
> MOST_POSITIVE_FIXNUM
)
4094 error ("Hash table too large to resize");
4096 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4097 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4098 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4099 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4101 /* Update the free list. Do it so that new entries are added at
4102 the end of the free list. This makes some operations like
4104 for (i
= old_size
; i
< new_size
- 1; ++i
)
4105 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4107 if (!NILP (h
->next_free
))
4109 Lisp_Object last
, next
;
4111 last
= h
->next_free
;
4112 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4116 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4119 XSETFASTINT (h
->next_free
, old_size
);
4122 for (i
= 0; i
< old_size
; ++i
)
4123 if (!NILP (HASH_HASH (h
, i
)))
4125 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4126 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4127 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4128 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4134 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4135 the hash code of KEY. Value is the index of the entry in H
4136 matching KEY, or -1 if not found. */
4139 hash_lookup (h
, key
, hash
)
4140 struct Lisp_Hash_Table
*h
;
4145 int start_of_bucket
;
4148 hash_code
= h
->hashfn (h
, key
);
4152 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4153 idx
= HASH_INDEX (h
, start_of_bucket
);
4155 /* We need not gcpro idx since it's either an integer or nil. */
4158 int i
= XFASTINT (idx
);
4159 if (EQ (key
, HASH_KEY (h
, i
))
4161 && h
->cmpfn (h
, key
, hash_code
,
4162 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4164 idx
= HASH_NEXT (h
, i
);
4167 return NILP (idx
) ? -1 : XFASTINT (idx
);
4171 /* Put an entry into hash table H that associates KEY with VALUE.
4172 HASH is a previously computed hash code of KEY.
4173 Value is the index of the entry in H matching KEY. */
4176 hash_put (h
, key
, value
, hash
)
4177 struct Lisp_Hash_Table
*h
;
4178 Lisp_Object key
, value
;
4181 int start_of_bucket
, i
;
4183 xassert ((hash
& ~INTMASK
) == 0);
4185 /* Increment count after resizing because resizing may fail. */
4186 maybe_resize_hash_table (h
);
4189 /* Store key/value in the key_and_value vector. */
4190 i
= XFASTINT (h
->next_free
);
4191 h
->next_free
= HASH_NEXT (h
, i
);
4192 HASH_KEY (h
, i
) = key
;
4193 HASH_VALUE (h
, i
) = value
;
4195 /* Remember its hash code. */
4196 HASH_HASH (h
, i
) = make_number (hash
);
4198 /* Add new entry to its collision chain. */
4199 start_of_bucket
= hash
% ASIZE (h
->index
);
4200 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4201 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4206 /* Remove the entry matching KEY from hash table H, if there is one. */
4209 hash_remove_from_table (h
, key
)
4210 struct Lisp_Hash_Table
*h
;
4214 int start_of_bucket
;
4215 Lisp_Object idx
, prev
;
4217 hash_code
= h
->hashfn (h
, key
);
4218 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4219 idx
= HASH_INDEX (h
, start_of_bucket
);
4222 /* We need not gcpro idx, prev since they're either integers or nil. */
4225 int i
= XFASTINT (idx
);
4227 if (EQ (key
, HASH_KEY (h
, i
))
4229 && h
->cmpfn (h
, key
, hash_code
,
4230 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4232 /* Take entry out of collision chain. */
4234 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4236 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4238 /* Clear slots in key_and_value and add the slots to
4240 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4241 HASH_NEXT (h
, i
) = h
->next_free
;
4242 h
->next_free
= make_number (i
);
4244 xassert (h
->count
>= 0);
4250 idx
= HASH_NEXT (h
, i
);
4256 /* Clear hash table H. */
4260 struct Lisp_Hash_Table
*h
;
4264 int i
, size
= HASH_TABLE_SIZE (h
);
4266 for (i
= 0; i
< size
; ++i
)
4268 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4269 HASH_KEY (h
, i
) = Qnil
;
4270 HASH_VALUE (h
, i
) = Qnil
;
4271 HASH_HASH (h
, i
) = Qnil
;
4274 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4275 ASET (h
->index
, i
, Qnil
);
4277 h
->next_free
= make_number (0);
4284 /************************************************************************
4286 ************************************************************************/
4289 init_weak_hash_tables ()
4291 weak_hash_tables
= NULL
;
4294 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4295 entries from the table that don't survive the current GC.
4296 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4297 non-zero if anything was marked. */
4300 sweep_weak_table (h
, remove_entries_p
)
4301 struct Lisp_Hash_Table
*h
;
4302 int remove_entries_p
;
4304 int bucket
, n
, marked
;
4306 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4309 for (bucket
= 0; bucket
< n
; ++bucket
)
4311 Lisp_Object idx
, next
, prev
;
4313 /* Follow collision chain, removing entries that
4314 don't survive this garbage collection. */
4316 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4318 int i
= XFASTINT (idx
);
4319 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4320 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4323 if (EQ (h
->weak
, Qkey
))
4324 remove_p
= !key_known_to_survive_p
;
4325 else if (EQ (h
->weak
, Qvalue
))
4326 remove_p
= !value_known_to_survive_p
;
4327 else if (EQ (h
->weak
, Qkey_or_value
))
4328 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4329 else if (EQ (h
->weak
, Qkey_and_value
))
4330 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4334 next
= HASH_NEXT (h
, i
);
4336 if (remove_entries_p
)
4340 /* Take out of collision chain. */
4342 HASH_INDEX (h
, bucket
) = next
;
4344 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4346 /* Add to free list. */
4347 HASH_NEXT (h
, i
) = h
->next_free
;
4350 /* Clear key, value, and hash. */
4351 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4352 HASH_HASH (h
, i
) = Qnil
;
4365 /* Make sure key and value survive. */
4366 if (!key_known_to_survive_p
)
4368 mark_object (HASH_KEY (h
, i
));
4372 if (!value_known_to_survive_p
)
4374 mark_object (HASH_VALUE (h
, i
));
4385 /* Remove elements from weak hash tables that don't survive the
4386 current garbage collection. Remove weak tables that don't survive
4387 from Vweak_hash_tables. Called from gc_sweep. */
4390 sweep_weak_hash_tables ()
4392 struct Lisp_Hash_Table
*h
, *used
, *next
;
4395 /* Mark all keys and values that are in use. Keep on marking until
4396 there is no more change. This is necessary for cases like
4397 value-weak table A containing an entry X -> Y, where Y is used in a
4398 key-weak table B, Z -> Y. If B comes after A in the list of weak
4399 tables, X -> Y might be removed from A, although when looking at B
4400 one finds that it shouldn't. */
4404 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4406 if (h
->size
& ARRAY_MARK_FLAG
)
4407 marked
|= sweep_weak_table (h
, 0);
4412 /* Remove tables and entries that aren't used. */
4413 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4415 next
= h
->next_weak
;
4417 if (h
->size
& ARRAY_MARK_FLAG
)
4419 /* TABLE is marked as used. Sweep its contents. */
4421 sweep_weak_table (h
, 1);
4423 /* Add table to the list of used weak hash tables. */
4424 h
->next_weak
= used
;
4429 weak_hash_tables
= used
;
4434 /***********************************************************************
4435 Hash Code Computation
4436 ***********************************************************************/
4438 /* Maximum depth up to which to dive into Lisp structures. */
4440 #define SXHASH_MAX_DEPTH 3
4442 /* Maximum length up to which to take list and vector elements into
4445 #define SXHASH_MAX_LEN 7
4447 /* Combine two integers X and Y for hashing. */
4449 #define SXHASH_COMBINE(X, Y) \
4450 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4454 /* Return a hash for string PTR which has length LEN. The hash
4455 code returned is guaranteed to fit in a Lisp integer. */
4458 sxhash_string (ptr
, len
)
4462 unsigned char *p
= ptr
;
4463 unsigned char *end
= p
+ len
;
4472 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4475 return hash
& INTMASK
;
4479 /* Return a hash for list LIST. DEPTH is the current depth in the
4480 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4483 sxhash_list (list
, depth
)
4490 if (depth
< SXHASH_MAX_DEPTH
)
4492 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4493 list
= XCDR (list
), ++i
)
4495 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4496 hash
= SXHASH_COMBINE (hash
, hash2
);
4501 unsigned hash2
= sxhash (list
, depth
+ 1);
4502 hash
= SXHASH_COMBINE (hash
, hash2
);
4509 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4510 the Lisp structure. */
4513 sxhash_vector (vec
, depth
)
4517 unsigned hash
= ASIZE (vec
);
4520 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4521 for (i
= 0; i
< n
; ++i
)
4523 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4524 hash
= SXHASH_COMBINE (hash
, hash2
);
4531 /* Return a hash for bool-vector VECTOR. */
4534 sxhash_bool_vector (vec
)
4537 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4540 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4541 for (i
= 0; i
< n
; ++i
)
4542 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4548 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4549 structure. Value is an unsigned integer clipped to INTMASK. */
4558 if (depth
> SXHASH_MAX_DEPTH
)
4561 switch (XTYPE (obj
))
4572 obj
= SYMBOL_NAME (obj
);
4576 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4579 /* This can be everything from a vector to an overlay. */
4580 case Lisp_Vectorlike
:
4582 /* According to the CL HyperSpec, two arrays are equal only if
4583 they are `eq', except for strings and bit-vectors. In
4584 Emacs, this works differently. We have to compare element
4586 hash
= sxhash_vector (obj
, depth
);
4587 else if (BOOL_VECTOR_P (obj
))
4588 hash
= sxhash_bool_vector (obj
);
4590 /* Others are `equal' if they are `eq', so let's take their
4596 hash
= sxhash_list (obj
, depth
);
4601 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4602 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4603 for (hash
= 0; p
< e
; ++p
)
4604 hash
= SXHASH_COMBINE (hash
, *p
);
4612 return hash
& INTMASK
;
4617 /***********************************************************************
4619 ***********************************************************************/
4622 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4623 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4627 unsigned hash
= sxhash (obj
, 0);
4628 return make_number (hash
);
4632 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4633 doc
: /* Create and return a new hash table.
4635 Arguments are specified as keyword/argument pairs. The following
4636 arguments are defined:
4638 :test TEST -- TEST must be a symbol that specifies how to compare
4639 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4640 `equal'. User-supplied test and hash functions can be specified via
4641 `define-hash-table-test'.
4643 :size SIZE -- A hint as to how many elements will be put in the table.
4646 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4647 fills up. If REHASH-SIZE is an integer, add that many space. If it
4648 is a float, it must be > 1.0, and the new size is computed by
4649 multiplying the old size with that factor. Default is 1.5.
4651 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4652 Resize the hash table when ratio of the number of entries in the
4653 table. Default is 0.8.
4655 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4656 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4657 returned is a weak table. Key/value pairs are removed from a weak
4658 hash table when there are no non-weak references pointing to their
4659 key, value, one of key or value, or both key and value, depending on
4660 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4663 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4668 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4669 Lisp_Object user_test
, user_hash
;
4673 /* The vector `used' is used to keep track of arguments that
4674 have been consumed. */
4675 used
= (char *) alloca (nargs
* sizeof *used
);
4676 bzero (used
, nargs
* sizeof *used
);
4678 /* See if there's a `:test TEST' among the arguments. */
4679 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4680 test
= i
< 0 ? Qeql
: args
[i
];
4681 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4683 /* See if it is a user-defined test. */
4686 prop
= Fget (test
, Qhash_table_test
);
4687 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4688 signal_error ("Invalid hash table test", test
);
4689 user_test
= XCAR (prop
);
4690 user_hash
= XCAR (XCDR (prop
));
4693 user_test
= user_hash
= Qnil
;
4695 /* See if there's a `:size SIZE' argument. */
4696 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4697 size
= i
< 0 ? Qnil
: args
[i
];
4699 size
= make_number (DEFAULT_HASH_SIZE
);
4700 else if (!INTEGERP (size
) || XINT (size
) < 0)
4701 signal_error ("Invalid hash table size", size
);
4703 /* Look for `:rehash-size SIZE'. */
4704 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4705 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4706 if (!NUMBERP (rehash_size
)
4707 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4708 || XFLOATINT (rehash_size
) <= 1.0)
4709 signal_error ("Invalid hash table rehash size", rehash_size
);
4711 /* Look for `:rehash-threshold THRESHOLD'. */
4712 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4713 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4714 if (!FLOATP (rehash_threshold
)
4715 || XFLOATINT (rehash_threshold
) <= 0.0
4716 || XFLOATINT (rehash_threshold
) > 1.0)
4717 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4719 /* Look for `:weakness WEAK'. */
4720 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4721 weak
= i
< 0 ? Qnil
: args
[i
];
4723 weak
= Qkey_and_value
;
4726 && !EQ (weak
, Qvalue
)
4727 && !EQ (weak
, Qkey_or_value
)
4728 && !EQ (weak
, Qkey_and_value
))
4729 signal_error ("Invalid hash table weakness", weak
);
4731 /* Now, all args should have been used up, or there's a problem. */
4732 for (i
= 0; i
< nargs
; ++i
)
4734 signal_error ("Invalid argument list", args
[i
]);
4736 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4737 user_test
, user_hash
);
4741 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4742 doc
: /* Return a copy of hash table TABLE. */)
4746 return copy_hash_table (check_hash_table (table
));
4750 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4751 doc
: /* Return the number of elements in TABLE. */)
4755 return make_number (check_hash_table (table
)->count
);
4759 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4760 Shash_table_rehash_size
, 1, 1, 0,
4761 doc
: /* Return the current rehash size of TABLE. */)
4765 return check_hash_table (table
)->rehash_size
;
4769 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4770 Shash_table_rehash_threshold
, 1, 1, 0,
4771 doc
: /* Return the current rehash threshold of TABLE. */)
4775 return check_hash_table (table
)->rehash_threshold
;
4779 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4780 doc
: /* Return the size of TABLE.
4781 The size can be used as an argument to `make-hash-table' to create
4782 a hash table than can hold as many elements of TABLE holds
4783 without need for resizing. */)
4787 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4788 return make_number (HASH_TABLE_SIZE (h
));
4792 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4793 doc
: /* Return the test TABLE uses. */)
4797 return check_hash_table (table
)->test
;
4801 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4803 doc
: /* Return the weakness of TABLE. */)
4807 return check_hash_table (table
)->weak
;
4811 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4812 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4816 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4820 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4821 doc
: /* Clear hash table TABLE and return it. */)
4825 hash_clear (check_hash_table (table
));
4826 /* Be compatible with XEmacs. */
4831 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4832 doc
: /* Look up KEY in TABLE and return its associated value.
4833 If KEY is not found, return DFLT which defaults to nil. */)
4835 Lisp_Object key
, table
, dflt
;
4837 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4838 int i
= hash_lookup (h
, key
, NULL
);
4839 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4843 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4844 doc
: /* Associate KEY with VALUE in hash table TABLE.
4845 If KEY is already present in table, replace its current value with
4848 Lisp_Object key
, value
, table
;
4850 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4854 i
= hash_lookup (h
, key
, &hash
);
4856 HASH_VALUE (h
, i
) = value
;
4858 hash_put (h
, key
, value
, hash
);
4864 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4865 doc
: /* Remove KEY from TABLE. */)
4867 Lisp_Object key
, table
;
4869 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4870 hash_remove_from_table (h
, key
);
4875 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4876 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4877 FUNCTION is called with two arguments, KEY and VALUE. */)
4879 Lisp_Object function
, table
;
4881 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4882 Lisp_Object args
[3];
4885 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4886 if (!NILP (HASH_HASH (h
, i
)))
4889 args
[1] = HASH_KEY (h
, i
);
4890 args
[2] = HASH_VALUE (h
, i
);
4898 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4899 Sdefine_hash_table_test
, 3, 3, 0,
4900 doc
: /* Define a new hash table test with name NAME, a symbol.
4902 In hash tables created with NAME specified as test, use TEST to
4903 compare keys, and HASH for computing hash codes of keys.
4905 TEST must be a function taking two arguments and returning non-nil if
4906 both arguments are the same. HASH must be a function taking one
4907 argument and return an integer that is the hash code of the argument.
4908 Hash code computation should use the whole value range of integers,
4909 including negative integers. */)
4911 Lisp_Object name
, test
, hash
;
4913 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4918 /************************************************************************
4920 ************************************************************************/
4924 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4925 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4927 A message digest is a cryptographic checksum of a document, and the
4928 algorithm to calculate it is defined in RFC 1321.
4930 The two optional arguments START and END are character positions
4931 specifying for which part of OBJECT the message digest should be
4932 computed. If nil or omitted, the digest is computed for the whole
4935 The MD5 message digest is computed from the result of encoding the
4936 text in a coding system, not directly from the internal Emacs form of
4937 the text. The optional fourth argument CODING-SYSTEM specifies which
4938 coding system to encode the text with. It should be the same coding
4939 system that you used or will use when actually writing the text into a
4942 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4943 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4944 system would be chosen by default for writing this text into a file.
4946 If OBJECT is a string, the most preferred coding system (see the
4947 command `prefer-coding-system') is used.
4949 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4950 guesswork fails. Normally, an error is signaled in such case. */)
4951 (object
, start
, end
, coding_system
, noerror
)
4952 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4954 unsigned char digest
[16];
4955 unsigned char value
[33];
4959 int start_char
= 0, end_char
= 0;
4960 int start_byte
= 0, end_byte
= 0;
4962 register struct buffer
*bp
;
4965 if (STRINGP (object
))
4967 if (NILP (coding_system
))
4969 /* Decide the coding-system to encode the data with. */
4971 if (STRING_MULTIBYTE (object
))
4972 /* use default, we can't guess correct value */
4973 coding_system
= preferred_coding_system ();
4975 coding_system
= Qraw_text
;
4978 if (NILP (Fcoding_system_p (coding_system
)))
4980 /* Invalid coding system. */
4982 if (!NILP (noerror
))
4983 coding_system
= Qraw_text
;
4985 xsignal1 (Qcoding_system_error
, coding_system
);
4988 if (STRING_MULTIBYTE (object
))
4989 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4991 size
= SCHARS (object
);
4992 size_byte
= SBYTES (object
);
4996 CHECK_NUMBER (start
);
4998 start_char
= XINT (start
);
5003 start_byte
= string_char_to_byte (object
, start_char
);
5009 end_byte
= size_byte
;
5015 end_char
= XINT (end
);
5020 end_byte
= string_char_to_byte (object
, end_char
);
5023 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5024 args_out_of_range_3 (object
, make_number (start_char
),
5025 make_number (end_char
));
5029 struct buffer
*prev
= current_buffer
;
5031 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5033 CHECK_BUFFER (object
);
5035 bp
= XBUFFER (object
);
5036 if (bp
!= current_buffer
)
5037 set_buffer_internal (bp
);
5043 CHECK_NUMBER_COERCE_MARKER (start
);
5051 CHECK_NUMBER_COERCE_MARKER (end
);
5056 temp
= b
, b
= e
, e
= temp
;
5058 if (!(BEGV
<= b
&& e
<= ZV
))
5059 args_out_of_range (start
, end
);
5061 if (NILP (coding_system
))
5063 /* Decide the coding-system to encode the data with.
5064 See fileio.c:Fwrite-region */
5066 if (!NILP (Vcoding_system_for_write
))
5067 coding_system
= Vcoding_system_for_write
;
5070 int force_raw_text
= 0;
5072 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5073 if (NILP (coding_system
)
5074 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5076 coding_system
= Qnil
;
5077 if (NILP (current_buffer
->enable_multibyte_characters
))
5081 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5083 /* Check file-coding-system-alist. */
5084 Lisp_Object args
[4], val
;
5086 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5087 args
[3] = Fbuffer_file_name(object
);
5088 val
= Ffind_operation_coding_system (4, args
);
5089 if (CONSP (val
) && !NILP (XCDR (val
)))
5090 coding_system
= XCDR (val
);
5093 if (NILP (coding_system
)
5094 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5096 /* If we still have not decided a coding system, use the
5097 default value of buffer-file-coding-system. */
5098 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5102 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5103 /* Confirm that VAL can surely encode the current region. */
5104 coding_system
= call4 (Vselect_safe_coding_system_function
,
5105 make_number (b
), make_number (e
),
5106 coding_system
, Qnil
);
5109 coding_system
= Qraw_text
;
5112 if (NILP (Fcoding_system_p (coding_system
)))
5114 /* Invalid coding system. */
5116 if (!NILP (noerror
))
5117 coding_system
= Qraw_text
;
5119 xsignal1 (Qcoding_system_error
, coding_system
);
5123 object
= make_buffer_string (b
, e
, 0);
5124 if (prev
!= current_buffer
)
5125 set_buffer_internal (prev
);
5126 /* Discard the unwind protect for recovering the current
5130 if (STRING_MULTIBYTE (object
))
5131 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5134 md5_buffer (SDATA (object
) + start_byte
,
5135 SBYTES (object
) - (size_byte
- end_byte
),
5138 for (i
= 0; i
< 16; i
++)
5139 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5142 return make_string (value
, 32);
5149 /* Hash table stuff. */
5150 Qhash_table_p
= intern ("hash-table-p");
5151 staticpro (&Qhash_table_p
);
5152 Qeq
= intern ("eq");
5154 Qeql
= intern ("eql");
5156 Qequal
= intern ("equal");
5157 staticpro (&Qequal
);
5158 QCtest
= intern (":test");
5159 staticpro (&QCtest
);
5160 QCsize
= intern (":size");
5161 staticpro (&QCsize
);
5162 QCrehash_size
= intern (":rehash-size");
5163 staticpro (&QCrehash_size
);
5164 QCrehash_threshold
= intern (":rehash-threshold");
5165 staticpro (&QCrehash_threshold
);
5166 QCweakness
= intern (":weakness");
5167 staticpro (&QCweakness
);
5168 Qkey
= intern ("key");
5170 Qvalue
= intern ("value");
5171 staticpro (&Qvalue
);
5172 Qhash_table_test
= intern ("hash-table-test");
5173 staticpro (&Qhash_table_test
);
5174 Qkey_or_value
= intern ("key-or-value");
5175 staticpro (&Qkey_or_value
);
5176 Qkey_and_value
= intern ("key-and-value");
5177 staticpro (&Qkey_and_value
);
5180 defsubr (&Smake_hash_table
);
5181 defsubr (&Scopy_hash_table
);
5182 defsubr (&Shash_table_count
);
5183 defsubr (&Shash_table_rehash_size
);
5184 defsubr (&Shash_table_rehash_threshold
);
5185 defsubr (&Shash_table_size
);
5186 defsubr (&Shash_table_test
);
5187 defsubr (&Shash_table_weakness
);
5188 defsubr (&Shash_table_p
);
5189 defsubr (&Sclrhash
);
5190 defsubr (&Sgethash
);
5191 defsubr (&Sputhash
);
5192 defsubr (&Sremhash
);
5193 defsubr (&Smaphash
);
5194 defsubr (&Sdefine_hash_table_test
);
5196 Qstring_lessp
= intern ("string-lessp");
5197 staticpro (&Qstring_lessp
);
5198 Qprovide
= intern ("provide");
5199 staticpro (&Qprovide
);
5200 Qrequire
= intern ("require");
5201 staticpro (&Qrequire
);
5202 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5203 staticpro (&Qyes_or_no_p_history
);
5204 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5205 staticpro (&Qcursor_in_echo_area
);
5206 Qwidget_type
= intern ("widget-type");
5207 staticpro (&Qwidget_type
);
5209 staticpro (&string_char_byte_cache_string
);
5210 string_char_byte_cache_string
= Qnil
;
5212 require_nesting_list
= Qnil
;
5213 staticpro (&require_nesting_list
);
5215 Fset (Qyes_or_no_p_history
, Qnil
);
5217 DEFVAR_LISP ("features", &Vfeatures
,
5218 doc
: /* A list of symbols which are the features of the executing Emacs.
5219 Used by `featurep' and `require', and altered by `provide'. */);
5220 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5221 Qsubfeatures
= intern ("subfeatures");
5222 staticpro (&Qsubfeatures
);
5224 #ifdef HAVE_LANGINFO_CODESET
5225 Qcodeset
= intern ("codeset");
5226 staticpro (&Qcodeset
);
5227 Qdays
= intern ("days");
5229 Qmonths
= intern ("months");
5230 staticpro (&Qmonths
);
5231 Qpaper
= intern ("paper");
5232 staticpro (&Qpaper
);
5233 #endif /* HAVE_LANGINFO_CODESET */
5235 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5236 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5237 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5238 invoked by mouse clicks and mouse menu items.
5240 On some platforms, file selection dialogs are also enabled if this is
5244 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5245 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5246 This applies to commands from menus and tool bar buttons even when
5247 they are initiated from the keyboard. The value of `use-dialog-box'
5248 takes precedence over this variable, so a file dialog is only used if
5249 both `use-dialog-box' and this variable are non-nil. */);
5250 use_file_dialog
= 1;
5252 defsubr (&Sidentity
);
5255 defsubr (&Ssafe_length
);
5256 defsubr (&Sstring_bytes
);
5257 defsubr (&Sstring_equal
);
5258 defsubr (&Scompare_strings
);
5259 defsubr (&Sstring_lessp
);
5262 defsubr (&Svconcat
);
5263 defsubr (&Scopy_sequence
);
5264 defsubr (&Sstring_make_multibyte
);
5265 defsubr (&Sstring_make_unibyte
);
5266 defsubr (&Sstring_as_multibyte
);
5267 defsubr (&Sstring_as_unibyte
);
5268 defsubr (&Sstring_to_multibyte
);
5269 defsubr (&Sstring_to_unibyte
);
5270 defsubr (&Scopy_alist
);
5271 defsubr (&Ssubstring
);
5272 defsubr (&Ssubstring_no_properties
);
5285 defsubr (&Snreverse
);
5286 defsubr (&Sreverse
);
5288 defsubr (&Splist_get
);
5290 defsubr (&Splist_put
);
5292 defsubr (&Slax_plist_get
);
5293 defsubr (&Slax_plist_put
);
5296 defsubr (&Sequal_including_properties
);
5297 defsubr (&Sfillarray
);
5298 defsubr (&Sclear_string
);
5302 defsubr (&Smapconcat
);
5303 defsubr (&Sy_or_n_p
);
5304 defsubr (&Syes_or_no_p
);
5305 defsubr (&Sload_average
);
5306 defsubr (&Sfeaturep
);
5307 defsubr (&Srequire
);
5308 defsubr (&Sprovide
);
5309 defsubr (&Splist_member
);
5310 defsubr (&Swidget_put
);
5311 defsubr (&Swidget_get
);
5312 defsubr (&Swidget_apply
);
5313 defsubr (&Sbase64_encode_region
);
5314 defsubr (&Sbase64_decode_region
);
5315 defsubr (&Sbase64_encode_string
);
5316 defsubr (&Sbase64_decode_string
);
5318 defsubr (&Slocale_info
);
5327 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5328 (do not change this comment) */