1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
36 #include "character.h"
41 #include "intervals.h"
44 #include "blockinput.h"
46 #if defined (HAVE_X_WINDOWS)
49 #endif /* HAVE_MENUS */
52 #define NULL ((POINTER_TYPE *)0)
55 /* Nonzero enables use of dialog boxes for questions
56 asked by mouse commands. */
59 /* Nonzero enables use of a file dialog for file name
60 questions asked by mouse commands. */
63 extern int minibuffer_auto_raise
;
64 extern Lisp_Object minibuf_window
;
65 extern Lisp_Object impl_Vlocale_coding_system
;
66 extern int load_in_progress
;
68 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
69 Lisp_Object Qyes_or_no_p_history
;
70 Lisp_Object Qcursor_in_echo_area
;
71 Lisp_Object Qwidget_type
;
72 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
74 extern Lisp_Object Qinput_method_function
;
76 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
78 extern long get_random ();
79 extern void seed_random
P_ ((long));
81 static Lisp_Object
Fyes_or_no1 (Lisp_Object prompt
);
87 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
88 doc
: /* Return the argument unchanged. */)
95 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
96 doc
: /* Return a pseudo-random number.
97 All integers representable in Lisp are equally likely.
98 On most systems, this is 29 bits' worth.
99 With positive integer LIMIT, return random number in interval [0,LIMIT).
100 With argument t, set the random number seed from the current time and pid.
101 Other values of LIMIT are ignored. */)
106 Lisp_Object lispy_val
;
107 unsigned long denominator
;
110 seed_random (getpid () + time (NULL
));
111 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
113 /* Try to take our random number from the higher bits of VAL,
114 not the lower, since (says Gentzel) the low bits of `random'
115 are less random than the higher ones. We do this by using the
116 quotient rather than the remainder. At the high end of the RNG
117 it's possible to get a quotient larger than n; discarding
118 these values eliminates the bias that would otherwise appear
119 when using a large n. */
120 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
122 val
= get_random () / denominator
;
123 while (val
>= XFASTINT (limit
));
127 XSETINT (lispy_val
, val
);
131 /* Random data-structure functions */
133 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
134 doc
: /* Return the length of vector, list or string SEQUENCE.
135 A byte-code function object is also allowed.
136 If the string contains multibyte characters, this is not necessarily
137 the number of bytes in the string; it is the number of characters.
138 To get the number of bytes, use `string-bytes'. */)
140 register Lisp_Object sequence
;
142 register Lisp_Object val
;
145 if (STRINGP (sequence
))
146 XSETFASTINT (val
, SCHARS (sequence
));
147 else if (VECTORP (sequence
))
148 XSETFASTINT (val
, ASIZE (sequence
));
149 else if (CHAR_TABLE_P (sequence
))
150 XSETFASTINT (val
, MAX_CHAR
);
151 else if (BOOL_VECTOR_P (sequence
))
152 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
153 else if (COMPILEDP (sequence
))
154 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
155 else if (CONSP (sequence
))
158 while (CONSP (sequence
))
160 sequence
= XCDR (sequence
);
163 if (!CONSP (sequence
))
166 sequence
= XCDR (sequence
);
171 CHECK_LIST_END (sequence
, sequence
);
173 val
= make_number (i
);
175 else if (NILP (sequence
))
176 XSETFASTINT (val
, 0);
178 wrong_type_argument (Qsequencep
, sequence
);
183 /* This does not check for quits. That is safe since it must terminate. */
185 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
186 doc
: /* Return the length of a list, but avoid error or infinite loop.
187 This function never gets an error. If LIST is not really a list,
188 it returns 0. If LIST is circular, it returns a finite value
189 which is at least the number of distinct elements. */)
193 Lisp_Object tail
, halftail
, length
;
196 /* halftail is used to detect circular lists. */
198 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
200 if (EQ (tail
, halftail
) && len
!= 0)
204 halftail
= XCDR (halftail
);
207 XSETINT (length
, len
);
211 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
212 doc
: /* Return the number of bytes in STRING.
213 If STRING is multibyte, this may be greater than the length of STRING. */)
217 CHECK_STRING (string
);
218 return make_number (SBYTES (string
));
221 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
222 doc
: /* Return t if two strings have identical contents.
223 Case is significant, but text properties are ignored.
224 Symbols are also allowed; their print names are used instead. */)
226 register Lisp_Object s1
, s2
;
229 s1
= SYMBOL_NAME (s1
);
231 s2
= SYMBOL_NAME (s2
);
235 if (SCHARS (s1
) != SCHARS (s2
)
236 || SBYTES (s1
) != SBYTES (s2
)
237 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
242 DEFUN ("compare-strings", Fcompare_strings
,
243 Scompare_strings
, 6, 7, 0,
244 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
245 In string STR1, skip the first START1 characters and stop at END1.
246 In string STR2, skip the first START2 characters and stop at END2.
247 END1 and END2 default to the full lengths of the respective strings.
249 Case is significant in this comparison if IGNORE-CASE is nil.
250 Unibyte strings are converted to multibyte for comparison.
252 The value is t if the strings (or specified portions) match.
253 If string STR1 is less, the value is a negative number N;
254 - 1 - N is the number of characters that match at the beginning.
255 If string STR1 is greater, the value is a positive number N;
256 N - 1 is the number of characters that match at the beginning. */)
257 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
258 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
260 register int end1_char
, end2_char
;
261 register int i1
, i1_byte
, i2
, i2_byte
;
266 start1
= make_number (0);
268 start2
= make_number (0);
269 CHECK_NATNUM (start1
);
270 CHECK_NATNUM (start2
);
279 i1_byte
= string_char_to_byte (str1
, i1
);
280 i2_byte
= string_char_to_byte (str2
, i2
);
282 end1_char
= SCHARS (str1
);
283 if (! NILP (end1
) && end1_char
> XINT (end1
))
284 end1_char
= XINT (end1
);
286 end2_char
= SCHARS (str2
);
287 if (! NILP (end2
) && end2_char
> XINT (end2
))
288 end2_char
= XINT (end2
);
290 while (i1
< end1_char
&& i2
< end2_char
)
292 /* When we find a mismatch, we must compare the
293 characters, not just the bytes. */
296 if (STRING_MULTIBYTE (str1
))
297 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
300 c1
= SREF (str1
, i1
++);
301 MAKE_CHAR_MULTIBYTE (c1
);
304 if (STRING_MULTIBYTE (str2
))
305 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
308 c2
= SREF (str2
, i2
++);
309 MAKE_CHAR_MULTIBYTE (c2
);
315 if (! NILP (ignore_case
))
319 tem
= Fupcase (make_number (c1
));
321 tem
= Fupcase (make_number (c2
));
328 /* Note that I1 has already been incremented
329 past the character that we are comparing;
330 hence we don't add or subtract 1 here. */
332 return make_number (- i1
+ XINT (start1
));
334 return make_number (i1
- XINT (start1
));
338 return make_number (i1
- XINT (start1
) + 1);
340 return make_number (- i1
+ XINT (start1
) - 1);
345 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
346 doc
: /* Return t if first arg string is less than second in lexicographic order.
348 Symbols are also allowed; their print names are used instead. */)
350 register Lisp_Object s1
, s2
;
353 register int i1
, i1_byte
, i2
, i2_byte
;
356 s1
= SYMBOL_NAME (s1
);
358 s2
= SYMBOL_NAME (s2
);
362 i1
= i1_byte
= i2
= i2_byte
= 0;
365 if (end
> SCHARS (s2
))
370 /* When we find a mismatch, we must compare the
371 characters, not just the bytes. */
374 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
375 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
378 return c1
< c2
? Qt
: Qnil
;
380 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
384 /* "gcc -O3" enables automatic function inlining, which optimizes out
385 the arguments for the invocations of this function, whereas it
386 expects these values on the stack. */
387 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
388 #else /* !__GNUC__ */
389 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
401 return concat (2, args
, Lisp_String
, 0);
403 return concat (2, &s1
, Lisp_String
, 0);
404 #endif /* NO_ARG_ARRAY */
410 Lisp_Object s1
, s2
, s3
;
417 return concat (3, args
, Lisp_String
, 0);
419 return concat (3, &s1
, Lisp_String
, 0);
420 #endif /* NO_ARG_ARRAY */
423 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
424 doc
: /* Concatenate all the arguments and make the result a list.
425 The result is a list whose elements are the elements of all the arguments.
426 Each argument may be a list, vector or string.
427 The last argument is not copied, just used as the tail of the new list.
428 usage: (append &rest SEQUENCES) */)
433 return concat (nargs
, args
, Lisp_Cons
, 1);
436 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
437 doc
: /* Concatenate all the arguments and make the result a string.
438 The result is a string whose elements are the elements of all the arguments.
439 Each argument may be a string or a list or vector of characters (integers).
440 usage: (concat &rest SEQUENCES) */)
445 return concat (nargs
, args
, Lisp_String
, 0);
448 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
449 doc
: /* Concatenate all the arguments and make the result a vector.
450 The result is a vector whose elements are the elements of all the arguments.
451 Each argument may be a list, vector or string.
452 usage: (vconcat &rest SEQUENCES) */)
457 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
461 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
462 doc
: /* Return a copy of a list, vector, string or char-table.
463 The elements of a list or vector are not copied; they are shared
464 with the original. */)
468 if (NILP (arg
)) return arg
;
470 if (CHAR_TABLE_P (arg
))
472 return copy_char_table (arg
);
475 if (BOOL_VECTOR_P (arg
))
479 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
480 / BOOL_VECTOR_BITS_PER_CHAR
);
482 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
483 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
488 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
489 wrong_type_argument (Qsequencep
, arg
);
491 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
494 /* This structure holds information of an argument of `concat' that is
495 a string and has text properties to be copied. */
498 int argnum
; /* refer to ARGS (arguments of `concat') */
499 int from
; /* refer to ARGS[argnum] (argument string) */
500 int to
; /* refer to VAL (the target string) */
504 concat (nargs
, args
, target_type
, last_special
)
507 enum Lisp_Type target_type
;
511 register Lisp_Object tail
;
512 register Lisp_Object
this;
514 int toindex_byte
= 0;
515 register int result_len
;
516 register int result_len_byte
;
518 Lisp_Object last_tail
;
521 /* When we make a multibyte string, we can't copy text properties
522 while concatinating each string because the length of resulting
523 string can't be decided until we finish the whole concatination.
524 So, we record strings that have text properties to be copied
525 here, and copy the text properties after the concatination. */
526 struct textprop_rec
*textprops
= NULL
;
527 /* Number of elments in textprops. */
528 int num_textprops
= 0;
533 /* In append, the last arg isn't treated like the others */
534 if (last_special
&& nargs
> 0)
537 last_tail
= args
[nargs
];
542 /* Check each argument. */
543 for (argnum
= 0; argnum
< nargs
; argnum
++)
546 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
547 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
548 wrong_type_argument (Qsequencep
, this);
551 /* Compute total length in chars of arguments in RESULT_LEN.
552 If desired output is a string, also compute length in bytes
553 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
554 whether the result should be a multibyte string. */
558 for (argnum
= 0; argnum
< nargs
; argnum
++)
562 len
= XFASTINT (Flength (this));
563 if (target_type
== Lisp_String
)
565 /* We must count the number of bytes needed in the string
566 as well as the number of characters. */
572 for (i
= 0; i
< len
; i
++)
575 CHECK_CHARACTER (ch
);
576 this_len_byte
= CHAR_BYTES (XINT (ch
));
577 result_len_byte
+= this_len_byte
;
578 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
581 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
582 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
583 else if (CONSP (this))
584 for (; CONSP (this); this = XCDR (this))
587 CHECK_CHARACTER (ch
);
588 this_len_byte
= CHAR_BYTES (XINT (ch
));
589 result_len_byte
+= this_len_byte
;
590 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
593 else if (STRINGP (this))
595 if (STRING_MULTIBYTE (this))
598 result_len_byte
+= SBYTES (this);
601 result_len_byte
+= count_size_as_multibyte (SDATA (this),
608 error ("String overflow");
611 if (! some_multibyte
)
612 result_len_byte
= result_len
;
614 /* Create the output object. */
615 if (target_type
== Lisp_Cons
)
616 val
= Fmake_list (make_number (result_len
), Qnil
);
617 else if (target_type
== Lisp_Vectorlike
)
618 val
= Fmake_vector (make_number (result_len
), Qnil
);
619 else if (some_multibyte
)
620 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
622 val
= make_uninit_string (result_len
);
624 /* In `append', if all but last arg are nil, return last arg. */
625 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
628 /* Copy the contents of the args into the result. */
630 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
632 toindex
= 0, toindex_byte
= 0;
636 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
638 for (argnum
= 0; argnum
< nargs
; argnum
++)
642 register unsigned int thisindex
= 0;
643 register unsigned int thisindex_byte
= 0;
647 thislen
= Flength (this), thisleni
= XINT (thislen
);
649 /* Between strings of the same kind, copy fast. */
650 if (STRINGP (this) && STRINGP (val
)
651 && STRING_MULTIBYTE (this) == some_multibyte
)
653 int thislen_byte
= SBYTES (this);
655 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
657 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
659 textprops
[num_textprops
].argnum
= argnum
;
660 textprops
[num_textprops
].from
= 0;
661 textprops
[num_textprops
++].to
= toindex
;
663 toindex_byte
+= thislen_byte
;
666 /* Copy a single-byte string to a multibyte string. */
667 else if (STRINGP (this) && STRINGP (val
))
669 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
671 textprops
[num_textprops
].argnum
= argnum
;
672 textprops
[num_textprops
].from
= 0;
673 textprops
[num_textprops
++].to
= toindex
;
675 toindex_byte
+= copy_text (SDATA (this),
676 SDATA (val
) + toindex_byte
,
677 SCHARS (this), 0, 1);
681 /* Copy element by element. */
684 register Lisp_Object elt
;
686 /* Fetch next element of `this' arg into `elt', or break if
687 `this' is exhausted. */
688 if (NILP (this)) break;
690 elt
= XCAR (this), this = XCDR (this);
691 else if (thisindex
>= thisleni
)
693 else if (STRINGP (this))
696 if (STRING_MULTIBYTE (this))
698 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
701 XSETFASTINT (elt
, c
);
705 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
707 && !ASCII_CHAR_P (XINT (elt
))
708 && XINT (elt
) < 0400)
710 c
= BYTE8_TO_CHAR (XINT (elt
));
715 else if (BOOL_VECTOR_P (this))
718 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
719 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
727 elt
= AREF (this, thisindex
);
731 /* Store this element into the result. */
738 else if (VECTORP (val
))
740 ASET (val
, toindex
, elt
);
747 toindex_byte
+= CHAR_STRING (XINT (elt
),
748 SDATA (val
) + toindex_byte
);
750 SSET (val
, toindex_byte
++, XINT (elt
));
756 XSETCDR (prev
, last_tail
);
758 if (num_textprops
> 0)
761 int last_to_end
= -1;
763 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
765 this = args
[textprops
[argnum
].argnum
];
766 props
= text_property_list (this,
768 make_number (SCHARS (this)),
770 /* If successive arguments have properites, be sure that the
771 value of `composition' property be the copy. */
772 if (last_to_end
== textprops
[argnum
].to
)
773 make_composition_value_copy (props
);
774 add_text_properties_from_list (val
, props
,
775 make_number (textprops
[argnum
].to
));
776 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
784 static Lisp_Object string_char_byte_cache_string
;
785 static EMACS_INT string_char_byte_cache_charpos
;
786 static EMACS_INT string_char_byte_cache_bytepos
;
789 clear_string_char_byte_cache ()
791 string_char_byte_cache_string
= Qnil
;
794 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
797 string_char_to_byte (string
, char_index
)
799 EMACS_INT char_index
;
802 EMACS_INT best_below
, best_below_byte
;
803 EMACS_INT best_above
, best_above_byte
;
805 best_below
= best_below_byte
= 0;
806 best_above
= SCHARS (string
);
807 best_above_byte
= SBYTES (string
);
808 if (best_above
== best_above_byte
)
811 if (EQ (string
, string_char_byte_cache_string
))
813 if (string_char_byte_cache_charpos
< char_index
)
815 best_below
= string_char_byte_cache_charpos
;
816 best_below_byte
= string_char_byte_cache_bytepos
;
820 best_above
= string_char_byte_cache_charpos
;
821 best_above_byte
= string_char_byte_cache_bytepos
;
825 if (char_index
- best_below
< best_above
- char_index
)
827 unsigned char *p
= SDATA (string
) + best_below_byte
;
829 while (best_below
< char_index
)
831 p
+= BYTES_BY_CHAR_HEAD (*p
);
834 i_byte
= p
- SDATA (string
);
838 unsigned char *p
= SDATA (string
) + best_above_byte
;
840 while (best_above
> char_index
)
843 while (!CHAR_HEAD_P (*p
)) p
--;
846 i_byte
= p
- SDATA (string
);
849 string_char_byte_cache_bytepos
= i_byte
;
850 string_char_byte_cache_charpos
= char_index
;
851 string_char_byte_cache_string
= string
;
856 /* Return the character index corresponding to BYTE_INDEX in STRING. */
859 string_byte_to_char (string
, byte_index
)
861 EMACS_INT byte_index
;
864 EMACS_INT best_below
, best_below_byte
;
865 EMACS_INT best_above
, best_above_byte
;
867 best_below
= best_below_byte
= 0;
868 best_above
= SCHARS (string
);
869 best_above_byte
= SBYTES (string
);
870 if (best_above
== best_above_byte
)
873 if (EQ (string
, string_char_byte_cache_string
))
875 if (string_char_byte_cache_bytepos
< byte_index
)
877 best_below
= string_char_byte_cache_charpos
;
878 best_below_byte
= string_char_byte_cache_bytepos
;
882 best_above
= string_char_byte_cache_charpos
;
883 best_above_byte
= string_char_byte_cache_bytepos
;
887 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
889 unsigned char *p
= SDATA (string
) + best_below_byte
;
890 unsigned char *pend
= SDATA (string
) + byte_index
;
894 p
+= BYTES_BY_CHAR_HEAD (*p
);
898 i_byte
= p
- SDATA (string
);
902 unsigned char *p
= SDATA (string
) + best_above_byte
;
903 unsigned char *pbeg
= SDATA (string
) + byte_index
;
908 while (!CHAR_HEAD_P (*p
)) p
--;
912 i_byte
= p
- SDATA (string
);
915 string_char_byte_cache_bytepos
= i_byte
;
916 string_char_byte_cache_charpos
= i
;
917 string_char_byte_cache_string
= string
;
922 /* Convert STRING to a multibyte string. */
925 string_make_multibyte (string
)
933 if (STRING_MULTIBYTE (string
))
936 nbytes
= count_size_as_multibyte (SDATA (string
),
938 /* If all the chars are ASCII, they won't need any more bytes
939 once converted. In that case, we can return STRING itself. */
940 if (nbytes
== SBYTES (string
))
943 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
944 copy_text (SDATA (string
), buf
, SBYTES (string
),
947 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
954 /* Convert STRING (if unibyte) to a multibyte string without changing
955 the number of characters. Characters 0200 trough 0237 are
956 converted to eight-bit characters. */
959 string_to_multibyte (string
)
967 if (STRING_MULTIBYTE (string
))
970 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
971 /* If all the chars are ASCII, they won't need any more bytes once
973 if (nbytes
== SBYTES (string
))
974 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
976 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
977 bcopy (SDATA (string
), buf
, SBYTES (string
));
978 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
980 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
987 /* Convert STRING to a single-byte string. */
990 string_make_unibyte (string
)
998 if (! STRING_MULTIBYTE (string
))
1001 nchars
= SCHARS (string
);
1003 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1004 copy_text (SDATA (string
), buf
, SBYTES (string
),
1007 ret
= make_unibyte_string (buf
, nchars
);
1013 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1015 doc
: /* Return the multibyte equivalent of STRING.
1016 If STRING is unibyte and contains non-ASCII characters, the function
1017 `unibyte-char-to-multibyte' is used to convert each unibyte character
1018 to a multibyte character. In this case, the returned string is a
1019 newly created string with no text properties. If STRING is multibyte
1020 or entirely ASCII, it is returned unchanged. In particular, when
1021 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1022 \(When the characters are all ASCII, Emacs primitives will treat the
1023 string the same way whether it is unibyte or multibyte.) */)
1027 CHECK_STRING (string
);
1029 return string_make_multibyte (string
);
1032 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1034 doc
: /* Return the unibyte equivalent of STRING.
1035 Multibyte character codes are converted to unibyte according to
1036 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1037 If the lookup in the translation table fails, this function takes just
1038 the low 8 bits of each character. */)
1042 CHECK_STRING (string
);
1044 return string_make_unibyte (string
);
1047 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1049 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1050 If STRING is unibyte, the result is STRING itself.
1051 Otherwise it is a newly created string, with no text properties.
1052 If STRING is multibyte and contains a character of charset
1053 `eight-bit', it is converted to the corresponding single byte. */)
1057 CHECK_STRING (string
);
1059 if (STRING_MULTIBYTE (string
))
1061 int bytes
= SBYTES (string
);
1062 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1064 bcopy (SDATA (string
), str
, bytes
);
1065 bytes
= str_as_unibyte (str
, bytes
);
1066 string
= make_unibyte_string (str
, bytes
);
1072 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1074 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1075 If STRING is multibyte, the result is STRING itself.
1076 Otherwise it is a newly created string, with no text properties.
1078 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1079 part of a correct utf-8 sequence), it is converted to the corresponding
1080 multibyte character of charset `eight-bit'.
1081 See also `string-to-multibyte'.
1083 Beware, this often doesn't really do what you think it does.
1084 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1085 If you're not sure, whether to use `string-as-multibyte' or
1086 `string-to-multibyte', use `string-to-multibyte'. */)
1090 CHECK_STRING (string
);
1092 if (! STRING_MULTIBYTE (string
))
1094 Lisp_Object new_string
;
1097 parse_str_as_multibyte (SDATA (string
),
1100 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1101 bcopy (SDATA (string
), SDATA (new_string
),
1103 if (nbytes
!= SBYTES (string
))
1104 str_as_multibyte (SDATA (new_string
), nbytes
,
1105 SBYTES (string
), NULL
);
1106 string
= new_string
;
1107 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1112 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1114 doc
: /* Return a multibyte string with the same individual chars as STRING.
1115 If STRING is multibyte, the result is STRING itself.
1116 Otherwise it is a newly created string, with no text properties.
1118 If STRING is unibyte and contains an 8-bit byte, it is converted to
1119 the corresponding multibyte character of charset `eight-bit'.
1121 This differs from `string-as-multibyte' by converting each byte of a correct
1122 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1123 correct sequence. */)
1127 CHECK_STRING (string
);
1129 return string_to_multibyte (string
);
1132 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1134 doc
: /* Return a unibyte string with the same individual chars as STRING.
1135 If STRING is unibyte, the result is STRING itself.
1136 Otherwise it is a newly created string, with no text properties,
1137 where each `eight-bit' character is converted to the corresponding byte.
1138 If STRING contains a non-ASCII, non-`eight-bit' character,
1139 an error is signaled. */)
1143 CHECK_STRING (string
);
1145 if (STRING_MULTIBYTE (string
))
1147 EMACS_INT chars
= SCHARS (string
);
1148 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1149 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1151 if (converted
< chars
)
1152 error ("Can't convert the %dth character to unibyte", converted
);
1153 string
= make_unibyte_string (str
, chars
);
1160 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1161 doc
: /* Return a copy of ALIST.
1162 This is an alist which represents the same mapping from objects to objects,
1163 but does not share the alist structure with ALIST.
1164 The objects mapped (cars and cdrs of elements of the alist)
1165 are shared, however.
1166 Elements of ALIST that are not conses are also shared. */)
1170 register Lisp_Object tem
;
1175 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1176 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1178 register Lisp_Object car
;
1182 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1187 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1188 doc
: /* Return a new string whose contents are a substring of STRING.
1189 The returned string consists of the characters between index FROM
1190 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1191 zero-indexed: 0 means the first character of STRING. Negative values
1192 are counted from the end of STRING. If TO is nil, the substring runs
1193 to the end of STRING.
1195 The STRING argument may also be a vector. In that case, the return
1196 value is a new vector that contains the elements between index FROM
1197 \(inclusive) and index TO (exclusive) of that vector argument. */)
1200 register Lisp_Object from
, to
;
1205 int from_char
, to_char
;
1206 int from_byte
= 0, to_byte
= 0;
1208 CHECK_VECTOR_OR_STRING (string
);
1209 CHECK_NUMBER (from
);
1211 if (STRINGP (string
))
1213 size
= SCHARS (string
);
1214 size_byte
= SBYTES (string
);
1217 size
= ASIZE (string
);
1222 to_byte
= size_byte
;
1228 to_char
= XINT (to
);
1232 if (STRINGP (string
))
1233 to_byte
= string_char_to_byte (string
, to_char
);
1236 from_char
= XINT (from
);
1239 if (STRINGP (string
))
1240 from_byte
= string_char_to_byte (string
, from_char
);
1242 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1243 args_out_of_range_3 (string
, make_number (from_char
),
1244 make_number (to_char
));
1246 if (STRINGP (string
))
1248 res
= make_specified_string (SDATA (string
) + from_byte
,
1249 to_char
- from_char
, to_byte
- from_byte
,
1250 STRING_MULTIBYTE (string
));
1251 copy_text_properties (make_number (from_char
), make_number (to_char
),
1252 string
, make_number (0), res
, Qnil
);
1255 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1261 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1262 doc
: /* Return a substring of STRING, without text properties.
1263 It starts at index FROM and ending before TO.
1264 TO may be nil or omitted; then the substring runs to the end of STRING.
1265 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1266 If FROM or TO is negative, it counts from the end.
1268 With one argument, just copy STRING without its properties. */)
1271 register Lisp_Object from
, to
;
1273 int size
, size_byte
;
1274 int from_char
, to_char
;
1275 int from_byte
, to_byte
;
1277 CHECK_STRING (string
);
1279 size
= SCHARS (string
);
1280 size_byte
= SBYTES (string
);
1283 from_char
= from_byte
= 0;
1286 CHECK_NUMBER (from
);
1287 from_char
= XINT (from
);
1291 from_byte
= string_char_to_byte (string
, from_char
);
1297 to_byte
= size_byte
;
1303 to_char
= XINT (to
);
1307 to_byte
= string_char_to_byte (string
, to_char
);
1310 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1311 args_out_of_range_3 (string
, make_number (from_char
),
1312 make_number (to_char
));
1314 return make_specified_string (SDATA (string
) + from_byte
,
1315 to_char
- from_char
, to_byte
- from_byte
,
1316 STRING_MULTIBYTE (string
));
1319 /* Extract a substring of STRING, giving start and end positions
1320 both in characters and in bytes. */
1323 substring_both (string
, from
, from_byte
, to
, to_byte
)
1325 int from
, from_byte
, to
, to_byte
;
1331 CHECK_VECTOR_OR_STRING (string
);
1333 if (STRINGP (string
))
1335 size
= SCHARS (string
);
1336 size_byte
= SBYTES (string
);
1339 size
= ASIZE (string
);
1341 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1342 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1344 if (STRINGP (string
))
1346 res
= make_specified_string (SDATA (string
) + from_byte
,
1347 to
- from
, to_byte
- from_byte
,
1348 STRING_MULTIBYTE (string
));
1349 copy_text_properties (make_number (from
), make_number (to
),
1350 string
, make_number (0), res
, Qnil
);
1353 res
= Fvector (to
- from
, &AREF (string
, from
));
1358 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1359 doc
: /* Take cdr N times on LIST, returns the result. */)
1362 register Lisp_Object list
;
1364 register int i
, num
;
1367 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1370 CHECK_LIST_CONS (list
, list
);
1376 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1377 doc
: /* Return the Nth element of LIST.
1378 N counts from zero. If LIST is not that long, nil is returned. */)
1380 Lisp_Object n
, list
;
1382 return Fcar (Fnthcdr (n
, list
));
1385 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1386 doc
: /* Return element of SEQUENCE at index N. */)
1388 register Lisp_Object sequence
, n
;
1391 if (CONSP (sequence
) || NILP (sequence
))
1392 return Fcar (Fnthcdr (n
, sequence
));
1394 /* Faref signals a "not array" error, so check here. */
1395 CHECK_ARRAY (sequence
, Qsequencep
);
1396 return Faref (sequence
, n
);
1399 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1400 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1401 The value is actually the tail of LIST whose car is ELT. */)
1403 register Lisp_Object elt
;
1406 register Lisp_Object tail
;
1407 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1409 register Lisp_Object tem
;
1410 CHECK_LIST_CONS (tail
, list
);
1412 if (! NILP (Fequal (elt
, tem
)))
1419 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1420 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1421 The value is actually the tail of LIST whose car is ELT. */)
1423 register Lisp_Object elt
, list
;
1427 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1431 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1435 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1446 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1447 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1448 The value is actually the tail of LIST whose car is ELT. */)
1450 register Lisp_Object elt
;
1453 register Lisp_Object tail
;
1456 return Fmemq (elt
, list
);
1458 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1460 register Lisp_Object tem
;
1461 CHECK_LIST_CONS (tail
, list
);
1463 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1470 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1471 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1472 The value is actually the first element of LIST whose car is KEY.
1473 Elements of LIST that are not conses are ignored. */)
1475 Lisp_Object key
, list
;
1480 || (CONSP (XCAR (list
))
1481 && EQ (XCAR (XCAR (list
)), key
)))
1486 || (CONSP (XCAR (list
))
1487 && EQ (XCAR (XCAR (list
)), key
)))
1492 || (CONSP (XCAR (list
))
1493 && EQ (XCAR (XCAR (list
)), key
)))
1503 /* Like Fassq but never report an error and do not allow quits.
1504 Use only on lists known never to be circular. */
1507 assq_no_quit (key
, list
)
1508 Lisp_Object key
, list
;
1511 && (!CONSP (XCAR (list
))
1512 || !EQ (XCAR (XCAR (list
)), key
)))
1515 return CAR_SAFE (list
);
1518 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1519 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1520 The value is actually the first element of LIST whose car equals KEY. */)
1522 Lisp_Object key
, list
;
1529 || (CONSP (XCAR (list
))
1530 && (car
= XCAR (XCAR (list
)),
1531 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1536 || (CONSP (XCAR (list
))
1537 && (car
= XCAR (XCAR (list
)),
1538 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1543 || (CONSP (XCAR (list
))
1544 && (car
= XCAR (XCAR (list
)),
1545 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1555 /* Like Fassoc but never report an error and do not allow quits.
1556 Use only on lists known never to be circular. */
1559 assoc_no_quit (key
, list
)
1560 Lisp_Object key
, list
;
1563 && (!CONSP (XCAR (list
))
1564 || (!EQ (XCAR (XCAR (list
)), key
)
1565 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1568 return CONSP (list
) ? XCAR (list
) : Qnil
;
1571 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1572 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1573 The value is actually the first element of LIST whose cdr is KEY. */)
1575 register Lisp_Object key
;
1581 || (CONSP (XCAR (list
))
1582 && EQ (XCDR (XCAR (list
)), key
)))
1587 || (CONSP (XCAR (list
))
1588 && EQ (XCDR (XCAR (list
)), key
)))
1593 || (CONSP (XCAR (list
))
1594 && EQ (XCDR (XCAR (list
)), key
)))
1604 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1605 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1606 The value is actually the first element of LIST whose cdr equals KEY. */)
1608 Lisp_Object key
, list
;
1615 || (CONSP (XCAR (list
))
1616 && (cdr
= XCDR (XCAR (list
)),
1617 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1622 || (CONSP (XCAR (list
))
1623 && (cdr
= XCDR (XCAR (list
)),
1624 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1629 || (CONSP (XCAR (list
))
1630 && (cdr
= XCDR (XCAR (list
)),
1631 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1641 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1642 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1643 The modified LIST is returned. Comparison is done with `eq'.
1644 If the first member of LIST is ELT, there is no way to remove it by side effect;
1645 therefore, write `(setq foo (delq element foo))'
1646 to be sure of changing the value of `foo'. */)
1648 register Lisp_Object elt
;
1651 register Lisp_Object tail
, prev
;
1652 register Lisp_Object tem
;
1656 while (!NILP (tail
))
1658 CHECK_LIST_CONS (tail
, list
);
1665 Fsetcdr (prev
, XCDR (tail
));
1675 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1676 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1677 SEQ must be a list, a vector, or a string.
1678 The modified SEQ is returned. Comparison is done with `equal'.
1679 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1680 is not a side effect; it is simply using a different sequence.
1681 Therefore, write `(setq foo (delete element foo))'
1682 to be sure of changing the value of `foo'. */)
1684 Lisp_Object elt
, seq
;
1690 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1691 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1694 if (n
!= ASIZE (seq
))
1696 struct Lisp_Vector
*p
= allocate_vector (n
);
1698 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1699 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1700 p
->contents
[n
++] = AREF (seq
, i
);
1702 XSETVECTOR (seq
, p
);
1705 else if (STRINGP (seq
))
1707 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1710 for (i
= nchars
= nbytes
= ibyte
= 0;
1712 ++i
, ibyte
+= cbytes
)
1714 if (STRING_MULTIBYTE (seq
))
1716 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1717 cbytes
= CHAR_BYTES (c
);
1725 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1732 if (nchars
!= SCHARS (seq
))
1736 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1737 if (!STRING_MULTIBYTE (seq
))
1738 STRING_SET_UNIBYTE (tem
);
1740 for (i
= nchars
= nbytes
= ibyte
= 0;
1742 ++i
, ibyte
+= cbytes
)
1744 if (STRING_MULTIBYTE (seq
))
1746 c
= STRING_CHAR (SDATA (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 /* This does not check for quits. That is safe since it must terminate. */
1932 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1933 doc
: /* Extract a value from a property list.
1934 PLIST is a property list, which is a list of the form
1935 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1936 corresponding to the given PROP, or nil if PROP is not one of the
1937 properties on the list. This function never signals an error. */)
1942 Lisp_Object tail
, halftail
;
1944 /* halftail is used to detect circular lists. */
1945 tail
= halftail
= plist
;
1946 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1948 if (EQ (prop
, XCAR (tail
)))
1949 return XCAR (XCDR (tail
));
1951 tail
= XCDR (XCDR (tail
));
1952 halftail
= XCDR (halftail
);
1953 if (EQ (tail
, halftail
))
1956 #if 0 /* Unsafe version. */
1957 /* This function can be called asynchronously
1958 (setup_coding_system). Don't QUIT in that case. */
1959 if (!interrupt_input_blocked
)
1967 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1968 doc
: /* Return the value of SYMBOL's PROPNAME property.
1969 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1971 Lisp_Object symbol
, propname
;
1973 CHECK_SYMBOL (symbol
);
1974 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1977 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1978 doc
: /* Change value in PLIST of PROP to VAL.
1979 PLIST is a property list, which is a list of the form
1980 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1981 If PROP is already a property on the list, its value is set to VAL,
1982 otherwise the new PROP VAL pair is added. The new plist is returned;
1983 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1984 The PLIST is modified by side effects. */)
1987 register Lisp_Object prop
;
1990 register Lisp_Object tail
, prev
;
1991 Lisp_Object newcell
;
1993 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1994 tail
= XCDR (XCDR (tail
)))
1996 if (EQ (prop
, XCAR (tail
)))
1998 Fsetcar (XCDR (tail
), val
);
2005 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2009 Fsetcdr (XCDR (prev
), newcell
);
2013 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2014 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2015 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2016 (symbol
, propname
, value
)
2017 Lisp_Object symbol
, propname
, value
;
2019 CHECK_SYMBOL (symbol
);
2020 XSYMBOL (symbol
)->plist
2021 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2025 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2026 doc
: /* Extract a value from a property list, comparing with `equal'.
2027 PLIST is a property list, which is a list of the form
2028 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2029 corresponding to the given PROP, or nil if PROP is not
2030 one of the properties on the list. */)
2038 CONSP (tail
) && CONSP (XCDR (tail
));
2039 tail
= XCDR (XCDR (tail
)))
2041 if (! NILP (Fequal (prop
, XCAR (tail
))))
2042 return XCAR (XCDR (tail
));
2047 CHECK_LIST_END (tail
, prop
);
2052 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2053 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2054 PLIST is a property list, which is a list of the form
2055 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2056 If PROP is already a property on the list, its value is set to VAL,
2057 otherwise the new PROP VAL pair is added. The new plist is returned;
2058 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2059 The PLIST is modified by side effects. */)
2062 register Lisp_Object prop
;
2065 register Lisp_Object tail
, prev
;
2066 Lisp_Object newcell
;
2068 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2069 tail
= XCDR (XCDR (tail
)))
2071 if (! NILP (Fequal (prop
, XCAR (tail
))))
2073 Fsetcar (XCDR (tail
), val
);
2080 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2084 Fsetcdr (XCDR (prev
), newcell
);
2088 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2089 doc
: /* Return t if the two args are the same Lisp object.
2090 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2092 Lisp_Object obj1
, obj2
;
2095 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2097 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2100 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2101 doc
: /* Return t if two Lisp objects have similar structure and contents.
2102 They must have the same data type.
2103 Conses are compared by comparing the cars and the cdrs.
2104 Vectors and strings are compared element by element.
2105 Numbers are compared by value, but integers cannot equal floats.
2106 (Use `=' if you want integers and floats to be able to be equal.)
2107 Symbols must match exactly. */)
2109 register Lisp_Object o1
, o2
;
2111 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2114 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2115 doc
: /* Return t if two Lisp objects have similar structure and contents.
2116 This is like `equal' except that it compares the text properties
2117 of strings. (`equal' ignores text properties.) */)
2119 register Lisp_Object o1
, o2
;
2121 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2124 /* DEPTH is current depth of recursion. Signal an error if it
2126 PROPS, if non-nil, means compare string text properties too. */
2129 internal_equal (o1
, o2
, depth
, props
)
2130 register Lisp_Object o1
, o2
;
2134 error ("Stack overflow in equal");
2140 if (XTYPE (o1
) != XTYPE (o2
))
2149 d1
= extract_float (o1
);
2150 d2
= extract_float (o2
);
2151 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2152 though they are not =. */
2153 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2157 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2164 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2168 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2170 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2173 o1
= XOVERLAY (o1
)->plist
;
2174 o2
= XOVERLAY (o2
)->plist
;
2179 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2180 && (XMARKER (o1
)->buffer
== 0
2181 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2185 case Lisp_Vectorlike
:
2188 EMACS_INT size
= ASIZE (o1
);
2189 /* Pseudovectors have the type encoded in the size field, so this test
2190 actually checks that the objects have the same type as well as the
2192 if (ASIZE (o2
) != size
)
2194 /* Boolvectors are compared much like strings. */
2195 if (BOOL_VECTOR_P (o1
))
2198 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2199 / BOOL_VECTOR_BITS_PER_CHAR
);
2201 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2203 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2208 if (WINDOW_CONFIGURATIONP (o1
))
2209 return compare_window_configurations (o1
, o2
, 0);
2211 /* Aside from them, only true vectors, char-tables, compiled
2212 functions, and fonts (font-spec, font-entity, font-ojbect)
2213 are sensible to compare, so eliminate the others now. */
2214 if (size
& PSEUDOVECTOR_FLAG
)
2216 if (!(size
& (PVEC_COMPILED
2217 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2219 size
&= PSEUDOVECTOR_SIZE_MASK
;
2221 for (i
= 0; i
< size
; i
++)
2226 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2234 if (SCHARS (o1
) != SCHARS (o2
))
2236 if (SBYTES (o1
) != SBYTES (o2
))
2238 if (bcmp (SDATA (o1
), SDATA (o2
),
2241 if (props
&& !compare_string_intervals (o1
, o2
))
2252 extern Lisp_Object
Fmake_char_internal ();
2254 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2255 doc
: /* Store each element of ARRAY with ITEM.
2256 ARRAY is a vector, string, char-table, or bool-vector. */)
2258 Lisp_Object array
, item
;
2260 register int size
, index
, charval
;
2261 if (VECTORP (array
))
2263 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2264 size
= ASIZE (array
);
2265 for (index
= 0; index
< size
; index
++)
2268 else if (CHAR_TABLE_P (array
))
2272 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2273 XCHAR_TABLE (array
)->contents
[i
] = item
;
2274 XCHAR_TABLE (array
)->defalt
= item
;
2276 else if (STRINGP (array
))
2278 register unsigned char *p
= SDATA (array
);
2279 CHECK_NUMBER (item
);
2280 charval
= XINT (item
);
2281 size
= SCHARS (array
);
2282 if (STRING_MULTIBYTE (array
))
2284 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2285 int len
= CHAR_STRING (charval
, str
);
2286 int size_byte
= SBYTES (array
);
2287 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2290 if (size
!= size_byte
)
2293 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2294 if (len
!= this_len
)
2295 error ("Attempt to change byte length of a string");
2298 for (i
= 0; i
< size_byte
; i
++)
2299 *p
++ = str
[i
% len
];
2302 for (index
= 0; index
< size
; index
++)
2305 else if (BOOL_VECTOR_P (array
))
2307 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2309 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2310 / BOOL_VECTOR_BITS_PER_CHAR
);
2312 charval
= (! NILP (item
) ? -1 : 0);
2313 for (index
= 0; index
< size_in_chars
- 1; index
++)
2315 if (index
< size_in_chars
)
2317 /* Mask out bits beyond the vector size. */
2318 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2319 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2324 wrong_type_argument (Qarrayp
, array
);
2328 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2330 doc
: /* Clear the contents of STRING.
2331 This makes STRING unibyte and may change its length. */)
2336 CHECK_STRING (string
);
2337 len
= SBYTES (string
);
2338 bzero (SDATA (string
), len
);
2339 STRING_SET_CHARS (string
, len
);
2340 STRING_SET_UNIBYTE (string
);
2350 Lisp_Object args
[2];
2353 return Fnconc (2, args
);
2355 return Fnconc (2, &s1
);
2356 #endif /* NO_ARG_ARRAY */
2359 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2360 doc
: /* Concatenate any number of lists by altering them.
2361 Only the last argument is not altered, and need not be a list.
2362 usage: (nconc &rest LISTS) */)
2367 register int argnum
;
2368 register Lisp_Object tail
, tem
, val
;
2372 for (argnum
= 0; argnum
< nargs
; argnum
++)
2375 if (NILP (tem
)) continue;
2380 if (argnum
+ 1 == nargs
) break;
2382 CHECK_LIST_CONS (tem
, tem
);
2391 tem
= args
[argnum
+ 1];
2392 Fsetcdr (tail
, tem
);
2394 args
[argnum
+ 1] = tail
;
2400 /* This is the guts of all mapping functions.
2401 Apply FN to each element of SEQ, one by one,
2402 storing the results into elements of VALS, a C vector of Lisp_Objects.
2403 LENI is the length of VALS, which should also be the length of SEQ. */
2406 mapcar1 (leni
, vals
, fn
, seq
)
2409 Lisp_Object fn
, seq
;
2411 register Lisp_Object tail
;
2414 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2418 /* Don't let vals contain any garbage when GC happens. */
2419 for (i
= 0; i
< leni
; i
++)
2422 GCPRO3 (dummy
, fn
, seq
);
2424 gcpro1
.nvars
= leni
;
2428 /* We need not explicitly protect `tail' because it is used only on lists, and
2429 1) lists are not relocated and 2) the list is marked via `seq' so will not
2434 for (i
= 0; i
< leni
; i
++)
2436 dummy
= call1 (fn
, AREF (seq
, i
));
2441 else if (BOOL_VECTOR_P (seq
))
2443 for (i
= 0; i
< leni
; i
++)
2446 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2447 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2448 dummy
= call1 (fn
, dummy
);
2453 else if (STRINGP (seq
))
2457 for (i
= 0, i_byte
= 0; i
< leni
;)
2462 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2463 XSETFASTINT (dummy
, c
);
2464 dummy
= call1 (fn
, dummy
);
2466 vals
[i_before
] = dummy
;
2469 else /* Must be a list, since Flength did not get an error */
2472 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2474 dummy
= call1 (fn
, XCAR (tail
));
2484 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2485 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2486 In between each pair of results, stick in SEPARATOR. Thus, " " as
2487 SEPARATOR results in spaces between the values returned by FUNCTION.
2488 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2489 (function
, sequence
, separator
)
2490 Lisp_Object function
, sequence
, separator
;
2495 register Lisp_Object
*args
;
2497 struct gcpro gcpro1
;
2501 len
= Flength (sequence
);
2502 if (CHAR_TABLE_P (sequence
))
2503 wrong_type_argument (Qlistp
, sequence
);
2505 nargs
= leni
+ leni
- 1;
2506 if (nargs
< 0) return empty_unibyte_string
;
2508 SAFE_ALLOCA_LISP (args
, nargs
);
2511 mapcar1 (leni
, args
, function
, sequence
);
2514 for (i
= leni
- 1; i
> 0; i
--)
2515 args
[i
+ i
] = args
[i
];
2517 for (i
= 1; i
< nargs
; i
+= 2)
2518 args
[i
] = separator
;
2520 ret
= Fconcat (nargs
, args
);
2526 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2527 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2528 The result is a list just as long as SEQUENCE.
2529 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2530 (function
, sequence
)
2531 Lisp_Object function
, sequence
;
2533 register Lisp_Object len
;
2535 register Lisp_Object
*args
;
2539 len
= Flength (sequence
);
2540 if (CHAR_TABLE_P (sequence
))
2541 wrong_type_argument (Qlistp
, sequence
);
2542 leni
= XFASTINT (len
);
2544 SAFE_ALLOCA_LISP (args
, leni
);
2546 mapcar1 (leni
, args
, function
, sequence
);
2548 ret
= Flist (leni
, args
);
2554 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2555 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2556 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2557 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2558 (function
, sequence
)
2559 Lisp_Object function
, sequence
;
2563 leni
= XFASTINT (Flength (sequence
));
2564 if (CHAR_TABLE_P (sequence
))
2565 wrong_type_argument (Qlistp
, sequence
);
2566 mapcar1 (leni
, 0, function
, sequence
);
2571 /* Anything that calls this function must protect from GC! */
2573 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2574 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2575 Takes one argument, which is the string to display to ask the question.
2576 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2577 No confirmation of the answer is requested; a single character is enough.
2578 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2579 the bindings in `query-replace-map'; see the documentation of that variable
2580 for more information. In this case, the useful bindings are `act', `skip',
2581 `recenter', and `quit'.\)
2583 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2584 is nil and `use-dialog-box' is non-nil. */)
2588 register Lisp_Object obj
, key
, def
, map
;
2589 register int answer
;
2590 Lisp_Object xprompt
;
2591 Lisp_Object args
[2];
2592 struct gcpro gcpro1
, gcpro2
;
2593 int count
= SPECPDL_INDEX ();
2595 specbind (Qcursor_in_echo_area
, Qt
);
2597 map
= Fsymbol_value (intern ("query-replace-map"));
2599 CHECK_STRING (prompt
);
2601 GCPRO2 (prompt
, xprompt
);
2603 #ifdef HAVE_WINDOW_SYSTEM
2604 if (display_hourglass_p
)
2605 cancel_hourglass ();
2612 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2613 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2617 Lisp_Object pane
, menu
;
2618 redisplay_preserve_echo_area (3);
2619 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2620 Fcons (Fcons (build_string ("No"), Qnil
),
2622 menu
= Fcons (prompt
, pane
);
2623 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2624 answer
= !NILP (obj
);
2627 #endif /* HAVE_MENUS */
2628 cursor_in_echo_area
= 1;
2629 choose_minibuf_frame ();
2632 Lisp_Object pargs
[3];
2634 /* Colorize prompt according to `minibuffer-prompt' face. */
2635 pargs
[0] = build_string ("%s(y or n) ");
2636 pargs
[1] = intern ("face");
2637 pargs
[2] = intern ("minibuffer-prompt");
2638 args
[0] = Fpropertize (3, pargs
);
2643 if (minibuffer_auto_raise
)
2645 Lisp_Object mini_frame
;
2647 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2649 Fraise_frame (mini_frame
);
2652 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2653 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2654 cursor_in_echo_area
= 0;
2655 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2658 key
= Fmake_vector (make_number (1), obj
);
2659 def
= Flookup_key (map
, key
, Qt
);
2661 if (EQ (def
, intern ("skip")))
2666 else if (EQ (def
, intern ("act")))
2671 else if (EQ (def
, intern ("recenter")))
2677 else if (EQ (def
, intern ("quit")))
2679 /* We want to exit this command for exit-prefix,
2680 and this is the only way to do it. */
2681 else if (EQ (def
, intern ("exit-prefix")))
2686 /* If we don't clear this, then the next call to read_char will
2687 return quit_char again, and we'll enter an infinite loop. */
2692 if (EQ (xprompt
, prompt
))
2694 args
[0] = build_string ("Please answer y or n. ");
2696 xprompt
= Fconcat (2, args
);
2701 if (! noninteractive
)
2703 cursor_in_echo_area
= -1;
2704 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2708 unbind_to (count
, Qnil
);
2709 return answer
? Qt
: Qnil
;
2712 /* This is how C code calls `yes-or-no-p' and allows the user
2715 Anything that calls this function must protect from GC! */
2718 do_yes_or_no_p (prompt
)
2721 return call1 (intern ("yes-or-no-p"), prompt
);
2724 /* Anything that calls this function must protect from GC! */
2726 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2727 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2728 Takes one argument, which is the string to display to ask the question.
2729 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2730 The user must confirm the answer with RET,
2731 and can edit it until it has been confirmed.
2733 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2734 is nil, and `use-dialog-box' is non-nil. */)
2739 int count
= SPECPDL_INDEX ();
2741 Finhibit_yield (Qt
);
2742 record_unwind_protect (Finhibit_yield
, Qnil
);
2743 ret
= Fyes_or_no1 (prompt
);
2744 Finhibit_yield (Qnil
);
2745 unbind_to (count
, Qnil
);
2750 Fyes_or_no1 (Lisp_Object prompt
)
2752 register Lisp_Object ans
;
2753 Lisp_Object args
[2];
2754 struct gcpro gcpro1
;
2756 CHECK_STRING (prompt
);
2759 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2760 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2764 Lisp_Object pane
, menu
, obj
;
2765 redisplay_preserve_echo_area (4);
2766 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2767 Fcons (Fcons (build_string ("No"), Qnil
),
2770 menu
= Fcons (prompt
, pane
);
2771 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2775 #endif /* HAVE_MENUS */
2778 args
[1] = build_string ("(yes or no) ");
2779 prompt
= Fconcat (2, args
);
2785 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2786 Qyes_or_no_p_history
, Qnil
,
2788 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2793 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2801 message ("Please answer yes or no.");
2802 Fsleep_for (make_number (2), Qnil
);
2806 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2807 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2809 Each of the three load averages is multiplied by 100, then converted
2812 When USE-FLOATS is non-nil, floats will be used instead of integers.
2813 These floats are not multiplied by 100.
2815 If the 5-minute or 15-minute load averages are not available, return a
2816 shortened list, containing only those averages which are available.
2818 An error is thrown if the load average can't be obtained. In some
2819 cases making it work would require Emacs being installed setuid or
2820 setgid so that it can read kernel information, and that usually isn't
2823 Lisp_Object use_floats
;
2826 int loads
= getloadavg (load_ave
, 3);
2827 Lisp_Object ret
= Qnil
;
2830 error ("load-average not implemented for this operating system");
2834 Lisp_Object load
= (NILP (use_floats
) ?
2835 make_number ((int) (100.0 * load_ave
[loads
]))
2836 : make_float (load_ave
[loads
]));
2837 ret
= Fcons (load
, ret
);
2843 Lisp_Object impl_Vfeatures
, Qsubfeatures
;
2844 extern Lisp_Object impl_Vafter_load_alist
;
2846 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2847 doc
: /* Returns t if FEATURE is present in this Emacs.
2849 Use this to conditionalize execution of lisp code based on the
2850 presence or absence of Emacs or environment extensions.
2851 Use `provide' to declare that a feature is available. This function
2852 looks at the value of the variable `features'. The optional argument
2853 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2854 (feature
, subfeature
)
2855 Lisp_Object feature
, subfeature
;
2857 register Lisp_Object tem
;
2858 CHECK_SYMBOL (feature
);
2859 tem
= Fmemq (feature
, Vfeatures
);
2860 if (!NILP (tem
) && !NILP (subfeature
))
2861 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2862 return (NILP (tem
)) ? Qnil
: Qt
;
2865 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2866 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2867 The optional argument SUBFEATURES should be a list of symbols listing
2868 particular subfeatures supported in this version of FEATURE. */)
2869 (feature
, subfeatures
)
2870 Lisp_Object feature
, subfeatures
;
2872 register Lisp_Object tem
;
2873 CHECK_SYMBOL (feature
);
2874 CHECK_LIST (subfeatures
);
2875 if (!NILP (Vautoload_queue
))
2876 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2878 tem
= Fmemq (feature
, Vfeatures
);
2880 Vfeatures
= Fcons (feature
, Vfeatures
);
2881 if (!NILP (subfeatures
))
2882 Fput (feature
, Qsubfeatures
, subfeatures
);
2883 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2885 /* Run any load-hooks for this file. */
2886 tem
= Fassq (feature
, Vafter_load_alist
);
2888 Fprogn (XCDR (tem
));
2893 /* `require' and its subroutines. */
2895 /* List of features currently being require'd, innermost first. */
2897 Lisp_Object require_nesting_list
;
2900 require_unwind (old_value
)
2901 Lisp_Object old_value
;
2903 return require_nesting_list
= old_value
;
2906 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2907 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2908 If FEATURE is not a member of the list `features', then the feature
2909 is not loaded; so load the file FILENAME.
2910 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2911 and `load' will try to load this name appended with the suffix `.elc' or
2912 `.el', in that order. The name without appended suffix will not be used.
2913 If the optional third argument NOERROR is non-nil,
2914 then return nil if the file is not found instead of signaling an error.
2915 Normally the return value is FEATURE.
2916 The normal messages at start and end of loading FILENAME are suppressed. */)
2917 (feature
, filename
, noerror
)
2918 Lisp_Object feature
, filename
, noerror
;
2920 register Lisp_Object tem
;
2921 struct gcpro gcpro1
, gcpro2
;
2922 int from_file
= load_in_progress
;
2924 CHECK_SYMBOL (feature
);
2926 /* Record the presence of `require' in this file
2927 even if the feature specified is already loaded.
2928 But not more than once in any file,
2929 and not when we aren't loading or reading from a file. */
2931 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2932 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2937 tem
= Fcons (Qrequire
, feature
);
2938 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2939 LOADHIST_ATTACH (tem
);
2941 tem
= Fmemq (feature
, Vfeatures
);
2945 int count
= SPECPDL_INDEX ();
2948 /* This is to make sure that loadup.el gives a clear picture
2949 of what files are preloaded and when. */
2950 if (! NILP (Vpurify_flag
))
2951 error ("(require %s) while preparing to dump",
2952 SDATA (SYMBOL_NAME (feature
)));
2954 /* A certain amount of recursive `require' is legitimate,
2955 but if we require the same feature recursively 3 times,
2957 tem
= require_nesting_list
;
2958 while (! NILP (tem
))
2960 if (! NILP (Fequal (feature
, XCAR (tem
))))
2965 error ("Recursive `require' for feature `%s'",
2966 SDATA (SYMBOL_NAME (feature
)));
2968 /* Update the list for any nested `require's that occur. */
2969 record_unwind_protect (require_unwind
, require_nesting_list
);
2970 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2972 /* Value saved here is to be restored into Vautoload_queue */
2973 record_unwind_protect (un_autoload
, Vautoload_queue
);
2974 Vautoload_queue
= Qt
;
2976 /* Load the file. */
2977 GCPRO2 (feature
, filename
);
2978 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2979 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2982 /* If load failed entirely, return nil. */
2984 return unbind_to (count
, Qnil
);
2986 tem
= Fmemq (feature
, Vfeatures
);
2988 error ("Required feature `%s' was not provided",
2989 SDATA (SYMBOL_NAME (feature
)));
2991 /* Once loading finishes, don't undo it. */
2992 Vautoload_queue
= Qt
;
2993 feature
= unbind_to (count
, feature
);
2999 /* Primitives for work of the "widget" library.
3000 In an ideal world, this section would not have been necessary.
3001 However, lisp function calls being as slow as they are, it turns
3002 out that some functions in the widget library (wid-edit.el) are the
3003 bottleneck of Widget operation. Here is their translation to C,
3004 for the sole reason of efficiency. */
3006 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3007 doc
: /* Return non-nil if PLIST has the property PROP.
3008 PLIST is a property list, which is a list of the form
3009 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3010 Unlike `plist-get', this allows you to distinguish between a missing
3011 property and a property with the value nil.
3012 The value is actually the tail of PLIST whose car is PROP. */)
3014 Lisp_Object plist
, prop
;
3016 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3019 plist
= XCDR (plist
);
3020 plist
= CDR (plist
);
3025 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3026 doc
: /* In WIDGET, set PROPERTY to VALUE.
3027 The value can later be retrieved with `widget-get'. */)
3028 (widget
, property
, value
)
3029 Lisp_Object widget
, property
, value
;
3031 CHECK_CONS (widget
);
3032 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3036 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3037 doc
: /* In WIDGET, get the value of PROPERTY.
3038 The value could either be specified when the widget was created, or
3039 later with `widget-put'. */)
3041 Lisp_Object widget
, property
;
3049 CHECK_CONS (widget
);
3050 tmp
= Fplist_member (XCDR (widget
), property
);
3056 tmp
= XCAR (widget
);
3059 widget
= Fget (tmp
, Qwidget_type
);
3063 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3064 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3065 ARGS are passed as extra arguments to the function.
3066 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3071 /* This function can GC. */
3072 Lisp_Object newargs
[3];
3073 struct gcpro gcpro1
, gcpro2
;
3076 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3077 newargs
[1] = args
[0];
3078 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3079 GCPRO2 (newargs
[0], newargs
[2]);
3080 result
= Fapply (3, newargs
);
3085 #ifdef HAVE_LANGINFO_CODESET
3086 #include <langinfo.h>
3089 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3090 doc
: /* Access locale data ITEM for the current C locale, if available.
3091 ITEM should be one of the following:
3093 `codeset', returning the character set as a string (locale item CODESET);
3095 `days', returning a 7-element vector of day names (locale items DAY_n);
3097 `months', returning a 12-element vector of month names (locale items MON_n);
3099 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3100 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3102 If the system can't provide such information through a call to
3103 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3105 See also Info node `(libc)Locales'.
3107 The data read from the system are decoded using `locale-coding-system'. */)
3112 #ifdef HAVE_LANGINFO_CODESET
3114 if (EQ (item
, Qcodeset
))
3116 str
= nl_langinfo (CODESET
);
3117 return build_string (str
);
3120 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3122 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3123 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3125 struct gcpro gcpro1
;
3127 synchronize_system_time_locale ();
3128 for (i
= 0; i
< 7; i
++)
3130 str
= nl_langinfo (days
[i
]);
3131 val
= make_unibyte_string (str
, strlen (str
));
3132 /* Fixme: Is this coding system necessarily right, even if
3133 it is consistent with CODESET? If not, what to do? */
3134 Faset (v
, make_number (i
),
3135 code_convert_string_norecord (val
, Vlocale_coding_system
,
3143 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3145 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3146 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3147 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3149 struct gcpro gcpro1
;
3151 synchronize_system_time_locale ();
3152 for (i
= 0; i
< 12; i
++)
3154 str
= nl_langinfo (months
[i
]);
3155 val
= make_unibyte_string (str
, strlen (str
));
3156 Faset (v
, make_number (i
),
3157 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3163 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3164 but is in the locale files. This could be used by ps-print. */
3166 else if (EQ (item
, Qpaper
))
3168 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3169 make_number (nl_langinfo (PAPER_HEIGHT
)));
3171 #endif /* PAPER_WIDTH */
3172 #endif /* HAVE_LANGINFO_CODESET*/
3176 /* base64 encode/decode functions (RFC 2045).
3177 Based on code from GNU recode. */
3179 #define MIME_LINE_LENGTH 76
3181 #define IS_ASCII(Character) \
3183 #define IS_BASE64(Character) \
3184 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3185 #define IS_BASE64_IGNORABLE(Character) \
3186 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3187 || (Character) == '\f' || (Character) == '\r')
3189 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3190 character or return retval if there are no characters left to
3192 #define READ_QUADRUPLET_BYTE(retval) \
3197 if (nchars_return) \
3198 *nchars_return = nchars; \
3203 while (IS_BASE64_IGNORABLE (c))
3205 /* Table of characters coding the 64 values. */
3206 static const char base64_value_to_char
[64] =
3208 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3209 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3210 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3211 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3212 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3213 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3214 '8', '9', '+', '/' /* 60-63 */
3217 /* Table of base64 values for first 128 characters. */
3218 static const short base64_char_to_value
[128] =
3220 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3221 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3222 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3223 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3224 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3225 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3226 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3227 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3228 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3229 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3230 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3231 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3232 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3235 /* The following diagram shows the logical steps by which three octets
3236 get transformed into four base64 characters.
3238 .--------. .--------. .--------.
3239 |aaaaaabb| |bbbbcccc| |ccdddddd|
3240 `--------' `--------' `--------'
3242 .--------+--------+--------+--------.
3243 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3244 `--------+--------+--------+--------'
3246 .--------+--------+--------+--------.
3247 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3248 `--------+--------+--------+--------'
3250 The octets are divided into 6 bit chunks, which are then encoded into
3251 base64 characters. */
3254 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3255 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3257 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3259 doc
: /* Base64-encode the region between BEG and END.
3260 Return the length of the encoded text.
3261 Optional third argument NO-LINE-BREAK means do not break long lines
3262 into shorter lines. */)
3263 (beg
, end
, no_line_break
)
3264 Lisp_Object beg
, end
, no_line_break
;
3267 int allength
, length
;
3268 int ibeg
, iend
, encoded_length
;
3272 validate_region (&beg
, &end
);
3274 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3275 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3276 move_gap_both (XFASTINT (beg
), ibeg
);
3278 /* We need to allocate enough room for encoding the text.
3279 We need 33 1/3% more space, plus a newline every 76
3280 characters, and then we round up. */
3281 length
= iend
- ibeg
;
3282 allength
= length
+ length
/3 + 1;
3283 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3285 SAFE_ALLOCA (encoded
, char *, allength
);
3286 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3287 NILP (no_line_break
),
3288 !NILP (BUF_ENABLE_MULTIBYTE_CHARACTERS (current_buffer
)));
3289 if (encoded_length
> allength
)
3292 if (encoded_length
< 0)
3294 /* The encoding wasn't possible. */
3296 error ("Multibyte character in data for base64 encoding");
3299 /* Now we have encoded the region, so we insert the new contents
3300 and delete the old. (Insert first in order to preserve markers.) */
3301 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3302 insert (encoded
, encoded_length
);
3304 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3306 /* If point was outside of the region, restore it exactly; else just
3307 move to the beginning of the region. */
3308 if (old_pos
>= XFASTINT (end
))
3309 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3310 else if (old_pos
> XFASTINT (beg
))
3311 old_pos
= XFASTINT (beg
);
3314 /* We return the length of the encoded text. */
3315 return make_number (encoded_length
);
3318 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3320 doc
: /* Base64-encode STRING and return the result.
3321 Optional second argument NO-LINE-BREAK means do not break long lines
3322 into shorter lines. */)
3323 (string
, no_line_break
)
3324 Lisp_Object string
, no_line_break
;
3326 int allength
, length
, encoded_length
;
3328 Lisp_Object encoded_string
;
3331 CHECK_STRING (string
);
3333 /* We need to allocate enough room for encoding the text.
3334 We need 33 1/3% more space, plus a newline every 76
3335 characters, and then we round up. */
3336 length
= SBYTES (string
);
3337 allength
= length
+ length
/3 + 1;
3338 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3340 /* We need to allocate enough room for decoding the text. */
3341 SAFE_ALLOCA (encoded
, char *, allength
);
3343 encoded_length
= base64_encode_1 (SDATA (string
),
3344 encoded
, length
, NILP (no_line_break
),
3345 STRING_MULTIBYTE (string
));
3346 if (encoded_length
> allength
)
3349 if (encoded_length
< 0)
3351 /* The encoding wasn't possible. */
3353 error ("Multibyte character in data for base64 encoding");
3356 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3359 return encoded_string
;
3363 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3370 int counter
= 0, i
= 0;
3380 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3381 if (CHAR_BYTE8_P (c
))
3382 c
= CHAR_TO_BYTE8 (c
);
3390 /* Wrap line every 76 characters. */
3394 if (counter
< MIME_LINE_LENGTH
/ 4)
3403 /* Process first byte of a triplet. */
3405 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3406 value
= (0x03 & c
) << 4;
3408 /* Process second byte of a triplet. */
3412 *e
++ = base64_value_to_char
[value
];
3420 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3421 if (CHAR_BYTE8_P (c
))
3422 c
= CHAR_TO_BYTE8 (c
);
3430 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3431 value
= (0x0f & c
) << 2;
3433 /* Process third byte of a triplet. */
3437 *e
++ = base64_value_to_char
[value
];
3444 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3445 if (CHAR_BYTE8_P (c
))
3446 c
= CHAR_TO_BYTE8 (c
);
3454 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3455 *e
++ = base64_value_to_char
[0x3f & c
];
3462 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3464 doc
: /* Base64-decode the region between BEG and END.
3465 Return the length of the decoded text.
3466 If the region can't be decoded, signal an error and don't modify the buffer. */)
3468 Lisp_Object beg
, end
;
3470 int ibeg
, iend
, length
, allength
;
3475 int multibyte
= !NILP (BUF_ENABLE_MULTIBYTE_CHARACTERS (current_buffer
));
3478 validate_region (&beg
, &end
);
3480 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3481 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3483 length
= iend
- ibeg
;
3485 /* We need to allocate enough room for decoding the text. If we are
3486 working on a multibyte buffer, each decoded code may occupy at
3488 allength
= multibyte
? length
* 2 : length
;
3489 SAFE_ALLOCA (decoded
, char *, allength
);
3491 move_gap_both (XFASTINT (beg
), ibeg
);
3492 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3493 multibyte
, &inserted_chars
);
3494 if (decoded_length
> allength
)
3497 if (decoded_length
< 0)
3499 /* The decoding wasn't possible. */
3501 error ("Invalid base64 data");
3504 /* Now we have decoded the region, so we insert the new contents
3505 and delete the old. (Insert first in order to preserve markers.) */
3506 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3507 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3510 /* Delete the original text. */
3511 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3512 iend
+ decoded_length
, 1);
3514 /* If point was outside of the region, restore it exactly; else just
3515 move to the beginning of the region. */
3516 if (old_pos
>= XFASTINT (end
))
3517 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3518 else if (old_pos
> XFASTINT (beg
))
3519 old_pos
= XFASTINT (beg
);
3520 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3522 return make_number (inserted_chars
);
3525 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3527 doc
: /* Base64-decode STRING and return the result. */)
3532 int length
, decoded_length
;
3533 Lisp_Object decoded_string
;
3536 CHECK_STRING (string
);
3538 length
= SBYTES (string
);
3539 /* We need to allocate enough room for decoding the text. */
3540 SAFE_ALLOCA (decoded
, char *, length
);
3542 /* The decoded result should be unibyte. */
3543 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3545 if (decoded_length
> length
)
3547 else if (decoded_length
>= 0)
3548 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3550 decoded_string
= Qnil
;
3553 if (!STRINGP (decoded_string
))
3554 error ("Invalid base64 data");
3556 return decoded_string
;
3559 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3560 MULTIBYTE is nonzero, the decoded result should be in multibyte
3561 form. If NCHARS_RETRUN is not NULL, store the number of produced
3562 characters in *NCHARS_RETURN. */
3565 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3575 unsigned long value
;
3580 /* Process first byte of a quadruplet. */
3582 READ_QUADRUPLET_BYTE (e
-to
);
3586 value
= base64_char_to_value
[c
] << 18;
3588 /* Process second byte of a quadruplet. */
3590 READ_QUADRUPLET_BYTE (-1);
3594 value
|= base64_char_to_value
[c
] << 12;
3596 c
= (unsigned char) (value
>> 16);
3597 if (multibyte
&& c
>= 128)
3598 e
+= BYTE8_STRING (c
, e
);
3603 /* Process third byte of a quadruplet. */
3605 READ_QUADRUPLET_BYTE (-1);
3609 READ_QUADRUPLET_BYTE (-1);
3618 value
|= base64_char_to_value
[c
] << 6;
3620 c
= (unsigned char) (0xff & value
>> 8);
3621 if (multibyte
&& c
>= 128)
3622 e
+= BYTE8_STRING (c
, e
);
3627 /* Process fourth byte of a quadruplet. */
3629 READ_QUADRUPLET_BYTE (-1);
3636 value
|= base64_char_to_value
[c
];
3638 c
= (unsigned char) (0xff & value
);
3639 if (multibyte
&& c
>= 128)
3640 e
+= BYTE8_STRING (c
, e
);
3649 /***********************************************************************
3651 ***** Hash Tables *****
3653 ***********************************************************************/
3655 /* Implemented by gerd@gnu.org. This hash table implementation was
3656 inspired by CMUCL hash tables. */
3660 1. For small tables, association lists are probably faster than
3661 hash tables because they have lower overhead.
3663 For uses of hash tables where the O(1) behavior of table
3664 operations is not a requirement, it might therefore be a good idea
3665 not to hash. Instead, we could just do a linear search in the
3666 key_and_value vector of the hash table. This could be done
3667 if a `:linear-search t' argument is given to make-hash-table. */
3670 /* The list of all weak hash tables. Don't staticpro this one. */
3672 struct Lisp_Hash_Table
*weak_hash_tables
;
3674 /* Various symbols. */
3676 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3677 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3678 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3680 /* Function prototypes. */
3682 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3683 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3684 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3685 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3686 Lisp_Object
, unsigned));
3687 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3688 Lisp_Object
, unsigned));
3689 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3690 unsigned, Lisp_Object
, unsigned));
3691 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3692 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3693 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3694 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3696 static unsigned sxhash_string
P_ ((unsigned char *, int));
3697 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3698 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3699 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3700 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3704 /***********************************************************************
3706 ***********************************************************************/
3708 /* If OBJ is a Lisp hash table, return a pointer to its struct
3709 Lisp_Hash_Table. Otherwise, signal an error. */
3711 static struct Lisp_Hash_Table
*
3712 check_hash_table (obj
)
3715 CHECK_HASH_TABLE (obj
);
3716 return XHASH_TABLE (obj
);
3720 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3724 next_almost_prime (n
)
3737 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3738 which USED[I] is non-zero. If found at index I in ARGS, set
3739 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3740 -1. This function is used to extract a keyword/argument pair from
3741 a DEFUN parameter list. */
3744 get_key_arg (key
, nargs
, args
, used
)
3752 for (i
= 0; i
< nargs
- 1; ++i
)
3753 if (!used
[i
] && EQ (args
[i
], key
))
3768 /* Return a Lisp vector which has the same contents as VEC but has
3769 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3770 vector that are not copied from VEC are set to INIT. */
3773 larger_vector (vec
, new_size
, init
)
3778 struct Lisp_Vector
*v
;
3781 xassert (VECTORP (vec
));
3782 old_size
= ASIZE (vec
);
3783 xassert (new_size
>= old_size
);
3785 v
= allocate_vector (new_size
);
3786 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3787 old_size
* sizeof *v
->contents
);
3788 for (i
= old_size
; i
< new_size
; ++i
)
3789 v
->contents
[i
] = init
;
3790 XSETVECTOR (vec
, v
);
3795 /***********************************************************************
3797 ***********************************************************************/
3799 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3800 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3801 KEY2 are the same. */
3804 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3805 struct Lisp_Hash_Table
*h
;
3806 Lisp_Object key1
, key2
;
3807 unsigned hash1
, hash2
;
3809 return (FLOATP (key1
)
3811 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3815 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3816 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3817 KEY2 are the same. */
3820 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3821 struct Lisp_Hash_Table
*h
;
3822 Lisp_Object key1
, key2
;
3823 unsigned hash1
, hash2
;
3825 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3829 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3830 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3831 if KEY1 and KEY2 are the same. */
3834 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3835 struct Lisp_Hash_Table
*h
;
3836 Lisp_Object key1
, key2
;
3837 unsigned hash1
, hash2
;
3841 Lisp_Object args
[3];
3843 args
[0] = h
->user_cmp_function
;
3846 return !NILP (Ffuncall (3, args
));
3853 /* Value is a hash code for KEY for use in hash table H which uses
3854 `eq' to compare keys. The hash code returned is guaranteed to fit
3855 in a Lisp integer. */
3859 struct Lisp_Hash_Table
*h
;
3862 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3863 xassert ((hash
& ~INTMASK
) == 0);
3868 /* Value is a hash code for KEY for use in hash table H which uses
3869 `eql' to compare keys. The hash code returned is guaranteed to fit
3870 in a Lisp integer. */
3874 struct Lisp_Hash_Table
*h
;
3879 hash
= sxhash (key
, 0);
3881 hash
= XUINT (key
) ^ XTYPE (key
);
3882 xassert ((hash
& ~INTMASK
) == 0);
3887 /* Value is a hash code for KEY for use in hash table H which uses
3888 `equal' to compare keys. The hash code returned is guaranteed to fit
3889 in a Lisp integer. */
3892 hashfn_equal (h
, key
)
3893 struct Lisp_Hash_Table
*h
;
3896 unsigned hash
= sxhash (key
, 0);
3897 xassert ((hash
& ~INTMASK
) == 0);
3902 /* Value is a hash code for KEY for use in hash table H which uses as
3903 user-defined function to compare keys. The hash code returned is
3904 guaranteed to fit in a Lisp integer. */
3907 hashfn_user_defined (h
, key
)
3908 struct Lisp_Hash_Table
*h
;
3911 Lisp_Object args
[2], hash
;
3913 args
[0] = h
->user_hash_function
;
3915 hash
= Ffuncall (2, args
);
3916 if (!INTEGERP (hash
))
3917 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3918 return XUINT (hash
);
3922 /* Create and initialize a new hash table.
3924 TEST specifies the test the hash table will use to compare keys.
3925 It must be either one of the predefined tests `eq', `eql' or
3926 `equal' or a symbol denoting a user-defined test named TEST with
3927 test and hash functions USER_TEST and USER_HASH.
3929 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3931 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3932 new size when it becomes full is computed by adding REHASH_SIZE to
3933 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3934 table's new size is computed by multiplying its old size with
3937 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3938 be resized when the ratio of (number of entries in the table) /
3939 (table size) is >= REHASH_THRESHOLD.
3941 WEAK specifies the weakness of the table. If non-nil, it must be
3942 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3945 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3946 user_test
, user_hash
)
3947 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3948 Lisp_Object user_test
, user_hash
;
3950 struct Lisp_Hash_Table
*h
;
3952 int index_size
, i
, sz
;
3954 /* Preconditions. */
3955 xassert (SYMBOLP (test
));
3956 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3957 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3958 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3959 xassert (FLOATP (rehash_threshold
)
3960 && XFLOATINT (rehash_threshold
) > 0
3961 && XFLOATINT (rehash_threshold
) <= 1.0);
3963 if (XFASTINT (size
) == 0)
3964 size
= make_number (1);
3966 /* Allocate a table and initialize it. */
3967 h
= allocate_hash_table ();
3969 /* Initialize hash table slots. */
3970 sz
= XFASTINT (size
);
3973 if (EQ (test
, Qeql
))
3975 h
->cmpfn
= cmpfn_eql
;
3976 h
->hashfn
= hashfn_eql
;
3978 else if (EQ (test
, Qeq
))
3981 h
->hashfn
= hashfn_eq
;
3983 else if (EQ (test
, Qequal
))
3985 h
->cmpfn
= cmpfn_equal
;
3986 h
->hashfn
= hashfn_equal
;
3990 h
->user_cmp_function
= user_test
;
3991 h
->user_hash_function
= user_hash
;
3992 h
->cmpfn
= cmpfn_user_defined
;
3993 h
->hashfn
= hashfn_user_defined
;
3997 h
->rehash_threshold
= rehash_threshold
;
3998 h
->rehash_size
= rehash_size
;
4000 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4001 h
->hash
= Fmake_vector (size
, Qnil
);
4002 h
->next
= Fmake_vector (size
, Qnil
);
4003 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4004 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4005 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4007 /* Set up the free list. */
4008 for (i
= 0; i
< sz
- 1; ++i
)
4009 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4010 h
->next_free
= make_number (0);
4012 XSET_HASH_TABLE (table
, h
);
4013 xassert (HASH_TABLE_P (table
));
4014 xassert (XHASH_TABLE (table
) == h
);
4016 /* Maybe add this hash table to the list of all weak hash tables. */
4018 h
->next_weak
= NULL
;
4021 h
->next_weak
= weak_hash_tables
;
4022 weak_hash_tables
= h
;
4029 /* Return a copy of hash table H1. Keys and values are not copied,
4030 only the table itself is. */
4033 copy_hash_table (h1
)
4034 struct Lisp_Hash_Table
*h1
;
4037 struct Lisp_Hash_Table
*h2
;
4038 struct Lisp_Vector
*next
;
4040 h2
= allocate_hash_table ();
4041 next
= h2
->vec_next
;
4042 bcopy (h1
, h2
, sizeof *h2
);
4043 h2
->vec_next
= next
;
4044 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4045 h2
->hash
= Fcopy_sequence (h1
->hash
);
4046 h2
->next
= Fcopy_sequence (h1
->next
);
4047 h2
->index
= Fcopy_sequence (h1
->index
);
4048 XSET_HASH_TABLE (table
, h2
);
4050 /* Maybe add this hash table to the list of all weak hash tables. */
4051 if (!NILP (h2
->weak
))
4053 h2
->next_weak
= weak_hash_tables
;
4054 weak_hash_tables
= h2
;
4061 /* Resize hash table H if it's too full. If H cannot be resized
4062 because it's already too large, throw an error. */
4065 maybe_resize_hash_table (h
)
4066 struct Lisp_Hash_Table
*h
;
4068 if (NILP (h
->next_free
))
4070 int old_size
= HASH_TABLE_SIZE (h
);
4071 int i
, new_size
, index_size
;
4074 if (INTEGERP (h
->rehash_size
))
4075 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4077 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4078 new_size
= max (old_size
+ 1, new_size
);
4079 index_size
= next_almost_prime ((int)
4081 / XFLOATINT (h
->rehash_threshold
)));
4082 /* Assignment to EMACS_INT stops GCC whining about limited range
4084 nsize
= max (index_size
, 2 * new_size
);
4085 if (nsize
> MOST_POSITIVE_FIXNUM
)
4086 error ("Hash table too large to resize");
4088 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4089 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4090 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4091 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4093 /* Update the free list. Do it so that new entries are added at
4094 the end of the free list. This makes some operations like
4096 for (i
= old_size
; i
< new_size
- 1; ++i
)
4097 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4099 if (!NILP (h
->next_free
))
4101 Lisp_Object last
, next
;
4103 last
= h
->next_free
;
4104 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4108 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4111 XSETFASTINT (h
->next_free
, old_size
);
4114 for (i
= 0; i
< old_size
; ++i
)
4115 if (!NILP (HASH_HASH (h
, i
)))
4117 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4118 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4119 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4120 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4126 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4127 the hash code of KEY. Value is the index of the entry in H
4128 matching KEY, or -1 if not found. */
4131 hash_lookup (h
, key
, hash
)
4132 struct Lisp_Hash_Table
*h
;
4137 int start_of_bucket
;
4140 hash_code
= h
->hashfn (h
, key
);
4144 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4145 idx
= HASH_INDEX (h
, start_of_bucket
);
4147 /* We need not gcpro idx since it's either an integer or nil. */
4150 int i
= XFASTINT (idx
);
4151 if (EQ (key
, HASH_KEY (h
, i
))
4153 && h
->cmpfn (h
, key
, hash_code
,
4154 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4156 idx
= HASH_NEXT (h
, i
);
4159 return NILP (idx
) ? -1 : XFASTINT (idx
);
4163 /* Put an entry into hash table H that associates KEY with VALUE.
4164 HASH is a previously computed hash code of KEY.
4165 Value is the index of the entry in H matching KEY. */
4168 hash_put (h
, key
, value
, hash
)
4169 struct Lisp_Hash_Table
*h
;
4170 Lisp_Object key
, value
;
4173 int start_of_bucket
, i
;
4175 xassert ((hash
& ~INTMASK
) == 0);
4177 /* Increment count after resizing because resizing may fail. */
4178 maybe_resize_hash_table (h
);
4181 /* Store key/value in the key_and_value vector. */
4182 i
= XFASTINT (h
->next_free
);
4183 h
->next_free
= HASH_NEXT (h
, i
);
4184 HASH_KEY (h
, i
) = key
;
4185 HASH_VALUE (h
, i
) = value
;
4187 /* Remember its hash code. */
4188 HASH_HASH (h
, i
) = make_number (hash
);
4190 /* Add new entry to its collision chain. */
4191 start_of_bucket
= hash
% ASIZE (h
->index
);
4192 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4193 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4198 /* Remove the entry matching KEY from hash table H, if there is one. */
4201 hash_remove_from_table (h
, key
)
4202 struct Lisp_Hash_Table
*h
;
4206 int start_of_bucket
;
4207 Lisp_Object idx
, prev
;
4209 hash_code
= h
->hashfn (h
, key
);
4210 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4211 idx
= HASH_INDEX (h
, start_of_bucket
);
4214 /* We need not gcpro idx, prev since they're either integers or nil. */
4217 int i
= XFASTINT (idx
);
4219 if (EQ (key
, HASH_KEY (h
, i
))
4221 && h
->cmpfn (h
, key
, hash_code
,
4222 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4224 /* Take entry out of collision chain. */
4226 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4228 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4230 /* Clear slots in key_and_value and add the slots to
4232 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4233 HASH_NEXT (h
, i
) = h
->next_free
;
4234 h
->next_free
= make_number (i
);
4236 xassert (h
->count
>= 0);
4242 idx
= HASH_NEXT (h
, i
);
4248 /* Clear hash table H. */
4252 struct Lisp_Hash_Table
*h
;
4256 int i
, size
= HASH_TABLE_SIZE (h
);
4258 for (i
= 0; i
< size
; ++i
)
4260 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4261 HASH_KEY (h
, i
) = Qnil
;
4262 HASH_VALUE (h
, i
) = Qnil
;
4263 HASH_HASH (h
, i
) = Qnil
;
4266 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4267 ASET (h
->index
, i
, Qnil
);
4269 h
->next_free
= make_number (0);
4276 /************************************************************************
4278 ************************************************************************/
4281 init_weak_hash_tables ()
4283 weak_hash_tables
= NULL
;
4286 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4287 entries from the table that don't survive the current GC.
4288 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4289 non-zero if anything was marked. */
4292 sweep_weak_table (h
, remove_entries_p
)
4293 struct Lisp_Hash_Table
*h
;
4294 int remove_entries_p
;
4296 int bucket
, n
, marked
;
4298 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4301 for (bucket
= 0; bucket
< n
; ++bucket
)
4303 Lisp_Object idx
, next
, prev
;
4305 /* Follow collision chain, removing entries that
4306 don't survive this garbage collection. */
4308 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4310 int i
= XFASTINT (idx
);
4311 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4312 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4315 if (EQ (h
->weak
, Qkey
))
4316 remove_p
= !key_known_to_survive_p
;
4317 else if (EQ (h
->weak
, Qvalue
))
4318 remove_p
= !value_known_to_survive_p
;
4319 else if (EQ (h
->weak
, Qkey_or_value
))
4320 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4321 else if (EQ (h
->weak
, Qkey_and_value
))
4322 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4326 next
= HASH_NEXT (h
, i
);
4328 if (remove_entries_p
)
4332 /* Take out of collision chain. */
4334 HASH_INDEX (h
, bucket
) = next
;
4336 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4338 /* Add to free list. */
4339 HASH_NEXT (h
, i
) = h
->next_free
;
4342 /* Clear key, value, and hash. */
4343 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4344 HASH_HASH (h
, i
) = Qnil
;
4357 /* Make sure key and value survive. */
4358 if (!key_known_to_survive_p
)
4360 mark_object (HASH_KEY (h
, i
));
4364 if (!value_known_to_survive_p
)
4366 mark_object (HASH_VALUE (h
, i
));
4377 /* Remove elements from weak hash tables that don't survive the
4378 current garbage collection. Remove weak tables that don't survive
4379 from Vweak_hash_tables. Called from gc_sweep. */
4382 sweep_weak_hash_tables ()
4384 struct Lisp_Hash_Table
*h
, *used
, *next
;
4387 /* Mark all keys and values that are in use. Keep on marking until
4388 there is no more change. This is necessary for cases like
4389 value-weak table A containing an entry X -> Y, where Y is used in a
4390 key-weak table B, Z -> Y. If B comes after A in the list of weak
4391 tables, X -> Y might be removed from A, although when looking at B
4392 one finds that it shouldn't. */
4396 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4398 if (h
->size
& ARRAY_MARK_FLAG
)
4399 marked
|= sweep_weak_table (h
, 0);
4404 /* Remove tables and entries that aren't used. */
4405 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4407 next
= h
->next_weak
;
4409 if (h
->size
& ARRAY_MARK_FLAG
)
4411 /* TABLE is marked as used. Sweep its contents. */
4413 sweep_weak_table (h
, 1);
4415 /* Add table to the list of used weak hash tables. */
4416 h
->next_weak
= used
;
4421 weak_hash_tables
= used
;
4426 /***********************************************************************
4427 Hash Code Computation
4428 ***********************************************************************/
4430 /* Maximum depth up to which to dive into Lisp structures. */
4432 #define SXHASH_MAX_DEPTH 3
4434 /* Maximum length up to which to take list and vector elements into
4437 #define SXHASH_MAX_LEN 7
4439 /* Combine two integers X and Y for hashing. */
4441 #define SXHASH_COMBINE(X, Y) \
4442 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4446 /* Return a hash for string PTR which has length LEN. The hash
4447 code returned is guaranteed to fit in a Lisp integer. */
4450 sxhash_string (ptr
, len
)
4454 unsigned char *p
= ptr
;
4455 unsigned char *end
= p
+ len
;
4464 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4467 return hash
& INTMASK
;
4471 /* Return a hash for list LIST. DEPTH is the current depth in the
4472 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4475 sxhash_list (list
, depth
)
4482 if (depth
< SXHASH_MAX_DEPTH
)
4484 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4485 list
= XCDR (list
), ++i
)
4487 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4488 hash
= SXHASH_COMBINE (hash
, hash2
);
4493 unsigned hash2
= sxhash (list
, depth
+ 1);
4494 hash
= SXHASH_COMBINE (hash
, hash2
);
4501 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4502 the Lisp structure. */
4505 sxhash_vector (vec
, depth
)
4509 unsigned hash
= ASIZE (vec
);
4512 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4513 for (i
= 0; i
< n
; ++i
)
4515 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4516 hash
= SXHASH_COMBINE (hash
, hash2
);
4523 /* Return a hash for bool-vector VECTOR. */
4526 sxhash_bool_vector (vec
)
4529 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4532 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4533 for (i
= 0; i
< n
; ++i
)
4534 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4540 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4541 structure. Value is an unsigned integer clipped to INTMASK. */
4550 if (depth
> SXHASH_MAX_DEPTH
)
4553 switch (XTYPE (obj
))
4564 obj
= SYMBOL_NAME (obj
);
4568 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4571 /* This can be everything from a vector to an overlay. */
4572 case Lisp_Vectorlike
:
4574 /* According to the CL HyperSpec, two arrays are equal only if
4575 they are `eq', except for strings and bit-vectors. In
4576 Emacs, this works differently. We have to compare element
4578 hash
= sxhash_vector (obj
, depth
);
4579 else if (BOOL_VECTOR_P (obj
))
4580 hash
= sxhash_bool_vector (obj
);
4582 /* Others are `equal' if they are `eq', so let's take their
4588 hash
= sxhash_list (obj
, depth
);
4593 double val
= XFLOAT_DATA (obj
);
4594 unsigned char *p
= (unsigned char *) &val
;
4595 unsigned char *e
= p
+ sizeof val
;
4596 for (hash
= 0; p
< e
; ++p
)
4597 hash
= SXHASH_COMBINE (hash
, *p
);
4605 return hash
& INTMASK
;
4610 /***********************************************************************
4612 ***********************************************************************/
4615 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4616 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4620 unsigned hash
= sxhash (obj
, 0);
4621 return make_number (hash
);
4625 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4626 doc
: /* Create and return a new hash table.
4628 Arguments are specified as keyword/argument pairs. The following
4629 arguments are defined:
4631 :test TEST -- TEST must be a symbol that specifies how to compare
4632 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4633 `equal'. User-supplied test and hash functions can be specified via
4634 `define-hash-table-test'.
4636 :size SIZE -- A hint as to how many elements will be put in the table.
4639 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4640 fills up. If REHASH-SIZE is an integer, add that many space. If it
4641 is a float, it must be > 1.0, and the new size is computed by
4642 multiplying the old size with that factor. Default is 1.5.
4644 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4645 Resize the hash table when ratio of the number of entries in the
4646 table. Default is 0.8.
4648 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4649 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4650 returned is a weak table. Key/value pairs are removed from a weak
4651 hash table when there are no non-weak references pointing to their
4652 key, value, one of key or value, or both key and value, depending on
4653 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4656 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4661 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4662 Lisp_Object user_test
, user_hash
;
4666 /* The vector `used' is used to keep track of arguments that
4667 have been consumed. */
4668 used
= (char *) alloca (nargs
* sizeof *used
);
4669 bzero (used
, nargs
* sizeof *used
);
4671 /* See if there's a `:test TEST' among the arguments. */
4672 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4673 test
= i
< 0 ? Qeql
: args
[i
];
4674 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4676 /* See if it is a user-defined test. */
4679 prop
= Fget (test
, Qhash_table_test
);
4680 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4681 signal_error ("Invalid hash table test", test
);
4682 user_test
= XCAR (prop
);
4683 user_hash
= XCAR (XCDR (prop
));
4686 user_test
= user_hash
= Qnil
;
4688 /* See if there's a `:size SIZE' argument. */
4689 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4690 size
= i
< 0 ? Qnil
: args
[i
];
4692 size
= make_number (DEFAULT_HASH_SIZE
);
4693 else if (!INTEGERP (size
) || XINT (size
) < 0)
4694 signal_error ("Invalid hash table size", size
);
4696 /* Look for `:rehash-size SIZE'. */
4697 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4698 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4699 if (!NUMBERP (rehash_size
)
4700 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4701 || XFLOATINT (rehash_size
) <= 1.0)
4702 signal_error ("Invalid hash table rehash size", rehash_size
);
4704 /* Look for `:rehash-threshold THRESHOLD'. */
4705 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4706 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4707 if (!FLOATP (rehash_threshold
)
4708 || XFLOATINT (rehash_threshold
) <= 0.0
4709 || XFLOATINT (rehash_threshold
) > 1.0)
4710 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4712 /* Look for `:weakness WEAK'. */
4713 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4714 weak
= i
< 0 ? Qnil
: args
[i
];
4716 weak
= Qkey_and_value
;
4719 && !EQ (weak
, Qvalue
)
4720 && !EQ (weak
, Qkey_or_value
)
4721 && !EQ (weak
, Qkey_and_value
))
4722 signal_error ("Invalid hash table weakness", weak
);
4724 /* Now, all args should have been used up, or there's a problem. */
4725 for (i
= 0; i
< nargs
; ++i
)
4727 signal_error ("Invalid argument list", args
[i
]);
4729 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4730 user_test
, user_hash
);
4734 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4735 doc
: /* Return a copy of hash table TABLE. */)
4739 return copy_hash_table (check_hash_table (table
));
4743 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4744 doc
: /* Return the number of elements in TABLE. */)
4748 return make_number (check_hash_table (table
)->count
);
4752 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4753 Shash_table_rehash_size
, 1, 1, 0,
4754 doc
: /* Return the current rehash size of TABLE. */)
4758 return check_hash_table (table
)->rehash_size
;
4762 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4763 Shash_table_rehash_threshold
, 1, 1, 0,
4764 doc
: /* Return the current rehash threshold of TABLE. */)
4768 return check_hash_table (table
)->rehash_threshold
;
4772 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4773 doc
: /* Return the size of TABLE.
4774 The size can be used as an argument to `make-hash-table' to create
4775 a hash table than can hold as many elements of TABLE holds
4776 without need for resizing. */)
4780 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4781 return make_number (HASH_TABLE_SIZE (h
));
4785 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4786 doc
: /* Return the test TABLE uses. */)
4790 return check_hash_table (table
)->test
;
4794 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4796 doc
: /* Return the weakness of TABLE. */)
4800 return check_hash_table (table
)->weak
;
4804 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4805 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4809 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4813 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4814 doc
: /* Clear hash table TABLE and return it. */)
4818 hash_clear (check_hash_table (table
));
4819 /* Be compatible with XEmacs. */
4824 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4825 doc
: /* Look up KEY in TABLE and return its associated value.
4826 If KEY is not found, return DFLT which defaults to nil. */)
4828 Lisp_Object key
, table
, dflt
;
4830 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4831 int i
= hash_lookup (h
, key
, NULL
);
4832 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4836 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4837 doc
: /* Associate KEY with VALUE in hash table TABLE.
4838 If KEY is already present in table, replace its current value with
4841 Lisp_Object key
, value
, table
;
4843 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4847 i
= hash_lookup (h
, key
, &hash
);
4849 HASH_VALUE (h
, i
) = value
;
4851 hash_put (h
, key
, value
, hash
);
4857 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4858 doc
: /* Remove KEY from TABLE. */)
4860 Lisp_Object key
, table
;
4862 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4863 hash_remove_from_table (h
, key
);
4868 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4869 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4870 FUNCTION is called with two arguments, KEY and VALUE. */)
4872 Lisp_Object function
, table
;
4874 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4875 Lisp_Object args
[3];
4878 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4879 if (!NILP (HASH_HASH (h
, i
)))
4882 args
[1] = HASH_KEY (h
, i
);
4883 args
[2] = HASH_VALUE (h
, i
);
4891 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4892 Sdefine_hash_table_test
, 3, 3, 0,
4893 doc
: /* Define a new hash table test with name NAME, a symbol.
4895 In hash tables created with NAME specified as test, use TEST to
4896 compare keys, and HASH for computing hash codes of keys.
4898 TEST must be a function taking two arguments and returning non-nil if
4899 both arguments are the same. HASH must be a function taking one
4900 argument and return an integer that is the hash code of the argument.
4901 Hash code computation should use the whole value range of integers,
4902 including negative integers. */)
4904 Lisp_Object name
, test
, hash
;
4906 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4911 /************************************************************************
4913 ************************************************************************/
4917 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4918 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4920 A message digest is a cryptographic checksum of a document, and the
4921 algorithm to calculate it is defined in RFC 1321.
4923 The two optional arguments START and END are character positions
4924 specifying for which part of OBJECT the message digest should be
4925 computed. If nil or omitted, the digest is computed for the whole
4928 The MD5 message digest is computed from the result of encoding the
4929 text in a coding system, not directly from the internal Emacs form of
4930 the text. The optional fourth argument CODING-SYSTEM specifies which
4931 coding system to encode the text with. It should be the same coding
4932 system that you used or will use when actually writing the text into a
4935 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4936 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4937 system would be chosen by default for writing this text into a file.
4939 If OBJECT is a string, the most preferred coding system (see the
4940 command `prefer-coding-system') is used.
4942 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4943 guesswork fails. Normally, an error is signaled in such case. */)
4944 (object
, start
, end
, coding_system
, noerror
)
4945 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4947 unsigned char digest
[16];
4948 unsigned char value
[33];
4952 int start_char
= 0, end_char
= 0;
4953 int start_byte
= 0, end_byte
= 0;
4955 register struct buffer
*bp
;
4958 if (STRINGP (object
))
4960 if (NILP (coding_system
))
4962 /* Decide the coding-system to encode the data with. */
4964 if (STRING_MULTIBYTE (object
))
4965 /* use default, we can't guess correct value */
4966 coding_system
= preferred_coding_system ();
4968 coding_system
= Qraw_text
;
4971 if (NILP (Fcoding_system_p (coding_system
)))
4973 /* Invalid coding system. */
4975 if (!NILP (noerror
))
4976 coding_system
= Qraw_text
;
4978 xsignal1 (Qcoding_system_error
, coding_system
);
4981 if (STRING_MULTIBYTE (object
))
4982 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4984 size
= SCHARS (object
);
4985 size_byte
= SBYTES (object
);
4989 CHECK_NUMBER (start
);
4991 start_char
= XINT (start
);
4996 start_byte
= string_char_to_byte (object
, start_char
);
5002 end_byte
= size_byte
;
5008 end_char
= XINT (end
);
5013 end_byte
= string_char_to_byte (object
, end_char
);
5016 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5017 args_out_of_range_3 (object
, make_number (start_char
),
5018 make_number (end_char
));
5022 struct buffer
*prev
= current_buffer
;
5024 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5026 CHECK_BUFFER (object
);
5028 bp
= XBUFFER (object
);
5029 if (bp
!= current_buffer
)
5030 set_buffer_internal (bp
);
5036 CHECK_NUMBER_COERCE_MARKER (start
);
5044 CHECK_NUMBER_COERCE_MARKER (end
);
5049 temp
= b
, b
= e
, e
= temp
;
5051 if (!(BEGV
<= b
&& e
<= ZV
))
5052 args_out_of_range (start
, end
);
5054 if (NILP (coding_system
))
5056 /* Decide the coding-system to encode the data with.
5057 See fileio.c:Fwrite-region */
5059 if (!NILP (Vcoding_system_for_write
))
5060 coding_system
= Vcoding_system_for_write
;
5063 int force_raw_text
= 0;
5065 coding_system
= BUF_BUFFER_FILE_CODING_SYSTEM (XBUFFER (object
));
5066 if (NILP (coding_system
)
5067 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5069 coding_system
= Qnil
;
5070 if (NILP (BUF_ENABLE_MULTIBYTE_CHARACTERS (current_buffer
)))
5074 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5076 /* Check file-coding-system-alist. */
5077 Lisp_Object args
[4], val
;
5079 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5080 args
[3] = Fbuffer_file_name(object
);
5081 val
= Ffind_operation_coding_system (4, args
);
5082 if (CONSP (val
) && !NILP (XCDR (val
)))
5083 coding_system
= XCDR (val
);
5086 if (NILP (coding_system
)
5087 && !NILP (BUF_BUFFER_FILE_CODING_SYSTEM (XBUFFER (object
))))
5089 /* If we still have not decided a coding system, use the
5090 default value of buffer-file-coding-system. */
5091 coding_system
= BUF_BUFFER_FILE_CODING_SYSTEM (XBUFFER (object
));
5095 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5096 /* Confirm that VAL can surely encode the current region. */
5097 coding_system
= call4 (Vselect_safe_coding_system_function
,
5098 make_number (b
), make_number (e
),
5099 coding_system
, Qnil
);
5102 coding_system
= Qraw_text
;
5105 if (NILP (Fcoding_system_p (coding_system
)))
5107 /* Invalid coding system. */
5109 if (!NILP (noerror
))
5110 coding_system
= Qraw_text
;
5112 xsignal1 (Qcoding_system_error
, coding_system
);
5116 object
= make_buffer_string (b
, e
, 0);
5117 if (prev
!= current_buffer
)
5118 set_buffer_internal (prev
);
5119 /* Discard the unwind protect for recovering the current
5123 if (STRING_MULTIBYTE (object
))
5124 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5127 md5_buffer (SDATA (object
) + start_byte
,
5128 SBYTES (object
) - (size_byte
- end_byte
),
5131 for (i
= 0; i
< 16; i
++)
5132 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5135 return make_string (value
, 32);
5142 /* Hash table stuff. */
5143 Qhash_table_p
= intern_c_string ("hash-table-p");
5144 staticpro (&Qhash_table_p
);
5145 Qeq
= intern_c_string ("eq");
5147 Qeql
= intern_c_string ("eql");
5149 Qequal
= intern_c_string ("equal");
5150 staticpro (&Qequal
);
5151 QCtest
= intern_c_string (":test");
5152 staticpro (&QCtest
);
5153 QCsize
= intern_c_string (":size");
5154 staticpro (&QCsize
);
5155 QCrehash_size
= intern_c_string (":rehash-size");
5156 staticpro (&QCrehash_size
);
5157 QCrehash_threshold
= intern_c_string (":rehash-threshold");
5158 staticpro (&QCrehash_threshold
);
5159 QCweakness
= intern_c_string (":weakness");
5160 staticpro (&QCweakness
);
5161 Qkey
= intern_c_string ("key");
5163 Qvalue
= intern_c_string ("value");
5164 staticpro (&Qvalue
);
5165 Qhash_table_test
= intern_c_string ("hash-table-test");
5166 staticpro (&Qhash_table_test
);
5167 Qkey_or_value
= intern_c_string ("key-or-value");
5168 staticpro (&Qkey_or_value
);
5169 Qkey_and_value
= intern_c_string ("key-and-value");
5170 staticpro (&Qkey_and_value
);
5173 defsubr (&Smake_hash_table
);
5174 defsubr (&Scopy_hash_table
);
5175 defsubr (&Shash_table_count
);
5176 defsubr (&Shash_table_rehash_size
);
5177 defsubr (&Shash_table_rehash_threshold
);
5178 defsubr (&Shash_table_size
);
5179 defsubr (&Shash_table_test
);
5180 defsubr (&Shash_table_weakness
);
5181 defsubr (&Shash_table_p
);
5182 defsubr (&Sclrhash
);
5183 defsubr (&Sgethash
);
5184 defsubr (&Sputhash
);
5185 defsubr (&Sremhash
);
5186 defsubr (&Smaphash
);
5187 defsubr (&Sdefine_hash_table_test
);
5189 Qstring_lessp
= intern_c_string ("string-lessp");
5190 staticpro (&Qstring_lessp
);
5191 Qprovide
= intern_c_string ("provide");
5192 staticpro (&Qprovide
);
5193 Qrequire
= intern_c_string ("require");
5194 staticpro (&Qrequire
);
5195 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
5196 staticpro (&Qyes_or_no_p_history
);
5197 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
5198 staticpro (&Qcursor_in_echo_area
);
5199 Qwidget_type
= intern_c_string ("widget-type");
5200 staticpro (&Qwidget_type
);
5202 staticpro (&string_char_byte_cache_string
);
5203 string_char_byte_cache_string
= Qnil
;
5205 require_nesting_list
= Qnil
;
5206 staticpro (&require_nesting_list
);
5208 Fset (Qyes_or_no_p_history
, Qnil
);
5210 DEFVAR_LISP ("features", &Vfeatures
,
5211 doc
: /* A list of symbols which are the features of the executing Emacs.
5212 Used by `featurep' and `require', and altered by `provide'. */);
5213 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
5214 Qsubfeatures
= intern_c_string ("subfeatures");
5215 staticpro (&Qsubfeatures
);
5217 #ifdef HAVE_LANGINFO_CODESET
5218 Qcodeset
= intern_c_string ("codeset");
5219 staticpro (&Qcodeset
);
5220 Qdays
= intern_c_string ("days");
5222 Qmonths
= intern_c_string ("months");
5223 staticpro (&Qmonths
);
5224 Qpaper
= intern_c_string ("paper");
5225 staticpro (&Qpaper
);
5226 #endif /* HAVE_LANGINFO_CODESET */
5228 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5229 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5230 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5231 invoked by mouse clicks and mouse menu items.
5233 On some platforms, file selection dialogs are also enabled if this is
5237 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5238 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5239 This applies to commands from menus and tool bar buttons even when
5240 they are initiated from the keyboard. If `use-dialog-box' is nil,
5241 that disables the use of a file dialog, regardless of the value of
5243 use_file_dialog
= 1;
5245 defsubr (&Sidentity
);
5248 defsubr (&Ssafe_length
);
5249 defsubr (&Sstring_bytes
);
5250 defsubr (&Sstring_equal
);
5251 defsubr (&Scompare_strings
);
5252 defsubr (&Sstring_lessp
);
5255 defsubr (&Svconcat
);
5256 defsubr (&Scopy_sequence
);
5257 defsubr (&Sstring_make_multibyte
);
5258 defsubr (&Sstring_make_unibyte
);
5259 defsubr (&Sstring_as_multibyte
);
5260 defsubr (&Sstring_as_unibyte
);
5261 defsubr (&Sstring_to_multibyte
);
5262 defsubr (&Sstring_to_unibyte
);
5263 defsubr (&Scopy_alist
);
5264 defsubr (&Ssubstring
);
5265 defsubr (&Ssubstring_no_properties
);
5278 defsubr (&Snreverse
);
5279 defsubr (&Sreverse
);
5281 defsubr (&Splist_get
);
5283 defsubr (&Splist_put
);
5285 defsubr (&Slax_plist_get
);
5286 defsubr (&Slax_plist_put
);
5289 defsubr (&Sequal_including_properties
);
5290 defsubr (&Sfillarray
);
5291 defsubr (&Sclear_string
);
5295 defsubr (&Smapconcat
);
5296 defsubr (&Sy_or_n_p
);
5297 defsubr (&Syes_or_no_p
);
5298 defsubr (&Sload_average
);
5299 defsubr (&Sfeaturep
);
5300 defsubr (&Srequire
);
5301 defsubr (&Sprovide
);
5302 defsubr (&Splist_member
);
5303 defsubr (&Swidget_put
);
5304 defsubr (&Swidget_get
);
5305 defsubr (&Swidget_apply
);
5306 defsubr (&Sbase64_encode_region
);
5307 defsubr (&Sbase64_decode_region
);
5308 defsubr (&Sbase64_encode_string
);
5309 defsubr (&Sbase64_decode_string
);
5311 defsubr (&Slocale_info
);
5320 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5321 (do not change this comment) */