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, 2011
5 Free Software Foundation, Inc.
7 This file is part of GNU Emacs.
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
32 #include "character.h"
37 #include "intervals.h"
40 #include "blockinput.h"
42 #if defined (HAVE_X_WINDOWS)
45 #endif /* HAVE_MENUS */
48 #define NULL ((POINTER_TYPE *)0)
51 /* Nonzero enables use of dialog boxes for questions
52 asked by mouse commands. */
55 /* Nonzero enables use of a file dialog for file name
56 questions asked by mouse commands. */
59 extern int minibuffer_auto_raise
;
60 extern Lisp_Object minibuf_window
;
61 extern Lisp_Object Vlocale_coding_system
;
62 extern int load_in_progress
;
64 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
65 Lisp_Object Qyes_or_no_p_history
;
66 Lisp_Object Qcursor_in_echo_area
;
67 Lisp_Object Qwidget_type
;
68 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
70 extern Lisp_Object Qinput_method_function
;
72 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
74 extern long get_random ();
75 extern void seed_random
P_ ((long));
81 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
82 doc
: /* Return the argument unchanged. */)
89 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
90 doc
: /* Return a pseudo-random number.
91 All integers representable in Lisp are equally likely.
92 On most systems, this is 29 bits' worth.
93 With positive integer LIMIT, return random number in interval [0,LIMIT).
94 With argument t, set the random number seed from the current time and pid.
95 Other values of LIMIT are ignored. */)
100 Lisp_Object lispy_val
;
101 unsigned long denominator
;
104 seed_random (getpid () + time (NULL
));
105 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
107 /* Try to take our random number from the higher bits of VAL,
108 not the lower, since (says Gentzel) the low bits of `random'
109 are less random than the higher ones. We do this by using the
110 quotient rather than the remainder. At the high end of the RNG
111 it's possible to get a quotient larger than n; discarding
112 these values eliminates the bias that would otherwise appear
113 when using a large n. */
114 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
116 val
= get_random () / denominator
;
117 while (val
>= XFASTINT (limit
));
121 XSETINT (lispy_val
, val
);
125 /* Random data-structure functions */
127 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
128 doc
: /* Return the length of vector, list or string SEQUENCE.
129 A byte-code function object is also allowed.
130 If the string contains multibyte characters, this is not necessarily
131 the number of bytes in the string; it is the number of characters.
132 To get the number of bytes, use `string-bytes'. */)
134 register Lisp_Object sequence
;
136 register Lisp_Object val
;
139 if (STRINGP (sequence
))
140 XSETFASTINT (val
, SCHARS (sequence
));
141 else if (VECTORP (sequence
))
142 XSETFASTINT (val
, ASIZE (sequence
));
143 else if (CHAR_TABLE_P (sequence
))
144 XSETFASTINT (val
, MAX_CHAR
);
145 else if (BOOL_VECTOR_P (sequence
))
146 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
147 else if (COMPILEDP (sequence
))
148 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
149 else if (CONSP (sequence
))
152 while (CONSP (sequence
))
154 sequence
= XCDR (sequence
);
157 if (!CONSP (sequence
))
160 sequence
= XCDR (sequence
);
165 CHECK_LIST_END (sequence
, sequence
);
167 val
= make_number (i
);
169 else if (NILP (sequence
))
170 XSETFASTINT (val
, 0);
172 wrong_type_argument (Qsequencep
, sequence
);
177 /* This does not check for quits. That is safe since it must terminate. */
179 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
180 doc
: /* Return the length of a list, but avoid error or infinite loop.
181 This function never gets an error. If LIST is not really a list,
182 it returns 0. If LIST is circular, it returns a finite value
183 which is at least the number of distinct elements. */)
187 Lisp_Object tail
, halftail
, length
;
190 /* halftail is used to detect circular lists. */
192 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
194 if (EQ (tail
, halftail
) && len
!= 0)
198 halftail
= XCDR (halftail
);
201 XSETINT (length
, len
);
205 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
206 doc
: /* Return the number of bytes in STRING.
207 If STRING is multibyte, this may be greater than the length of STRING. */)
211 CHECK_STRING (string
);
212 return make_number (SBYTES (string
));
215 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
216 doc
: /* Return t if two strings have identical contents.
217 Case is significant, but text properties are ignored.
218 Symbols are also allowed; their print names are used instead. */)
220 register Lisp_Object s1
, s2
;
223 s1
= SYMBOL_NAME (s1
);
225 s2
= SYMBOL_NAME (s2
);
229 if (SCHARS (s1
) != SCHARS (s2
)
230 || SBYTES (s1
) != SBYTES (s2
)
231 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
236 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
237 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
238 In string STR1, skip the first START1 characters and stop at END1.
239 In string STR2, skip the first START2 characters and stop at END2.
240 END1 and END2 default to the full lengths of the respective strings.
242 Case is significant in this comparison if IGNORE-CASE is nil.
243 Unibyte strings are converted to multibyte for comparison.
245 The value is t if the strings (or specified portions) match.
246 If string STR1 is less, the value is a negative number N;
247 - 1 - N is the number of characters that match at the beginning.
248 If string STR1 is greater, the value is a positive number N;
249 N - 1 is the number of characters that match at the beginning. */)
250 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
251 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
253 register int end1_char
, end2_char
;
254 register int i1
, i1_byte
, i2
, i2_byte
;
259 start1
= make_number (0);
261 start2
= make_number (0);
262 CHECK_NATNUM (start1
);
263 CHECK_NATNUM (start2
);
272 i1_byte
= string_char_to_byte (str1
, i1
);
273 i2_byte
= string_char_to_byte (str2
, i2
);
275 end1_char
= SCHARS (str1
);
276 if (! NILP (end1
) && end1_char
> XINT (end1
))
277 end1_char
= XINT (end1
);
279 end2_char
= SCHARS (str2
);
280 if (! NILP (end2
) && end2_char
> XINT (end2
))
281 end2_char
= XINT (end2
);
283 while (i1
< end1_char
&& i2
< end2_char
)
285 /* When we find a mismatch, we must compare the
286 characters, not just the bytes. */
289 if (STRING_MULTIBYTE (str1
))
290 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
293 c1
= SREF (str1
, i1
++);
294 MAKE_CHAR_MULTIBYTE (c1
);
297 if (STRING_MULTIBYTE (str2
))
298 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
301 c2
= SREF (str2
, i2
++);
302 MAKE_CHAR_MULTIBYTE (c2
);
308 if (! NILP (ignore_case
))
312 tem
= Fupcase (make_number (c1
));
314 tem
= Fupcase (make_number (c2
));
321 /* Note that I1 has already been incremented
322 past the character that we are comparing;
323 hence we don't add or subtract 1 here. */
325 return make_number (- i1
+ XINT (start1
));
327 return make_number (i1
- XINT (start1
));
331 return make_number (i1
- XINT (start1
) + 1);
333 return make_number (- i1
+ XINT (start1
) - 1);
338 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
339 doc
: /* Return t if first arg string is less than second in lexicographic order.
341 Symbols are also allowed; their print names are used instead. */)
343 register Lisp_Object s1
, s2
;
346 register int i1
, i1_byte
, i2
, i2_byte
;
349 s1
= SYMBOL_NAME (s1
);
351 s2
= SYMBOL_NAME (s2
);
355 i1
= i1_byte
= i2
= i2_byte
= 0;
358 if (end
> SCHARS (s2
))
363 /* When we find a mismatch, we must compare the
364 characters, not just the bytes. */
367 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
368 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
371 return c1
< c2
? Qt
: Qnil
;
373 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
377 /* "gcc -O3" enables automatic function inlining, which optimizes out
378 the arguments for the invocations of this function, whereas it
379 expects these values on the stack. */
380 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
381 #else /* !__GNUC__ */
382 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
394 return concat (2, args
, Lisp_String
, 0);
396 return concat (2, &s1
, Lisp_String
, 0);
397 #endif /* NO_ARG_ARRAY */
403 Lisp_Object s1
, s2
, s3
;
410 return concat (3, args
, Lisp_String
, 0);
412 return concat (3, &s1
, Lisp_String
, 0);
413 #endif /* NO_ARG_ARRAY */
416 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
417 doc
: /* Concatenate all the arguments and make the result a list.
418 The result is a list whose elements are the elements of all the arguments.
419 Each argument may be a list, vector or string.
420 The last argument is not copied, just used as the tail of the new list.
421 usage: (append &rest SEQUENCES) */)
426 return concat (nargs
, args
, Lisp_Cons
, 1);
429 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
430 doc
: /* Concatenate all the arguments and make the result a string.
431 The result is a string whose elements are the elements of all the arguments.
432 Each argument may be a string or a list or vector of characters (integers).
433 usage: (concat &rest SEQUENCES) */)
438 return concat (nargs
, args
, Lisp_String
, 0);
441 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
442 doc
: /* Concatenate all the arguments and make the result a vector.
443 The result is a vector whose elements are the elements of all the arguments.
444 Each argument may be a list, vector or string.
445 usage: (vconcat &rest SEQUENCES) */)
450 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
454 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
455 doc
: /* Return a copy of a list, vector, string or char-table.
456 The elements of a list or vector are not copied; they are shared
457 with the original. */)
461 if (NILP (arg
)) return arg
;
463 if (CHAR_TABLE_P (arg
))
465 return copy_char_table (arg
);
468 if (BOOL_VECTOR_P (arg
))
472 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
473 / BOOL_VECTOR_BITS_PER_CHAR
);
475 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
476 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
481 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
482 wrong_type_argument (Qsequencep
, arg
);
484 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
487 /* This structure holds information of an argument of `concat' that is
488 a string and has text properties to be copied. */
491 int argnum
; /* refer to ARGS (arguments of `concat') */
492 int from
; /* refer to ARGS[argnum] (argument string) */
493 int to
; /* refer to VAL (the target string) */
497 concat (nargs
, args
, target_type
, last_special
)
500 enum Lisp_Type target_type
;
504 register Lisp_Object tail
;
505 register Lisp_Object
this;
507 int toindex_byte
= 0;
508 register int result_len
;
509 register int result_len_byte
;
511 Lisp_Object last_tail
;
514 /* When we make a multibyte string, we can't copy text properties
515 while concatinating each string because the length of resulting
516 string can't be decided until we finish the whole concatination.
517 So, we record strings that have text properties to be copied
518 here, and copy the text properties after the concatination. */
519 struct textprop_rec
*textprops
= NULL
;
520 /* Number of elements in textprops. */
521 int num_textprops
= 0;
526 /* In append, the last arg isn't treated like the others */
527 if (last_special
&& nargs
> 0)
530 last_tail
= args
[nargs
];
535 /* Check each argument. */
536 for (argnum
= 0; argnum
< nargs
; argnum
++)
539 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
540 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
541 wrong_type_argument (Qsequencep
, this);
544 /* Compute total length in chars of arguments in RESULT_LEN.
545 If desired output is a string, also compute length in bytes
546 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
547 whether the result should be a multibyte string. */
551 for (argnum
= 0; argnum
< nargs
; argnum
++)
555 len
= XFASTINT (Flength (this));
556 if (target_type
== Lisp_String
)
558 /* We must count the number of bytes needed in the string
559 as well as the number of characters. */
565 for (i
= 0; i
< len
; i
++)
568 CHECK_CHARACTER (ch
);
569 this_len_byte
= CHAR_BYTES (XINT (ch
));
570 result_len_byte
+= this_len_byte
;
571 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
574 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
575 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
576 else if (CONSP (this))
577 for (; CONSP (this); this = XCDR (this))
580 CHECK_CHARACTER (ch
);
581 this_len_byte
= CHAR_BYTES (XINT (ch
));
582 result_len_byte
+= this_len_byte
;
583 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
586 else if (STRINGP (this))
588 if (STRING_MULTIBYTE (this))
591 result_len_byte
+= SBYTES (this);
594 result_len_byte
+= count_size_as_multibyte (SDATA (this),
601 error ("String overflow");
604 if (! some_multibyte
)
605 result_len_byte
= result_len
;
607 /* Create the output object. */
608 if (target_type
== Lisp_Cons
)
609 val
= Fmake_list (make_number (result_len
), Qnil
);
610 else if (target_type
== Lisp_Vectorlike
)
611 val
= Fmake_vector (make_number (result_len
), Qnil
);
612 else if (some_multibyte
)
613 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
615 val
= make_uninit_string (result_len
);
617 /* In `append', if all but last arg are nil, return last arg. */
618 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
621 /* Copy the contents of the args into the result. */
623 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
625 toindex
= 0, toindex_byte
= 0;
629 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
631 for (argnum
= 0; argnum
< nargs
; argnum
++)
635 register unsigned int thisindex
= 0;
636 register unsigned int thisindex_byte
= 0;
640 thislen
= Flength (this), thisleni
= XINT (thislen
);
642 /* Between strings of the same kind, copy fast. */
643 if (STRINGP (this) && STRINGP (val
)
644 && STRING_MULTIBYTE (this) == some_multibyte
)
646 int thislen_byte
= SBYTES (this);
648 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
650 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
652 textprops
[num_textprops
].argnum
= argnum
;
653 textprops
[num_textprops
].from
= 0;
654 textprops
[num_textprops
++].to
= toindex
;
656 toindex_byte
+= thislen_byte
;
659 /* Copy a single-byte string to a multibyte string. */
660 else if (STRINGP (this) && STRINGP (val
))
662 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
664 textprops
[num_textprops
].argnum
= argnum
;
665 textprops
[num_textprops
].from
= 0;
666 textprops
[num_textprops
++].to
= toindex
;
668 toindex_byte
+= copy_text (SDATA (this),
669 SDATA (val
) + toindex_byte
,
670 SCHARS (this), 0, 1);
674 /* Copy element by element. */
677 register Lisp_Object elt
;
679 /* Fetch next element of `this' arg into `elt', or break if
680 `this' is exhausted. */
681 if (NILP (this)) break;
683 elt
= XCAR (this), this = XCDR (this);
684 else if (thisindex
>= thisleni
)
686 else if (STRINGP (this))
689 if (STRING_MULTIBYTE (this))
691 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
694 XSETFASTINT (elt
, c
);
698 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
700 && !ASCII_CHAR_P (XINT (elt
))
701 && XINT (elt
) < 0400)
703 c
= BYTE8_TO_CHAR (XINT (elt
));
708 else if (BOOL_VECTOR_P (this))
711 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
712 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
720 elt
= AREF (this, thisindex
);
724 /* Store this element into the result. */
731 else if (VECTORP (val
))
733 ASET (val
, toindex
, elt
);
740 toindex_byte
+= CHAR_STRING (XINT (elt
),
741 SDATA (val
) + toindex_byte
);
743 SSET (val
, toindex_byte
++, XINT (elt
));
749 XSETCDR (prev
, last_tail
);
751 if (num_textprops
> 0)
754 int last_to_end
= -1;
756 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
758 this = args
[textprops
[argnum
].argnum
];
759 props
= text_property_list (this,
761 make_number (SCHARS (this)),
763 /* If successive arguments have properites, be sure that the
764 value of `composition' property be the copy. */
765 if (last_to_end
== textprops
[argnum
].to
)
766 make_composition_value_copy (props
);
767 add_text_properties_from_list (val
, props
,
768 make_number (textprops
[argnum
].to
));
769 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
777 static Lisp_Object string_char_byte_cache_string
;
778 static EMACS_INT string_char_byte_cache_charpos
;
779 static EMACS_INT string_char_byte_cache_bytepos
;
782 clear_string_char_byte_cache ()
784 string_char_byte_cache_string
= Qnil
;
787 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
790 string_char_to_byte (string
, char_index
)
792 EMACS_INT char_index
;
795 EMACS_INT best_below
, best_below_byte
;
796 EMACS_INT best_above
, best_above_byte
;
798 best_below
= best_below_byte
= 0;
799 best_above
= SCHARS (string
);
800 best_above_byte
= SBYTES (string
);
801 if (best_above
== best_above_byte
)
804 if (EQ (string
, string_char_byte_cache_string
))
806 if (string_char_byte_cache_charpos
< char_index
)
808 best_below
= string_char_byte_cache_charpos
;
809 best_below_byte
= string_char_byte_cache_bytepos
;
813 best_above
= string_char_byte_cache_charpos
;
814 best_above_byte
= string_char_byte_cache_bytepos
;
818 if (char_index
- best_below
< best_above
- char_index
)
820 unsigned char *p
= SDATA (string
) + best_below_byte
;
822 while (best_below
< char_index
)
824 p
+= BYTES_BY_CHAR_HEAD (*p
);
827 i_byte
= p
- SDATA (string
);
831 unsigned char *p
= SDATA (string
) + best_above_byte
;
833 while (best_above
> char_index
)
836 while (!CHAR_HEAD_P (*p
)) p
--;
839 i_byte
= p
- SDATA (string
);
842 string_char_byte_cache_bytepos
= i_byte
;
843 string_char_byte_cache_charpos
= char_index
;
844 string_char_byte_cache_string
= string
;
849 /* Return the character index corresponding to BYTE_INDEX in STRING. */
852 string_byte_to_char (string
, byte_index
)
854 EMACS_INT byte_index
;
857 EMACS_INT best_below
, best_below_byte
;
858 EMACS_INT best_above
, best_above_byte
;
860 best_below
= best_below_byte
= 0;
861 best_above
= SCHARS (string
);
862 best_above_byte
= SBYTES (string
);
863 if (best_above
== best_above_byte
)
866 if (EQ (string
, string_char_byte_cache_string
))
868 if (string_char_byte_cache_bytepos
< byte_index
)
870 best_below
= string_char_byte_cache_charpos
;
871 best_below_byte
= string_char_byte_cache_bytepos
;
875 best_above
= string_char_byte_cache_charpos
;
876 best_above_byte
= string_char_byte_cache_bytepos
;
880 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
882 unsigned char *p
= SDATA (string
) + best_below_byte
;
883 unsigned char *pend
= SDATA (string
) + byte_index
;
887 p
+= BYTES_BY_CHAR_HEAD (*p
);
891 i_byte
= p
- SDATA (string
);
895 unsigned char *p
= SDATA (string
) + best_above_byte
;
896 unsigned char *pbeg
= SDATA (string
) + byte_index
;
901 while (!CHAR_HEAD_P (*p
)) p
--;
905 i_byte
= p
- SDATA (string
);
908 string_char_byte_cache_bytepos
= i_byte
;
909 string_char_byte_cache_charpos
= i
;
910 string_char_byte_cache_string
= string
;
915 /* Convert STRING to a multibyte string. */
918 string_make_multibyte (string
)
926 if (STRING_MULTIBYTE (string
))
929 nbytes
= count_size_as_multibyte (SDATA (string
),
931 /* If all the chars are ASCII, they won't need any more bytes
932 once converted. In that case, we can return STRING itself. */
933 if (nbytes
== SBYTES (string
))
936 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
937 copy_text (SDATA (string
), buf
, SBYTES (string
),
940 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
947 /* Convert STRING (if unibyte) to a multibyte string without changing
948 the number of characters. Characters 0200 trough 0237 are
949 converted to eight-bit characters. */
952 string_to_multibyte (string
)
960 if (STRING_MULTIBYTE (string
))
963 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
964 /* If all the chars are ASCII, they won't need any more bytes once
966 if (nbytes
== SBYTES (string
))
967 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
969 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
970 bcopy (SDATA (string
), buf
, SBYTES (string
));
971 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
973 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
980 /* Convert STRING to a single-byte string. */
983 string_make_unibyte (string
)
991 if (! STRING_MULTIBYTE (string
))
994 nchars
= SCHARS (string
);
996 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
997 copy_text (SDATA (string
), buf
, SBYTES (string
),
1000 ret
= make_unibyte_string (buf
, nchars
);
1006 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1008 doc
: /* Return the multibyte equivalent of STRING.
1009 If STRING is unibyte and contains non-ASCII characters, the function
1010 `unibyte-char-to-multibyte' is used to convert each unibyte character
1011 to a multibyte character. In this case, the returned string is a
1012 newly created string with no text properties. If STRING is multibyte
1013 or entirely ASCII, it is returned unchanged. In particular, when
1014 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1015 \(When the characters are all ASCII, Emacs primitives will treat the
1016 string the same way whether it is unibyte or multibyte.) */)
1020 CHECK_STRING (string
);
1022 return string_make_multibyte (string
);
1025 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1027 doc
: /* Return the unibyte equivalent of STRING.
1028 Multibyte character codes are converted to unibyte according to
1029 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1030 If the lookup in the translation table fails, this function takes just
1031 the low 8 bits of each character. */)
1035 CHECK_STRING (string
);
1037 return string_make_unibyte (string
);
1040 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1042 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1043 If STRING is unibyte, the result is STRING itself.
1044 Otherwise it is a newly created string, with no text properties.
1045 If STRING is multibyte and contains a character of charset
1046 `eight-bit', it is converted to the corresponding single byte. */)
1050 CHECK_STRING (string
);
1052 if (STRING_MULTIBYTE (string
))
1054 int bytes
= SBYTES (string
);
1055 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1057 bcopy (SDATA (string
), str
, bytes
);
1058 bytes
= str_as_unibyte (str
, bytes
);
1059 string
= make_unibyte_string (str
, bytes
);
1065 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1067 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1068 If STRING is multibyte, the result is STRING itself.
1069 Otherwise it is a newly created string, with no text properties.
1071 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1072 part of a correct utf-8 sequence), it is converted to the corresponding
1073 multibyte character of charset `eight-bit'.
1074 See also `string-to-multibyte'.
1076 Beware, this often doesn't really do what you think it does.
1077 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1078 If you're not sure, whether to use `string-as-multibyte' or
1079 `string-to-multibyte', use `string-to-multibyte'. */)
1083 CHECK_STRING (string
);
1085 if (! STRING_MULTIBYTE (string
))
1087 Lisp_Object new_string
;
1090 parse_str_as_multibyte (SDATA (string
),
1093 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1094 bcopy (SDATA (string
), SDATA (new_string
),
1096 if (nbytes
!= SBYTES (string
))
1097 str_as_multibyte (SDATA (new_string
), nbytes
,
1098 SBYTES (string
), NULL
);
1099 string
= new_string
;
1100 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1105 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1107 doc
: /* Return a multibyte string with the same individual chars as STRING.
1108 If STRING is multibyte, the result is STRING itself.
1109 Otherwise it is a newly created string, with no text properties.
1111 If STRING is unibyte and contains an 8-bit byte, it is converted to
1112 the corresponding multibyte character of charset `eight-bit'.
1114 This differs from `string-as-multibyte' by converting each byte of a correct
1115 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1116 correct sequence. */)
1120 CHECK_STRING (string
);
1122 return string_to_multibyte (string
);
1125 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1127 doc
: /* Return a unibyte string with the same individual chars as STRING.
1128 If STRING is unibyte, the result is STRING itself.
1129 Otherwise it is a newly created string, with no text properties,
1130 where each `eight-bit' character is converted to the corresponding byte.
1131 If STRING contains a non-ASCII, non-`eight-bit' character,
1132 an error is signaled. */)
1136 CHECK_STRING (string
);
1138 if (STRING_MULTIBYTE (string
))
1140 EMACS_INT chars
= SCHARS (string
);
1141 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1142 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1144 if (converted
< chars
)
1145 error ("Can't convert the %dth character to unibyte", converted
);
1146 string
= make_unibyte_string (str
, chars
);
1153 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1154 doc
: /* Return a copy of ALIST.
1155 This is an alist which represents the same mapping from objects to objects,
1156 but does not share the alist structure with ALIST.
1157 The objects mapped (cars and cdrs of elements of the alist)
1158 are shared, however.
1159 Elements of ALIST that are not conses are also shared. */)
1163 register Lisp_Object tem
;
1168 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1169 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1171 register Lisp_Object car
;
1175 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1180 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1181 doc
: /* Return a new string whose contents are a substring of STRING.
1182 The returned string consists of the characters between index FROM
1183 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1184 zero-indexed: 0 means the first character of STRING. Negative values
1185 are counted from the end of STRING. If TO is nil, the substring runs
1186 to the end of STRING.
1188 The STRING argument may also be a vector. In that case, the return
1189 value is a new vector that contains the elements between index FROM
1190 \(inclusive) and index TO (exclusive) of that vector argument. */)
1193 register Lisp_Object from
, to
;
1198 int from_char
, to_char
;
1199 int from_byte
= 0, to_byte
= 0;
1201 CHECK_VECTOR_OR_STRING (string
);
1202 CHECK_NUMBER (from
);
1204 if (STRINGP (string
))
1206 size
= SCHARS (string
);
1207 size_byte
= SBYTES (string
);
1210 size
= ASIZE (string
);
1215 to_byte
= size_byte
;
1221 to_char
= XINT (to
);
1225 if (STRINGP (string
))
1226 to_byte
= string_char_to_byte (string
, to_char
);
1229 from_char
= XINT (from
);
1232 if (STRINGP (string
))
1233 from_byte
= string_char_to_byte (string
, from_char
);
1235 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1236 args_out_of_range_3 (string
, make_number (from_char
),
1237 make_number (to_char
));
1239 if (STRINGP (string
))
1241 res
= make_specified_string (SDATA (string
) + from_byte
,
1242 to_char
- from_char
, to_byte
- from_byte
,
1243 STRING_MULTIBYTE (string
));
1244 copy_text_properties (make_number (from_char
), make_number (to_char
),
1245 string
, make_number (0), res
, Qnil
);
1248 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1254 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1255 doc
: /* Return a substring of STRING, without text properties.
1256 It starts at index FROM and ends before TO.
1257 TO may be nil or omitted; then the substring runs to the end of STRING.
1258 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1259 If FROM or TO is negative, it counts from the end.
1261 With one argument, just copy STRING without its properties. */)
1264 register Lisp_Object from
, to
;
1266 int size
, size_byte
;
1267 int from_char
, to_char
;
1268 int from_byte
, to_byte
;
1270 CHECK_STRING (string
);
1272 size
= SCHARS (string
);
1273 size_byte
= SBYTES (string
);
1276 from_char
= from_byte
= 0;
1279 CHECK_NUMBER (from
);
1280 from_char
= XINT (from
);
1284 from_byte
= string_char_to_byte (string
, from_char
);
1290 to_byte
= size_byte
;
1296 to_char
= XINT (to
);
1300 to_byte
= string_char_to_byte (string
, to_char
);
1303 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1304 args_out_of_range_3 (string
, make_number (from_char
),
1305 make_number (to_char
));
1307 return make_specified_string (SDATA (string
) + from_byte
,
1308 to_char
- from_char
, to_byte
- from_byte
,
1309 STRING_MULTIBYTE (string
));
1312 /* Extract a substring of STRING, giving start and end positions
1313 both in characters and in bytes. */
1316 substring_both (string
, from
, from_byte
, to
, to_byte
)
1318 int from
, from_byte
, to
, to_byte
;
1324 CHECK_VECTOR_OR_STRING (string
);
1326 if (STRINGP (string
))
1328 size
= SCHARS (string
);
1329 size_byte
= SBYTES (string
);
1332 size
= ASIZE (string
);
1334 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1335 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1337 if (STRINGP (string
))
1339 res
= make_specified_string (SDATA (string
) + from_byte
,
1340 to
- from
, to_byte
- from_byte
,
1341 STRING_MULTIBYTE (string
));
1342 copy_text_properties (make_number (from
), make_number (to
),
1343 string
, make_number (0), res
, Qnil
);
1346 res
= Fvector (to
- from
, &AREF (string
, from
));
1351 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1352 doc
: /* Take cdr N times on LIST, return the result. */)
1355 register Lisp_Object list
;
1357 register int i
, num
;
1360 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1363 CHECK_LIST_CONS (list
, list
);
1369 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1370 doc
: /* Return the Nth element of LIST.
1371 N counts from zero. If LIST is not that long, nil is returned. */)
1373 Lisp_Object n
, list
;
1375 return Fcar (Fnthcdr (n
, list
));
1378 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1379 doc
: /* Return element of SEQUENCE at index N. */)
1381 register Lisp_Object sequence
, n
;
1384 if (CONSP (sequence
) || NILP (sequence
))
1385 return Fcar (Fnthcdr (n
, sequence
));
1387 /* Faref signals a "not array" error, so check here. */
1388 CHECK_ARRAY (sequence
, Qsequencep
);
1389 return Faref (sequence
, n
);
1392 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1393 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1394 The value is actually the tail of LIST whose car is ELT. */)
1396 register Lisp_Object elt
;
1399 register Lisp_Object tail
;
1400 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1402 register Lisp_Object tem
;
1403 CHECK_LIST_CONS (tail
, list
);
1405 if (! NILP (Fequal (elt
, tem
)))
1412 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1413 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1414 The value is actually the tail of LIST whose car is ELT. */)
1416 register Lisp_Object elt
, list
;
1420 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1424 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1428 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1439 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1440 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1441 The value is actually the tail of LIST whose car is ELT. */)
1443 register Lisp_Object elt
;
1446 register Lisp_Object tail
;
1449 return Fmemq (elt
, list
);
1451 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1453 register Lisp_Object tem
;
1454 CHECK_LIST_CONS (tail
, list
);
1456 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1463 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1464 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1465 The value is actually the first element of LIST whose car is KEY.
1466 Elements of LIST that are not conses are ignored. */)
1468 Lisp_Object key
, list
;
1473 || (CONSP (XCAR (list
))
1474 && EQ (XCAR (XCAR (list
)), key
)))
1479 || (CONSP (XCAR (list
))
1480 && EQ (XCAR (XCAR (list
)), key
)))
1485 || (CONSP (XCAR (list
))
1486 && EQ (XCAR (XCAR (list
)), key
)))
1496 /* Like Fassq but never report an error and do not allow quits.
1497 Use only on lists known never to be circular. */
1500 assq_no_quit (key
, list
)
1501 Lisp_Object key
, list
;
1504 && (!CONSP (XCAR (list
))
1505 || !EQ (XCAR (XCAR (list
)), key
)))
1508 return CAR_SAFE (list
);
1511 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1512 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1513 The value is actually the first element of LIST whose car equals KEY. */)
1515 Lisp_Object key
, list
;
1522 || (CONSP (XCAR (list
))
1523 && (car
= XCAR (XCAR (list
)),
1524 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
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
)))))
1548 /* Like Fassoc but never report an error and do not allow quits.
1549 Use only on lists known never to be circular. */
1552 assoc_no_quit (key
, list
)
1553 Lisp_Object key
, list
;
1556 && (!CONSP (XCAR (list
))
1557 || (!EQ (XCAR (XCAR (list
)), key
)
1558 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1561 return CONSP (list
) ? XCAR (list
) : Qnil
;
1564 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1565 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1566 The value is actually the first element of LIST whose cdr is KEY. */)
1568 register Lisp_Object key
;
1574 || (CONSP (XCAR (list
))
1575 && EQ (XCDR (XCAR (list
)), key
)))
1580 || (CONSP (XCAR (list
))
1581 && EQ (XCDR (XCAR (list
)), key
)))
1586 || (CONSP (XCAR (list
))
1587 && EQ (XCDR (XCAR (list
)), key
)))
1597 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1598 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1599 The value is actually the first element of LIST whose cdr equals KEY. */)
1601 Lisp_Object key
, list
;
1608 || (CONSP (XCAR (list
))
1609 && (cdr
= XCDR (XCAR (list
)),
1610 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
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
)))))
1634 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1635 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1636 The modified LIST is returned. Comparison is done with `eq'.
1637 If the first member of LIST is ELT, there is no way to remove it by side effect;
1638 therefore, write `(setq foo (delq element foo))'
1639 to be sure of changing the value of `foo'. */)
1641 register Lisp_Object elt
;
1644 register Lisp_Object tail
, prev
;
1645 register Lisp_Object tem
;
1649 while (!NILP (tail
))
1651 CHECK_LIST_CONS (tail
, list
);
1658 Fsetcdr (prev
, XCDR (tail
));
1668 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1669 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1670 SEQ must be a list, a vector, or a string.
1671 The modified SEQ is returned. Comparison is done with `equal'.
1672 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1673 is not a side effect; it is simply using a different sequence.
1674 Therefore, write `(setq foo (delete element foo))'
1675 to be sure of changing the value of `foo'. */)
1677 Lisp_Object elt
, seq
;
1683 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1684 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1687 if (n
!= ASIZE (seq
))
1689 struct Lisp_Vector
*p
= allocate_vector (n
);
1691 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1692 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1693 p
->contents
[n
++] = AREF (seq
, i
);
1695 XSETVECTOR (seq
, p
);
1698 else if (STRINGP (seq
))
1700 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1703 for (i
= nchars
= nbytes
= ibyte
= 0;
1705 ++i
, ibyte
+= cbytes
)
1707 if (STRING_MULTIBYTE (seq
))
1709 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1710 cbytes
= CHAR_BYTES (c
);
1718 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1725 if (nchars
!= SCHARS (seq
))
1729 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1730 if (!STRING_MULTIBYTE (seq
))
1731 STRING_SET_UNIBYTE (tem
);
1733 for (i
= nchars
= nbytes
= ibyte
= 0;
1735 ++i
, ibyte
+= cbytes
)
1737 if (STRING_MULTIBYTE (seq
))
1739 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1740 cbytes
= CHAR_BYTES (c
);
1748 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1750 unsigned char *from
= SDATA (seq
) + ibyte
;
1751 unsigned char *to
= SDATA (tem
) + nbytes
;
1757 for (n
= cbytes
; n
--; )
1767 Lisp_Object tail
, prev
;
1769 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1771 CHECK_LIST_CONS (tail
, seq
);
1773 if (!NILP (Fequal (elt
, XCAR (tail
))))
1778 Fsetcdr (prev
, XCDR (tail
));
1789 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1790 doc
: /* Reverse LIST by modifying cdr pointers.
1791 Return the reversed list. */)
1795 register Lisp_Object prev
, tail
, next
;
1797 if (NILP (list
)) return list
;
1800 while (!NILP (tail
))
1803 CHECK_LIST_CONS (tail
, list
);
1805 Fsetcdr (tail
, prev
);
1812 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1813 doc
: /* Reverse LIST, copying. Return the reversed list.
1814 See also the function `nreverse', which is used more often. */)
1820 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1823 new = Fcons (XCAR (list
), new);
1825 CHECK_LIST_END (list
, list
);
1829 Lisp_Object
merge ();
1831 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1832 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1833 Returns the sorted list. LIST is modified by side effects.
1834 PREDICATE is called with two elements of LIST, and should return non-nil
1835 if the first element should sort before the second. */)
1837 Lisp_Object list
, predicate
;
1839 Lisp_Object front
, back
;
1840 register Lisp_Object len
, tem
;
1841 struct gcpro gcpro1
, gcpro2
;
1842 register int length
;
1845 len
= Flength (list
);
1846 length
= XINT (len
);
1850 XSETINT (len
, (length
/ 2) - 1);
1851 tem
= Fnthcdr (len
, list
);
1853 Fsetcdr (tem
, Qnil
);
1855 GCPRO2 (front
, back
);
1856 front
= Fsort (front
, predicate
);
1857 back
= Fsort (back
, predicate
);
1859 return merge (front
, back
, predicate
);
1863 merge (org_l1
, org_l2
, pred
)
1864 Lisp_Object org_l1
, org_l2
;
1868 register Lisp_Object tail
;
1870 register Lisp_Object l1
, l2
;
1871 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1878 /* It is sufficient to protect org_l1 and org_l2.
1879 When l1 and l2 are updated, we copy the new values
1880 back into the org_ vars. */
1881 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1901 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1917 Fsetcdr (tail
, tem
);
1923 /* This does not check for quits. That is safe since it must terminate. */
1925 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1926 doc
: /* Extract a value from a property list.
1927 PLIST is a property list, which is a list of the form
1928 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1929 corresponding to the given PROP, or nil if PROP is not one of the
1930 properties on the list. This function never signals an error. */)
1935 Lisp_Object tail
, halftail
;
1937 /* halftail is used to detect circular lists. */
1938 tail
= halftail
= plist
;
1939 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1941 if (EQ (prop
, XCAR (tail
)))
1942 return XCAR (XCDR (tail
));
1944 tail
= XCDR (XCDR (tail
));
1945 halftail
= XCDR (halftail
);
1946 if (EQ (tail
, halftail
))
1949 #if 0 /* Unsafe version. */
1950 /* This function can be called asynchronously
1951 (setup_coding_system). Don't QUIT in that case. */
1952 if (!interrupt_input_blocked
)
1960 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1961 doc
: /* Return the value of SYMBOL's PROPNAME property.
1962 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1964 Lisp_Object symbol
, propname
;
1966 CHECK_SYMBOL (symbol
);
1967 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1970 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1971 doc
: /* Change value in PLIST of PROP to VAL.
1972 PLIST is a property list, which is a list of the form
1973 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1974 If PROP is already a property on the list, its value is set to VAL,
1975 otherwise the new PROP VAL pair is added. The new plist is returned;
1976 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1977 The PLIST is modified by side effects. */)
1980 register Lisp_Object prop
;
1983 register Lisp_Object tail
, prev
;
1984 Lisp_Object newcell
;
1986 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1987 tail
= XCDR (XCDR (tail
)))
1989 if (EQ (prop
, XCAR (tail
)))
1991 Fsetcar (XCDR (tail
), val
);
1998 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2002 Fsetcdr (XCDR (prev
), newcell
);
2006 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2007 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2008 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2009 (symbol
, propname
, value
)
2010 Lisp_Object symbol
, propname
, value
;
2012 CHECK_SYMBOL (symbol
);
2013 XSYMBOL (symbol
)->plist
2014 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2018 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2019 doc
: /* Extract a value from a property list, comparing with `equal'.
2020 PLIST is a property list, which is a list of the form
2021 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2022 corresponding to the given PROP, or nil if PROP is not
2023 one of the properties on the list. */)
2031 CONSP (tail
) && CONSP (XCDR (tail
));
2032 tail
= XCDR (XCDR (tail
)))
2034 if (! NILP (Fequal (prop
, XCAR (tail
))))
2035 return XCAR (XCDR (tail
));
2040 CHECK_LIST_END (tail
, prop
);
2045 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2046 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2047 PLIST is a property list, which is a list of the form
2048 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2049 If PROP is already a property on the list, its value is set to VAL,
2050 otherwise the new PROP VAL pair is added. The new plist is returned;
2051 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2052 The PLIST is modified by side effects. */)
2055 register Lisp_Object prop
;
2058 register Lisp_Object tail
, prev
;
2059 Lisp_Object newcell
;
2061 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2062 tail
= XCDR (XCDR (tail
)))
2064 if (! NILP (Fequal (prop
, XCAR (tail
))))
2066 Fsetcar (XCDR (tail
), val
);
2073 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2077 Fsetcdr (XCDR (prev
), newcell
);
2081 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2082 doc
: /* Return t if the two args are the same Lisp object.
2083 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2085 Lisp_Object obj1
, obj2
;
2088 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2090 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2093 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2094 doc
: /* Return t if two Lisp objects have similar structure and contents.
2095 They must have the same data type.
2096 Conses are compared by comparing the cars and the cdrs.
2097 Vectors and strings are compared element by element.
2098 Numbers are compared by value, but integers cannot equal floats.
2099 (Use `=' if you want integers and floats to be able to be equal.)
2100 Symbols must match exactly. */)
2102 register Lisp_Object o1
, o2
;
2104 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2107 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2108 doc
: /* Return t if two Lisp objects have similar structure and contents.
2109 This is like `equal' except that it compares the text properties
2110 of strings. (`equal' ignores text properties.) */)
2112 register Lisp_Object o1
, o2
;
2114 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2117 /* DEPTH is current depth of recursion. Signal an error if it
2119 PROPS, if non-nil, means compare string text properties too. */
2122 internal_equal (o1
, o2
, depth
, props
)
2123 register Lisp_Object o1
, o2
;
2127 error ("Stack overflow in equal");
2133 if (XTYPE (o1
) != XTYPE (o2
))
2142 d1
= extract_float (o1
);
2143 d2
= extract_float (o2
);
2144 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2145 though they are not =. */
2146 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2150 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2157 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2161 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2163 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2166 o1
= XOVERLAY (o1
)->plist
;
2167 o2
= XOVERLAY (o2
)->plist
;
2172 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2173 && (XMARKER (o1
)->buffer
== 0
2174 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2178 case Lisp_Vectorlike
:
2181 EMACS_INT size
= ASIZE (o1
);
2182 /* Pseudovectors have the type encoded in the size field, so this test
2183 actually checks that the objects have the same type as well as the
2185 if (ASIZE (o2
) != size
)
2187 /* Boolvectors are compared much like strings. */
2188 if (BOOL_VECTOR_P (o1
))
2191 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2192 / BOOL_VECTOR_BITS_PER_CHAR
);
2194 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2196 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2201 if (WINDOW_CONFIGURATIONP (o1
))
2202 return compare_window_configurations (o1
, o2
, 0);
2204 /* Aside from them, only true vectors, char-tables, compiled
2205 functions, and fonts (font-spec, font-entity, font-ojbect)
2206 are sensible to compare, so eliminate the others now. */
2207 if (size
& PSEUDOVECTOR_FLAG
)
2209 if (!(size
& (PVEC_COMPILED
2210 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2212 size
&= PSEUDOVECTOR_SIZE_MASK
;
2214 for (i
= 0; i
< size
; i
++)
2219 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2227 if (SCHARS (o1
) != SCHARS (o2
))
2229 if (SBYTES (o1
) != SBYTES (o2
))
2231 if (bcmp (SDATA (o1
), SDATA (o2
),
2234 if (props
&& !compare_string_intervals (o1
, o2
))
2245 extern Lisp_Object
Fmake_char_internal ();
2247 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2248 doc
: /* Store each element of ARRAY with ITEM.
2249 ARRAY is a vector, string, char-table, or bool-vector. */)
2251 Lisp_Object array
, item
;
2253 register int size
, index
, charval
;
2254 if (VECTORP (array
))
2256 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2257 size
= ASIZE (array
);
2258 for (index
= 0; index
< size
; index
++)
2261 else if (CHAR_TABLE_P (array
))
2265 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2266 XCHAR_TABLE (array
)->contents
[i
] = item
;
2267 XCHAR_TABLE (array
)->defalt
= item
;
2269 else if (STRINGP (array
))
2271 register unsigned char *p
= SDATA (array
);
2272 CHECK_NUMBER (item
);
2273 charval
= XINT (item
);
2274 size
= SCHARS (array
);
2275 if (STRING_MULTIBYTE (array
))
2277 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2278 int len
= CHAR_STRING (charval
, str
);
2279 int size_byte
= SBYTES (array
);
2280 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2283 if (size
!= size_byte
)
2286 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2287 if (len
!= this_len
)
2288 error ("Attempt to change byte length of a string");
2291 for (i
= 0; i
< size_byte
; i
++)
2292 *p
++ = str
[i
% len
];
2295 for (index
= 0; index
< size
; index
++)
2298 else if (BOOL_VECTOR_P (array
))
2300 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2302 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2303 / BOOL_VECTOR_BITS_PER_CHAR
);
2305 charval
= (! NILP (item
) ? -1 : 0);
2306 for (index
= 0; index
< size_in_chars
- 1; index
++)
2308 if (index
< size_in_chars
)
2310 /* Mask out bits beyond the vector size. */
2311 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2312 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2317 wrong_type_argument (Qarrayp
, array
);
2321 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2323 doc
: /* Clear the contents of STRING.
2324 This makes STRING unibyte and may change its length. */)
2329 CHECK_STRING (string
);
2330 len
= SBYTES (string
);
2331 bzero (SDATA (string
), len
);
2332 STRING_SET_CHARS (string
, len
);
2333 STRING_SET_UNIBYTE (string
);
2343 Lisp_Object args
[2];
2346 return Fnconc (2, args
);
2348 return Fnconc (2, &s1
);
2349 #endif /* NO_ARG_ARRAY */
2352 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2353 doc
: /* Concatenate any number of lists by altering them.
2354 Only the last argument is not altered, and need not be a list.
2355 usage: (nconc &rest LISTS) */)
2360 register int argnum
;
2361 register Lisp_Object tail
, tem
, val
;
2365 for (argnum
= 0; argnum
< nargs
; argnum
++)
2368 if (NILP (tem
)) continue;
2373 if (argnum
+ 1 == nargs
) break;
2375 CHECK_LIST_CONS (tem
, tem
);
2384 tem
= args
[argnum
+ 1];
2385 Fsetcdr (tail
, tem
);
2387 args
[argnum
+ 1] = tail
;
2393 /* This is the guts of all mapping functions.
2394 Apply FN to each element of SEQ, one by one,
2395 storing the results into elements of VALS, a C vector of Lisp_Objects.
2396 LENI is the length of VALS, which should also be the length of SEQ. */
2399 mapcar1 (leni
, vals
, fn
, seq
)
2402 Lisp_Object fn
, seq
;
2404 register Lisp_Object tail
;
2407 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2411 /* Don't let vals contain any garbage when GC happens. */
2412 for (i
= 0; i
< leni
; i
++)
2415 GCPRO3 (dummy
, fn
, seq
);
2417 gcpro1
.nvars
= leni
;
2421 /* We need not explicitly protect `tail' because it is used only on lists, and
2422 1) lists are not relocated and 2) the list is marked via `seq' so will not
2427 for (i
= 0; i
< leni
; i
++)
2429 dummy
= call1 (fn
, AREF (seq
, i
));
2434 else if (BOOL_VECTOR_P (seq
))
2436 for (i
= 0; i
< leni
; i
++)
2439 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2440 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2441 dummy
= call1 (fn
, dummy
);
2446 else if (STRINGP (seq
))
2450 for (i
= 0, i_byte
= 0; i
< leni
;)
2455 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2456 XSETFASTINT (dummy
, c
);
2457 dummy
= call1 (fn
, dummy
);
2459 vals
[i_before
] = dummy
;
2462 else /* Must be a list, since Flength did not get an error */
2465 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2467 dummy
= call1 (fn
, XCAR (tail
));
2477 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2478 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2479 In between each pair of results, stick in SEPARATOR. Thus, " " as
2480 SEPARATOR results in spaces between the values returned by FUNCTION.
2481 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2482 (function
, sequence
, separator
)
2483 Lisp_Object function
, sequence
, separator
;
2488 register Lisp_Object
*args
;
2490 struct gcpro gcpro1
;
2494 len
= Flength (sequence
);
2495 if (CHAR_TABLE_P (sequence
))
2496 wrong_type_argument (Qlistp
, sequence
);
2498 nargs
= leni
+ leni
- 1;
2499 if (nargs
< 0) return empty_unibyte_string
;
2501 SAFE_ALLOCA_LISP (args
, nargs
);
2504 mapcar1 (leni
, args
, function
, sequence
);
2507 for (i
= leni
- 1; i
> 0; i
--)
2508 args
[i
+ i
] = args
[i
];
2510 for (i
= 1; i
< nargs
; i
+= 2)
2511 args
[i
] = separator
;
2513 ret
= Fconcat (nargs
, args
);
2519 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2520 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2521 The result is a list just as long as SEQUENCE.
2522 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2523 (function
, sequence
)
2524 Lisp_Object function
, sequence
;
2526 register Lisp_Object len
;
2528 register Lisp_Object
*args
;
2532 len
= Flength (sequence
);
2533 if (CHAR_TABLE_P (sequence
))
2534 wrong_type_argument (Qlistp
, sequence
);
2535 leni
= XFASTINT (len
);
2537 SAFE_ALLOCA_LISP (args
, leni
);
2539 mapcar1 (leni
, args
, function
, sequence
);
2541 ret
= Flist (leni
, args
);
2547 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2548 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2549 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2550 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2551 (function
, sequence
)
2552 Lisp_Object function
, sequence
;
2556 leni
= XFASTINT (Flength (sequence
));
2557 if (CHAR_TABLE_P (sequence
))
2558 wrong_type_argument (Qlistp
, sequence
);
2559 mapcar1 (leni
, 0, function
, sequence
);
2564 /* Anything that calls this function must protect from GC! */
2566 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2567 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2568 Takes one argument, which is the string to display to ask the question.
2569 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2570 No confirmation of the answer is requested; a single character is enough.
2571 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2572 the bindings in `query-replace-map'; see the documentation of that variable
2573 for more information. In this case, the useful bindings are `act', `skip',
2574 `recenter', and `quit'.\)
2576 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2577 is nil and `use-dialog-box' is non-nil. */)
2581 register Lisp_Object obj
, key
, def
, map
;
2582 register int answer
;
2583 Lisp_Object xprompt
;
2584 Lisp_Object args
[2];
2585 struct gcpro gcpro1
, gcpro2
;
2586 int count
= SPECPDL_INDEX ();
2588 specbind (Qcursor_in_echo_area
, Qt
);
2590 map
= Fsymbol_value (intern ("query-replace-map"));
2592 CHECK_STRING (prompt
);
2594 GCPRO2 (prompt
, xprompt
);
2596 #ifdef HAVE_WINDOW_SYSTEM
2597 if (display_hourglass_p
)
2598 cancel_hourglass ();
2605 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2606 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2610 Lisp_Object pane
, menu
;
2611 redisplay_preserve_echo_area (3);
2612 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2613 Fcons (Fcons (build_string ("No"), Qnil
),
2615 menu
= Fcons (prompt
, pane
);
2616 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2617 answer
= !NILP (obj
);
2620 #endif /* HAVE_MENUS */
2621 cursor_in_echo_area
= 1;
2622 choose_minibuf_frame ();
2625 Lisp_Object pargs
[3];
2627 /* Colorize prompt according to `minibuffer-prompt' face. */
2628 pargs
[0] = build_string ("%s(y or n) ");
2629 pargs
[1] = intern ("face");
2630 pargs
[2] = intern ("minibuffer-prompt");
2631 args
[0] = Fpropertize (3, pargs
);
2636 if (minibuffer_auto_raise
)
2638 Lisp_Object mini_frame
;
2640 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2642 Fraise_frame (mini_frame
);
2645 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2646 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2647 cursor_in_echo_area
= 0;
2648 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2651 key
= Fmake_vector (make_number (1), obj
);
2652 def
= Flookup_key (map
, key
, Qt
);
2654 if (EQ (def
, intern ("skip")))
2659 else if (EQ (def
, intern ("act")))
2664 else if (EQ (def
, intern ("recenter")))
2670 else if (EQ (def
, intern ("quit")))
2672 /* We want to exit this command for exit-prefix,
2673 and this is the only way to do it. */
2674 else if (EQ (def
, intern ("exit-prefix")))
2679 /* If we don't clear this, then the next call to read_char will
2680 return quit_char again, and we'll enter an infinite loop. */
2685 if (EQ (xprompt
, prompt
))
2687 args
[0] = build_string ("Please answer y or n. ");
2689 xprompt
= Fconcat (2, args
);
2694 if (! noninteractive
)
2696 cursor_in_echo_area
= -1;
2697 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2701 unbind_to (count
, Qnil
);
2702 return answer
? Qt
: Qnil
;
2705 /* This is how C code calls `yes-or-no-p' and allows the user
2708 Anything that calls this function must protect from GC! */
2711 do_yes_or_no_p (prompt
)
2714 return call1 (intern ("yes-or-no-p"), prompt
);
2717 /* Anything that calls this function must protect from GC! */
2719 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2720 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2721 Takes one argument, which is the string to display to ask the question.
2722 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2723 The user must confirm the answer with RET,
2724 and can edit it until it has been confirmed.
2726 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2727 is nil, and `use-dialog-box' is non-nil. */)
2731 register Lisp_Object ans
;
2732 Lisp_Object args
[2];
2733 struct gcpro gcpro1
;
2735 CHECK_STRING (prompt
);
2738 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2739 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2743 Lisp_Object pane
, menu
, obj
;
2744 redisplay_preserve_echo_area (4);
2745 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2746 Fcons (Fcons (build_string ("No"), Qnil
),
2749 menu
= Fcons (prompt
, pane
);
2750 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2754 #endif /* HAVE_MENUS */
2757 args
[1] = build_string ("(yes or no) ");
2758 prompt
= Fconcat (2, args
);
2764 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2765 Qyes_or_no_p_history
, Qnil
,
2767 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2772 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2780 message ("Please answer yes or no.");
2781 Fsleep_for (make_number (2), Qnil
);
2785 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2786 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2788 Each of the three load averages is multiplied by 100, then converted
2791 When USE-FLOATS is non-nil, floats will be used instead of integers.
2792 These floats are not multiplied by 100.
2794 If the 5-minute or 15-minute load averages are not available, return a
2795 shortened list, containing only those averages which are available.
2797 An error is thrown if the load average can't be obtained. In some
2798 cases making it work would require Emacs being installed setuid or
2799 setgid so that it can read kernel information, and that usually isn't
2802 Lisp_Object use_floats
;
2805 int loads
= getloadavg (load_ave
, 3);
2806 Lisp_Object ret
= Qnil
;
2809 error ("load-average not implemented for this operating system");
2813 Lisp_Object load
= (NILP (use_floats
) ?
2814 make_number ((int) (100.0 * load_ave
[loads
]))
2815 : make_float (load_ave
[loads
]));
2816 ret
= Fcons (load
, ret
);
2822 Lisp_Object Vfeatures
, Qsubfeatures
;
2823 extern Lisp_Object Vafter_load_alist
;
2825 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2826 doc
: /* Return t if FEATURE is present in this Emacs.
2828 Use this to conditionalize execution of lisp code based on the
2829 presence or absence of Emacs or environment extensions.
2830 Use `provide' to declare that a feature is available. This function
2831 looks at the value of the variable `features'. The optional argument
2832 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2833 (feature
, subfeature
)
2834 Lisp_Object feature
, subfeature
;
2836 register Lisp_Object tem
;
2837 CHECK_SYMBOL (feature
);
2838 tem
= Fmemq (feature
, Vfeatures
);
2839 if (!NILP (tem
) && !NILP (subfeature
))
2840 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2841 return (NILP (tem
)) ? Qnil
: Qt
;
2844 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2845 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2846 The optional argument SUBFEATURES should be a list of symbols listing
2847 particular subfeatures supported in this version of FEATURE. */)
2848 (feature
, subfeatures
)
2849 Lisp_Object feature
, subfeatures
;
2851 register Lisp_Object tem
;
2852 CHECK_SYMBOL (feature
);
2853 CHECK_LIST (subfeatures
);
2854 if (!NILP (Vautoload_queue
))
2855 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2857 tem
= Fmemq (feature
, Vfeatures
);
2859 Vfeatures
= Fcons (feature
, Vfeatures
);
2860 if (!NILP (subfeatures
))
2861 Fput (feature
, Qsubfeatures
, subfeatures
);
2862 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2864 /* Run any load-hooks for this file. */
2865 tem
= Fassq (feature
, Vafter_load_alist
);
2867 Fprogn (XCDR (tem
));
2872 /* `require' and its subroutines. */
2874 /* List of features currently being require'd, innermost first. */
2876 Lisp_Object require_nesting_list
;
2879 require_unwind (old_value
)
2880 Lisp_Object old_value
;
2882 return require_nesting_list
= old_value
;
2885 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2886 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2887 If FEATURE is not a member of the list `features', then the feature
2888 is not loaded; so load the file FILENAME.
2889 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2890 and `load' will try to load this name appended with the suffix `.elc' or
2891 `.el', in that order. The name without appended suffix will not be used.
2892 If the optional third argument NOERROR is non-nil,
2893 then return nil if the file is not found instead of signaling an error.
2894 Normally the return value is FEATURE.
2895 The normal messages at start and end of loading FILENAME are suppressed. */)
2896 (feature
, filename
, noerror
)
2897 Lisp_Object feature
, filename
, noerror
;
2899 register Lisp_Object tem
;
2900 struct gcpro gcpro1
, gcpro2
;
2901 int from_file
= load_in_progress
;
2903 CHECK_SYMBOL (feature
);
2905 /* Record the presence of `require' in this file
2906 even if the feature specified is already loaded.
2907 But not more than once in any file,
2908 and not when we aren't loading or reading from a file. */
2910 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2911 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2916 tem
= Fcons (Qrequire
, feature
);
2917 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2918 LOADHIST_ATTACH (tem
);
2920 tem
= Fmemq (feature
, Vfeatures
);
2924 int count
= SPECPDL_INDEX ();
2927 /* This is to make sure that loadup.el gives a clear picture
2928 of what files are preloaded and when. */
2929 if (! NILP (Vpurify_flag
))
2930 error ("(require %s) while preparing to dump",
2931 SDATA (SYMBOL_NAME (feature
)));
2933 /* A certain amount of recursive `require' is legitimate,
2934 but if we require the same feature recursively 3 times,
2936 tem
= require_nesting_list
;
2937 while (! NILP (tem
))
2939 if (! NILP (Fequal (feature
, XCAR (tem
))))
2944 error ("Recursive `require' for feature `%s'",
2945 SDATA (SYMBOL_NAME (feature
)));
2947 /* Update the list for any nested `require's that occur. */
2948 record_unwind_protect (require_unwind
, require_nesting_list
);
2949 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2951 /* Value saved here is to be restored into Vautoload_queue */
2952 record_unwind_protect (un_autoload
, Vautoload_queue
);
2953 Vautoload_queue
= Qt
;
2955 /* Load the file. */
2956 GCPRO2 (feature
, filename
);
2957 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2958 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2961 /* If load failed entirely, return nil. */
2963 return unbind_to (count
, Qnil
);
2965 tem
= Fmemq (feature
, Vfeatures
);
2967 error ("Required feature `%s' was not provided",
2968 SDATA (SYMBOL_NAME (feature
)));
2970 /* Once loading finishes, don't undo it. */
2971 Vautoload_queue
= Qt
;
2972 feature
= unbind_to (count
, feature
);
2978 /* Primitives for work of the "widget" library.
2979 In an ideal world, this section would not have been necessary.
2980 However, lisp function calls being as slow as they are, it turns
2981 out that some functions in the widget library (wid-edit.el) are the
2982 bottleneck of Widget operation. Here is their translation to C,
2983 for the sole reason of efficiency. */
2985 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2986 doc
: /* Return non-nil if PLIST has the property PROP.
2987 PLIST is a property list, which is a list of the form
2988 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2989 Unlike `plist-get', this allows you to distinguish between a missing
2990 property and a property with the value nil.
2991 The value is actually the tail of PLIST whose car is PROP. */)
2993 Lisp_Object plist
, prop
;
2995 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2998 plist
= XCDR (plist
);
2999 plist
= CDR (plist
);
3004 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3005 doc
: /* In WIDGET, set PROPERTY to VALUE.
3006 The value can later be retrieved with `widget-get'. */)
3007 (widget
, property
, value
)
3008 Lisp_Object widget
, property
, value
;
3010 CHECK_CONS (widget
);
3011 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3015 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3016 doc
: /* In WIDGET, get the value of PROPERTY.
3017 The value could either be specified when the widget was created, or
3018 later with `widget-put'. */)
3020 Lisp_Object widget
, property
;
3028 CHECK_CONS (widget
);
3029 tmp
= Fplist_member (XCDR (widget
), property
);
3035 tmp
= XCAR (widget
);
3038 widget
= Fget (tmp
, Qwidget_type
);
3042 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3043 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3044 ARGS are passed as extra arguments to the function.
3045 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3050 /* This function can GC. */
3051 Lisp_Object newargs
[3];
3052 struct gcpro gcpro1
, gcpro2
;
3055 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3056 newargs
[1] = args
[0];
3057 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3058 GCPRO2 (newargs
[0], newargs
[2]);
3059 result
= Fapply (3, newargs
);
3064 #ifdef HAVE_LANGINFO_CODESET
3065 #include <langinfo.h>
3068 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3069 doc
: /* Access locale data ITEM for the current C locale, if available.
3070 ITEM should be one of the following:
3072 `codeset', returning the character set as a string (locale item CODESET);
3074 `days', returning a 7-element vector of day names (locale items DAY_n);
3076 `months', returning a 12-element vector of month names (locale items MON_n);
3078 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3079 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3081 If the system can't provide such information through a call to
3082 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3084 See also Info node `(libc)Locales'.
3086 The data read from the system are decoded using `locale-coding-system'. */)
3091 #ifdef HAVE_LANGINFO_CODESET
3093 if (EQ (item
, Qcodeset
))
3095 str
= nl_langinfo (CODESET
);
3096 return build_string (str
);
3099 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3101 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3102 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3104 struct gcpro gcpro1
;
3106 synchronize_system_time_locale ();
3107 for (i
= 0; i
< 7; i
++)
3109 str
= nl_langinfo (days
[i
]);
3110 val
= make_unibyte_string (str
, strlen (str
));
3111 /* Fixme: Is this coding system necessarily right, even if
3112 it is consistent with CODESET? If not, what to do? */
3113 Faset (v
, make_number (i
),
3114 code_convert_string_norecord (val
, Vlocale_coding_system
,
3122 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3124 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3125 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3126 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3128 struct gcpro gcpro1
;
3130 synchronize_system_time_locale ();
3131 for (i
= 0; i
< 12; i
++)
3133 str
= nl_langinfo (months
[i
]);
3134 val
= make_unibyte_string (str
, strlen (str
));
3135 Faset (v
, make_number (i
),
3136 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3142 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3143 but is in the locale files. This could be used by ps-print. */
3145 else if (EQ (item
, Qpaper
))
3147 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3148 make_number (nl_langinfo (PAPER_HEIGHT
)));
3150 #endif /* PAPER_WIDTH */
3151 #endif /* HAVE_LANGINFO_CODESET*/
3155 /* base64 encode/decode functions (RFC 2045).
3156 Based on code from GNU recode. */
3158 #define MIME_LINE_LENGTH 76
3160 #define IS_ASCII(Character) \
3162 #define IS_BASE64(Character) \
3163 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3164 #define IS_BASE64_IGNORABLE(Character) \
3165 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3166 || (Character) == '\f' || (Character) == '\r')
3168 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3169 character or return retval if there are no characters left to
3171 #define READ_QUADRUPLET_BYTE(retval) \
3176 if (nchars_return) \
3177 *nchars_return = nchars; \
3182 while (IS_BASE64_IGNORABLE (c))
3184 /* Table of characters coding the 64 values. */
3185 static const char base64_value_to_char
[64] =
3187 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3188 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3189 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3190 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3191 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3192 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3193 '8', '9', '+', '/' /* 60-63 */
3196 /* Table of base64 values for first 128 characters. */
3197 static const short base64_char_to_value
[128] =
3199 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3200 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3201 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3202 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3203 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3204 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3205 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3206 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3207 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3208 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3209 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3210 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3211 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3214 /* The following diagram shows the logical steps by which three octets
3215 get transformed into four base64 characters.
3217 .--------. .--------. .--------.
3218 |aaaaaabb| |bbbbcccc| |ccdddddd|
3219 `--------' `--------' `--------'
3221 .--------+--------+--------+--------.
3222 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3223 `--------+--------+--------+--------'
3225 .--------+--------+--------+--------.
3226 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3227 `--------+--------+--------+--------'
3229 The octets are divided into 6 bit chunks, which are then encoded into
3230 base64 characters. */
3233 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3234 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3236 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3238 doc
: /* Base64-encode the region between BEG and END.
3239 Return the length of the encoded text.
3240 Optional third argument NO-LINE-BREAK means do not break long lines
3241 into shorter lines. */)
3242 (beg
, end
, no_line_break
)
3243 Lisp_Object beg
, end
, no_line_break
;
3246 int allength
, length
;
3247 int ibeg
, iend
, encoded_length
;
3251 validate_region (&beg
, &end
);
3253 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3254 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3255 move_gap_both (XFASTINT (beg
), ibeg
);
3257 /* We need to allocate enough room for encoding the text.
3258 We need 33 1/3% more space, plus a newline every 76
3259 characters, and then we round up. */
3260 length
= iend
- ibeg
;
3261 allength
= length
+ length
/3 + 1;
3262 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3264 SAFE_ALLOCA (encoded
, char *, allength
);
3265 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3266 NILP (no_line_break
),
3267 !NILP (current_buffer
->enable_multibyte_characters
));
3268 if (encoded_length
> allength
)
3271 if (encoded_length
< 0)
3273 /* The encoding wasn't possible. */
3275 error ("Multibyte character in data for base64 encoding");
3278 /* Now we have encoded the region, so we insert the new contents
3279 and delete the old. (Insert first in order to preserve markers.) */
3280 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3281 insert (encoded
, encoded_length
);
3283 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3285 /* If point was outside of the region, restore it exactly; else just
3286 move to the beginning of the region. */
3287 if (old_pos
>= XFASTINT (end
))
3288 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3289 else if (old_pos
> XFASTINT (beg
))
3290 old_pos
= XFASTINT (beg
);
3293 /* We return the length of the encoded text. */
3294 return make_number (encoded_length
);
3297 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3299 doc
: /* Base64-encode STRING and return the result.
3300 Optional second argument NO-LINE-BREAK means do not break long lines
3301 into shorter lines. */)
3302 (string
, no_line_break
)
3303 Lisp_Object string
, no_line_break
;
3305 int allength
, length
, encoded_length
;
3307 Lisp_Object encoded_string
;
3310 CHECK_STRING (string
);
3312 /* We need to allocate enough room for encoding the text.
3313 We need 33 1/3% more space, plus a newline every 76
3314 characters, and then we round up. */
3315 length
= SBYTES (string
);
3316 allength
= length
+ length
/3 + 1;
3317 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3319 /* We need to allocate enough room for decoding the text. */
3320 SAFE_ALLOCA (encoded
, char *, allength
);
3322 encoded_length
= base64_encode_1 (SDATA (string
),
3323 encoded
, length
, NILP (no_line_break
),
3324 STRING_MULTIBYTE (string
));
3325 if (encoded_length
> allength
)
3328 if (encoded_length
< 0)
3330 /* The encoding wasn't possible. */
3332 error ("Multibyte character in data for base64 encoding");
3335 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3338 return encoded_string
;
3342 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3349 int counter
= 0, i
= 0;
3359 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3360 if (CHAR_BYTE8_P (c
))
3361 c
= CHAR_TO_BYTE8 (c
);
3369 /* Wrap line every 76 characters. */
3373 if (counter
< MIME_LINE_LENGTH
/ 4)
3382 /* Process first byte of a triplet. */
3384 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3385 value
= (0x03 & c
) << 4;
3387 /* Process second byte of a triplet. */
3391 *e
++ = base64_value_to_char
[value
];
3399 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3400 if (CHAR_BYTE8_P (c
))
3401 c
= CHAR_TO_BYTE8 (c
);
3409 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3410 value
= (0x0f & c
) << 2;
3412 /* Process third byte of a triplet. */
3416 *e
++ = base64_value_to_char
[value
];
3423 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3424 if (CHAR_BYTE8_P (c
))
3425 c
= CHAR_TO_BYTE8 (c
);
3433 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3434 *e
++ = base64_value_to_char
[0x3f & c
];
3441 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3443 doc
: /* Base64-decode the region between BEG and END.
3444 Return the length of the decoded text.
3445 If the region can't be decoded, signal an error and don't modify the buffer. */)
3447 Lisp_Object beg
, end
;
3449 int ibeg
, iend
, length
, allength
;
3454 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3457 validate_region (&beg
, &end
);
3459 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3460 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3462 length
= iend
- ibeg
;
3464 /* We need to allocate enough room for decoding the text. If we are
3465 working on a multibyte buffer, each decoded code may occupy at
3467 allength
= multibyte
? length
* 2 : length
;
3468 SAFE_ALLOCA (decoded
, char *, allength
);
3470 move_gap_both (XFASTINT (beg
), ibeg
);
3471 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3472 multibyte
, &inserted_chars
);
3473 if (decoded_length
> allength
)
3476 if (decoded_length
< 0)
3478 /* The decoding wasn't possible. */
3480 error ("Invalid base64 data");
3483 /* Now we have decoded the region, so we insert the new contents
3484 and delete the old. (Insert first in order to preserve markers.) */
3485 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3486 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3489 /* Delete the original text. */
3490 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3491 iend
+ decoded_length
, 1);
3493 /* If point was outside of the region, restore it exactly; else just
3494 move to the beginning of the region. */
3495 if (old_pos
>= XFASTINT (end
))
3496 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3497 else if (old_pos
> XFASTINT (beg
))
3498 old_pos
= XFASTINT (beg
);
3499 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3501 return make_number (inserted_chars
);
3504 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3506 doc
: /* Base64-decode STRING and return the result. */)
3511 int length
, decoded_length
;
3512 Lisp_Object decoded_string
;
3515 CHECK_STRING (string
);
3517 length
= SBYTES (string
);
3518 /* We need to allocate enough room for decoding the text. */
3519 SAFE_ALLOCA (decoded
, char *, length
);
3521 /* The decoded result should be unibyte. */
3522 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3524 if (decoded_length
> length
)
3526 else if (decoded_length
>= 0)
3527 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3529 decoded_string
= Qnil
;
3532 if (!STRINGP (decoded_string
))
3533 error ("Invalid base64 data");
3535 return decoded_string
;
3538 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3539 MULTIBYTE is nonzero, the decoded result should be in multibyte
3540 form. If NCHARS_RETRUN is not NULL, store the number of produced
3541 characters in *NCHARS_RETURN. */
3544 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3554 unsigned long value
;
3559 /* Process first byte of a quadruplet. */
3561 READ_QUADRUPLET_BYTE (e
-to
);
3565 value
= base64_char_to_value
[c
] << 18;
3567 /* Process second byte of a quadruplet. */
3569 READ_QUADRUPLET_BYTE (-1);
3573 value
|= base64_char_to_value
[c
] << 12;
3575 c
= (unsigned char) (value
>> 16);
3576 if (multibyte
&& c
>= 128)
3577 e
+= BYTE8_STRING (c
, e
);
3582 /* Process third byte of a quadruplet. */
3584 READ_QUADRUPLET_BYTE (-1);
3588 READ_QUADRUPLET_BYTE (-1);
3597 value
|= base64_char_to_value
[c
] << 6;
3599 c
= (unsigned char) (0xff & value
>> 8);
3600 if (multibyte
&& c
>= 128)
3601 e
+= BYTE8_STRING (c
, e
);
3606 /* Process fourth byte of a quadruplet. */
3608 READ_QUADRUPLET_BYTE (-1);
3615 value
|= base64_char_to_value
[c
];
3617 c
= (unsigned char) (0xff & value
);
3618 if (multibyte
&& c
>= 128)
3619 e
+= BYTE8_STRING (c
, e
);
3628 /***********************************************************************
3630 ***** Hash Tables *****
3632 ***********************************************************************/
3634 /* Implemented by gerd@gnu.org. This hash table implementation was
3635 inspired by CMUCL hash tables. */
3639 1. For small tables, association lists are probably faster than
3640 hash tables because they have lower overhead.
3642 For uses of hash tables where the O(1) behavior of table
3643 operations is not a requirement, it might therefore be a good idea
3644 not to hash. Instead, we could just do a linear search in the
3645 key_and_value vector of the hash table. This could be done
3646 if a `:linear-search t' argument is given to make-hash-table. */
3649 /* The list of all weak hash tables. Don't staticpro this one. */
3651 struct Lisp_Hash_Table
*weak_hash_tables
;
3653 /* Various symbols. */
3655 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3656 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3657 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3659 /* Function prototypes. */
3661 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3662 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3663 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3664 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3665 Lisp_Object
, unsigned));
3666 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3667 Lisp_Object
, unsigned));
3668 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3669 unsigned, Lisp_Object
, unsigned));
3670 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3671 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3672 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3673 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3675 static unsigned sxhash_string
P_ ((unsigned char *, int));
3676 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3677 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3678 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3679 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3683 /***********************************************************************
3685 ***********************************************************************/
3687 /* If OBJ is a Lisp hash table, return a pointer to its struct
3688 Lisp_Hash_Table. Otherwise, signal an error. */
3690 static struct Lisp_Hash_Table
*
3691 check_hash_table (obj
)
3694 CHECK_HASH_TABLE (obj
);
3695 return XHASH_TABLE (obj
);
3699 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3703 next_almost_prime (n
)
3716 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3717 which USED[I] is non-zero. If found at index I in ARGS, set
3718 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3719 -1. This function is used to extract a keyword/argument pair from
3720 a DEFUN parameter list. */
3723 get_key_arg (key
, nargs
, args
, used
)
3731 for (i
= 0; i
< nargs
- 1; ++i
)
3732 if (!used
[i
] && EQ (args
[i
], key
))
3747 /* Return a Lisp vector which has the same contents as VEC but has
3748 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3749 vector that are not copied from VEC are set to INIT. */
3752 larger_vector (vec
, new_size
, init
)
3757 struct Lisp_Vector
*v
;
3760 xassert (VECTORP (vec
));
3761 old_size
= ASIZE (vec
);
3762 xassert (new_size
>= old_size
);
3764 v
= allocate_vector (new_size
);
3765 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3766 old_size
* sizeof *v
->contents
);
3767 for (i
= old_size
; i
< new_size
; ++i
)
3768 v
->contents
[i
] = init
;
3769 XSETVECTOR (vec
, v
);
3774 /***********************************************************************
3776 ***********************************************************************/
3778 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3779 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3780 KEY2 are the same. */
3783 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3784 struct Lisp_Hash_Table
*h
;
3785 Lisp_Object key1
, key2
;
3786 unsigned hash1
, hash2
;
3788 return (FLOATP (key1
)
3790 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3794 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3795 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3796 KEY2 are the same. */
3799 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3800 struct Lisp_Hash_Table
*h
;
3801 Lisp_Object key1
, key2
;
3802 unsigned hash1
, hash2
;
3804 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3808 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3809 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3810 if KEY1 and KEY2 are the same. */
3813 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3814 struct Lisp_Hash_Table
*h
;
3815 Lisp_Object key1
, key2
;
3816 unsigned hash1
, hash2
;
3820 Lisp_Object args
[3];
3822 args
[0] = h
->user_cmp_function
;
3825 return !NILP (Ffuncall (3, args
));
3832 /* Value is a hash code for KEY for use in hash table H which uses
3833 `eq' to compare keys. The hash code returned is guaranteed to fit
3834 in a Lisp integer. */
3838 struct Lisp_Hash_Table
*h
;
3841 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3842 xassert ((hash
& ~INTMASK
) == 0);
3847 /* Value is a hash code for KEY for use in hash table H which uses
3848 `eql' to compare keys. The hash code returned is guaranteed to fit
3849 in a Lisp integer. */
3853 struct Lisp_Hash_Table
*h
;
3858 hash
= sxhash (key
, 0);
3860 hash
= XUINT (key
) ^ XTYPE (key
);
3861 xassert ((hash
& ~INTMASK
) == 0);
3866 /* Value is a hash code for KEY for use in hash table H which uses
3867 `equal' to compare keys. The hash code returned is guaranteed to fit
3868 in a Lisp integer. */
3871 hashfn_equal (h
, key
)
3872 struct Lisp_Hash_Table
*h
;
3875 unsigned hash
= sxhash (key
, 0);
3876 xassert ((hash
& ~INTMASK
) == 0);
3881 /* Value is a hash code for KEY for use in hash table H which uses as
3882 user-defined function to compare keys. The hash code returned is
3883 guaranteed to fit in a Lisp integer. */
3886 hashfn_user_defined (h
, key
)
3887 struct Lisp_Hash_Table
*h
;
3890 Lisp_Object args
[2], hash
;
3892 args
[0] = h
->user_hash_function
;
3894 hash
= Ffuncall (2, args
);
3895 if (!INTEGERP (hash
))
3896 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3897 return XUINT (hash
);
3901 /* Create and initialize a new hash table.
3903 TEST specifies the test the hash table will use to compare keys.
3904 It must be either one of the predefined tests `eq', `eql' or
3905 `equal' or a symbol denoting a user-defined test named TEST with
3906 test and hash functions USER_TEST and USER_HASH.
3908 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3910 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3911 new size when it becomes full is computed by adding REHASH_SIZE to
3912 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3913 table's new size is computed by multiplying its old size with
3916 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3917 be resized when the ratio of (number of entries in the table) /
3918 (table size) is >= REHASH_THRESHOLD.
3920 WEAK specifies the weakness of the table. If non-nil, it must be
3921 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3924 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3925 user_test
, user_hash
)
3926 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3927 Lisp_Object user_test
, user_hash
;
3929 struct Lisp_Hash_Table
*h
;
3931 int index_size
, i
, sz
;
3933 /* Preconditions. */
3934 xassert (SYMBOLP (test
));
3935 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3936 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3937 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3938 xassert (FLOATP (rehash_threshold
)
3939 && XFLOATINT (rehash_threshold
) > 0
3940 && XFLOATINT (rehash_threshold
) <= 1.0);
3942 if (XFASTINT (size
) == 0)
3943 size
= make_number (1);
3945 /* Allocate a table and initialize it. */
3946 h
= allocate_hash_table ();
3948 /* Initialize hash table slots. */
3949 sz
= XFASTINT (size
);
3952 if (EQ (test
, Qeql
))
3954 h
->cmpfn
= cmpfn_eql
;
3955 h
->hashfn
= hashfn_eql
;
3957 else if (EQ (test
, Qeq
))
3960 h
->hashfn
= hashfn_eq
;
3962 else if (EQ (test
, Qequal
))
3964 h
->cmpfn
= cmpfn_equal
;
3965 h
->hashfn
= hashfn_equal
;
3969 h
->user_cmp_function
= user_test
;
3970 h
->user_hash_function
= user_hash
;
3971 h
->cmpfn
= cmpfn_user_defined
;
3972 h
->hashfn
= hashfn_user_defined
;
3976 h
->rehash_threshold
= rehash_threshold
;
3977 h
->rehash_size
= rehash_size
;
3979 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3980 h
->hash
= Fmake_vector (size
, Qnil
);
3981 h
->next
= Fmake_vector (size
, Qnil
);
3982 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3983 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3984 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3986 /* Set up the free list. */
3987 for (i
= 0; i
< sz
- 1; ++i
)
3988 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3989 h
->next_free
= make_number (0);
3991 XSET_HASH_TABLE (table
, h
);
3992 xassert (HASH_TABLE_P (table
));
3993 xassert (XHASH_TABLE (table
) == h
);
3995 /* Maybe add this hash table to the list of all weak hash tables. */
3997 h
->next_weak
= NULL
;
4000 h
->next_weak
= weak_hash_tables
;
4001 weak_hash_tables
= h
;
4008 /* Return a copy of hash table H1. Keys and values are not copied,
4009 only the table itself is. */
4012 copy_hash_table (h1
)
4013 struct Lisp_Hash_Table
*h1
;
4016 struct Lisp_Hash_Table
*h2
;
4017 struct Lisp_Vector
*next
;
4019 h2
= allocate_hash_table ();
4020 next
= h2
->header
.next
.vector
;
4021 bcopy (h1
, h2
, sizeof *h2
);
4022 h2
->header
.next
.vector
= next
;
4023 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4024 h2
->hash
= Fcopy_sequence (h1
->hash
);
4025 h2
->next
= Fcopy_sequence (h1
->next
);
4026 h2
->index
= Fcopy_sequence (h1
->index
);
4027 XSET_HASH_TABLE (table
, h2
);
4029 /* Maybe add this hash table to the list of all weak hash tables. */
4030 if (!NILP (h2
->weak
))
4032 h2
->next_weak
= weak_hash_tables
;
4033 weak_hash_tables
= h2
;
4040 /* Resize hash table H if it's too full. If H cannot be resized
4041 because it's already too large, throw an error. */
4044 maybe_resize_hash_table (h
)
4045 struct Lisp_Hash_Table
*h
;
4047 if (NILP (h
->next_free
))
4049 int old_size
= HASH_TABLE_SIZE (h
);
4050 int i
, new_size
, index_size
;
4053 if (INTEGERP (h
->rehash_size
))
4054 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4056 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4057 new_size
= max (old_size
+ 1, new_size
);
4058 index_size
= next_almost_prime ((int)
4060 / XFLOATINT (h
->rehash_threshold
)));
4061 /* Assignment to EMACS_INT stops GCC whining about limited range
4063 nsize
= max (index_size
, 2 * new_size
);
4064 if (nsize
> MOST_POSITIVE_FIXNUM
)
4065 error ("Hash table too large to resize");
4067 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4068 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4069 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4070 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4072 /* Update the free list. Do it so that new entries are added at
4073 the end of the free list. This makes some operations like
4075 for (i
= old_size
; i
< new_size
- 1; ++i
)
4076 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4078 if (!NILP (h
->next_free
))
4080 Lisp_Object last
, next
;
4082 last
= h
->next_free
;
4083 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4087 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4090 XSETFASTINT (h
->next_free
, old_size
);
4093 for (i
= 0; i
< old_size
; ++i
)
4094 if (!NILP (HASH_HASH (h
, i
)))
4096 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4097 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4098 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4099 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4105 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4106 the hash code of KEY. Value is the index of the entry in H
4107 matching KEY, or -1 if not found. */
4110 hash_lookup (h
, key
, hash
)
4111 struct Lisp_Hash_Table
*h
;
4116 int start_of_bucket
;
4119 hash_code
= h
->hashfn (h
, key
);
4123 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4124 idx
= HASH_INDEX (h
, start_of_bucket
);
4126 /* We need not gcpro idx since it's either an integer or nil. */
4129 int i
= XFASTINT (idx
);
4130 if (EQ (key
, HASH_KEY (h
, i
))
4132 && h
->cmpfn (h
, key
, hash_code
,
4133 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4135 idx
= HASH_NEXT (h
, i
);
4138 return NILP (idx
) ? -1 : XFASTINT (idx
);
4142 /* Put an entry into hash table H that associates KEY with VALUE.
4143 HASH is a previously computed hash code of KEY.
4144 Value is the index of the entry in H matching KEY. */
4147 hash_put (h
, key
, value
, hash
)
4148 struct Lisp_Hash_Table
*h
;
4149 Lisp_Object key
, value
;
4152 int start_of_bucket
, i
;
4154 xassert ((hash
& ~INTMASK
) == 0);
4156 /* Increment count after resizing because resizing may fail. */
4157 maybe_resize_hash_table (h
);
4160 /* Store key/value in the key_and_value vector. */
4161 i
= XFASTINT (h
->next_free
);
4162 h
->next_free
= HASH_NEXT (h
, i
);
4163 HASH_KEY (h
, i
) = key
;
4164 HASH_VALUE (h
, i
) = value
;
4166 /* Remember its hash code. */
4167 HASH_HASH (h
, i
) = make_number (hash
);
4169 /* Add new entry to its collision chain. */
4170 start_of_bucket
= hash
% ASIZE (h
->index
);
4171 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4172 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4177 /* Remove the entry matching KEY from hash table H, if there is one. */
4180 hash_remove_from_table (h
, key
)
4181 struct Lisp_Hash_Table
*h
;
4185 int start_of_bucket
;
4186 Lisp_Object idx
, prev
;
4188 hash_code
= h
->hashfn (h
, key
);
4189 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4190 idx
= HASH_INDEX (h
, start_of_bucket
);
4193 /* We need not gcpro idx, prev since they're either integers or nil. */
4196 int i
= XFASTINT (idx
);
4198 if (EQ (key
, HASH_KEY (h
, i
))
4200 && h
->cmpfn (h
, key
, hash_code
,
4201 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4203 /* Take entry out of collision chain. */
4205 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4207 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4209 /* Clear slots in key_and_value and add the slots to
4211 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4212 HASH_NEXT (h
, i
) = h
->next_free
;
4213 h
->next_free
= make_number (i
);
4215 xassert (h
->count
>= 0);
4221 idx
= HASH_NEXT (h
, i
);
4227 /* Clear hash table H. */
4231 struct Lisp_Hash_Table
*h
;
4235 int i
, size
= HASH_TABLE_SIZE (h
);
4237 for (i
= 0; i
< size
; ++i
)
4239 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4240 HASH_KEY (h
, i
) = Qnil
;
4241 HASH_VALUE (h
, i
) = Qnil
;
4242 HASH_HASH (h
, i
) = Qnil
;
4245 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4246 ASET (h
->index
, i
, Qnil
);
4248 h
->next_free
= make_number (0);
4255 /************************************************************************
4257 ************************************************************************/
4260 init_weak_hash_tables ()
4262 weak_hash_tables
= NULL
;
4265 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4266 entries from the table that don't survive the current GC.
4267 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4268 non-zero if anything was marked. */
4271 sweep_weak_table (h
, remove_entries_p
)
4272 struct Lisp_Hash_Table
*h
;
4273 int remove_entries_p
;
4275 int bucket
, n
, marked
;
4277 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4280 for (bucket
= 0; bucket
< n
; ++bucket
)
4282 Lisp_Object idx
, next
, prev
;
4284 /* Follow collision chain, removing entries that
4285 don't survive this garbage collection. */
4287 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4289 int i
= XFASTINT (idx
);
4290 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4291 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4294 if (EQ (h
->weak
, Qkey
))
4295 remove_p
= !key_known_to_survive_p
;
4296 else if (EQ (h
->weak
, Qvalue
))
4297 remove_p
= !value_known_to_survive_p
;
4298 else if (EQ (h
->weak
, Qkey_or_value
))
4299 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4300 else if (EQ (h
->weak
, Qkey_and_value
))
4301 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4305 next
= HASH_NEXT (h
, i
);
4307 if (remove_entries_p
)
4311 /* Take out of collision chain. */
4313 HASH_INDEX (h
, bucket
) = next
;
4315 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4317 /* Add to free list. */
4318 HASH_NEXT (h
, i
) = h
->next_free
;
4321 /* Clear key, value, and hash. */
4322 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4323 HASH_HASH (h
, i
) = Qnil
;
4336 /* Make sure key and value survive. */
4337 if (!key_known_to_survive_p
)
4339 mark_object (HASH_KEY (h
, i
));
4343 if (!value_known_to_survive_p
)
4345 mark_object (HASH_VALUE (h
, i
));
4356 /* Remove elements from weak hash tables that don't survive the
4357 current garbage collection. Remove weak tables that don't survive
4358 from Vweak_hash_tables. Called from gc_sweep. */
4361 sweep_weak_hash_tables ()
4363 struct Lisp_Hash_Table
*h
, *used
, *next
;
4366 /* Mark all keys and values that are in use. Keep on marking until
4367 there is no more change. This is necessary for cases like
4368 value-weak table A containing an entry X -> Y, where Y is used in a
4369 key-weak table B, Z -> Y. If B comes after A in the list of weak
4370 tables, X -> Y might be removed from A, although when looking at B
4371 one finds that it shouldn't. */
4375 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4377 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4378 marked
|= sweep_weak_table (h
, 0);
4383 /* Remove tables and entries that aren't used. */
4384 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4386 next
= h
->next_weak
;
4388 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4390 /* TABLE is marked as used. Sweep its contents. */
4392 sweep_weak_table (h
, 1);
4394 /* Add table to the list of used weak hash tables. */
4395 h
->next_weak
= used
;
4400 weak_hash_tables
= used
;
4405 /***********************************************************************
4406 Hash Code Computation
4407 ***********************************************************************/
4409 /* Maximum depth up to which to dive into Lisp structures. */
4411 #define SXHASH_MAX_DEPTH 3
4413 /* Maximum length up to which to take list and vector elements into
4416 #define SXHASH_MAX_LEN 7
4418 /* Combine two integers X and Y for hashing. */
4420 #define SXHASH_COMBINE(X, Y) \
4421 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4425 /* Return a hash for string PTR which has length LEN. The hash
4426 code returned is guaranteed to fit in a Lisp integer. */
4429 sxhash_string (ptr
, len
)
4433 unsigned char *p
= ptr
;
4434 unsigned char *end
= p
+ len
;
4443 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4446 return hash
& INTMASK
;
4450 /* Return a hash for list LIST. DEPTH is the current depth in the
4451 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4454 sxhash_list (list
, depth
)
4461 if (depth
< SXHASH_MAX_DEPTH
)
4463 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4464 list
= XCDR (list
), ++i
)
4466 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4467 hash
= SXHASH_COMBINE (hash
, hash2
);
4472 unsigned hash2
= sxhash (list
, depth
+ 1);
4473 hash
= SXHASH_COMBINE (hash
, hash2
);
4480 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4481 the Lisp structure. */
4484 sxhash_vector (vec
, depth
)
4488 unsigned hash
= ASIZE (vec
);
4491 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4492 for (i
= 0; i
< n
; ++i
)
4494 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4495 hash
= SXHASH_COMBINE (hash
, hash2
);
4502 /* Return a hash for bool-vector VECTOR. */
4505 sxhash_bool_vector (vec
)
4508 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4511 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->header
.size
);
4512 for (i
= 0; i
< n
; ++i
)
4513 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4519 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4520 structure. Value is an unsigned integer clipped to INTMASK. */
4529 if (depth
> SXHASH_MAX_DEPTH
)
4532 switch (XTYPE (obj
))
4543 obj
= SYMBOL_NAME (obj
);
4547 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4550 /* This can be everything from a vector to an overlay. */
4551 case Lisp_Vectorlike
:
4553 /* According to the CL HyperSpec, two arrays are equal only if
4554 they are `eq', except for strings and bit-vectors. In
4555 Emacs, this works differently. We have to compare element
4557 hash
= sxhash_vector (obj
, depth
);
4558 else if (BOOL_VECTOR_P (obj
))
4559 hash
= sxhash_bool_vector (obj
);
4561 /* Others are `equal' if they are `eq', so let's take their
4567 hash
= sxhash_list (obj
, depth
);
4572 double val
= XFLOAT_DATA (obj
);
4573 unsigned char *p
= (unsigned char *) &val
;
4574 unsigned char *e
= p
+ sizeof val
;
4575 for (hash
= 0; p
< e
; ++p
)
4576 hash
= SXHASH_COMBINE (hash
, *p
);
4584 return hash
& INTMASK
;
4589 /***********************************************************************
4591 ***********************************************************************/
4594 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4595 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4599 unsigned hash
= sxhash (obj
, 0);
4600 return make_number (hash
);
4604 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4605 doc
: /* Create and return a new hash table.
4607 Arguments are specified as keyword/argument pairs. The following
4608 arguments are defined:
4610 :test TEST -- TEST must be a symbol that specifies how to compare
4611 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4612 `equal'. User-supplied test and hash functions can be specified via
4613 `define-hash-table-test'.
4615 :size SIZE -- A hint as to how many elements will be put in the table.
4618 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4619 fills up. If REHASH-SIZE is an integer, add that many space. If it
4620 is a float, it must be > 1.0, and the new size is computed by
4621 multiplying the old size with that factor. Default is 1.5.
4623 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4624 Resize the hash table when the ratio (number of entries / table size)
4625 is greater or equal than THRESHOLD. Default is 0.8.
4627 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4628 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4629 returned is a weak table. Key/value pairs are removed from a weak
4630 hash table when there are no non-weak references pointing to their
4631 key, value, one of key or value, or both key and value, depending on
4632 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4635 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4640 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4641 Lisp_Object user_test
, user_hash
;
4645 /* The vector `used' is used to keep track of arguments that
4646 have been consumed. */
4647 used
= (char *) alloca (nargs
* sizeof *used
);
4648 bzero (used
, nargs
* sizeof *used
);
4650 /* See if there's a `:test TEST' among the arguments. */
4651 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4652 test
= i
< 0 ? Qeql
: args
[i
];
4653 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4655 /* See if it is a user-defined test. */
4658 prop
= Fget (test
, Qhash_table_test
);
4659 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4660 signal_error ("Invalid hash table test", test
);
4661 user_test
= XCAR (prop
);
4662 user_hash
= XCAR (XCDR (prop
));
4665 user_test
= user_hash
= Qnil
;
4667 /* See if there's a `:size SIZE' argument. */
4668 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4669 size
= i
< 0 ? Qnil
: args
[i
];
4671 size
= make_number (DEFAULT_HASH_SIZE
);
4672 else if (!INTEGERP (size
) || XINT (size
) < 0)
4673 signal_error ("Invalid hash table size", size
);
4675 /* Look for `:rehash-size SIZE'. */
4676 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4677 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4678 if (!NUMBERP (rehash_size
)
4679 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4680 || XFLOATINT (rehash_size
) <= 1.0)
4681 signal_error ("Invalid hash table rehash size", rehash_size
);
4683 /* Look for `:rehash-threshold THRESHOLD'. */
4684 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4685 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4686 if (!FLOATP (rehash_threshold
)
4687 || XFLOATINT (rehash_threshold
) <= 0.0
4688 || XFLOATINT (rehash_threshold
) > 1.0)
4689 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4691 /* Look for `:weakness WEAK'. */
4692 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4693 weak
= i
< 0 ? Qnil
: args
[i
];
4695 weak
= Qkey_and_value
;
4698 && !EQ (weak
, Qvalue
)
4699 && !EQ (weak
, Qkey_or_value
)
4700 && !EQ (weak
, Qkey_and_value
))
4701 signal_error ("Invalid hash table weakness", weak
);
4703 /* Now, all args should have been used up, or there's a problem. */
4704 for (i
= 0; i
< nargs
; ++i
)
4706 signal_error ("Invalid argument list", args
[i
]);
4708 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4709 user_test
, user_hash
);
4713 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4714 doc
: /* Return a copy of hash table TABLE. */)
4718 return copy_hash_table (check_hash_table (table
));
4722 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4723 doc
: /* Return the number of elements in TABLE. */)
4727 return make_number (check_hash_table (table
)->count
);
4731 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4732 Shash_table_rehash_size
, 1, 1, 0,
4733 doc
: /* Return the current rehash size of TABLE. */)
4737 return check_hash_table (table
)->rehash_size
;
4741 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4742 Shash_table_rehash_threshold
, 1, 1, 0,
4743 doc
: /* Return the current rehash threshold of TABLE. */)
4747 return check_hash_table (table
)->rehash_threshold
;
4751 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4752 doc
: /* Return the size of TABLE.
4753 The size can be used as an argument to `make-hash-table' to create
4754 a hash table than can hold as many elements as TABLE holds
4755 without need for resizing. */)
4759 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4760 return make_number (HASH_TABLE_SIZE (h
));
4764 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4765 doc
: /* Return the test TABLE uses. */)
4769 return check_hash_table (table
)->test
;
4773 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4775 doc
: /* Return the weakness of TABLE. */)
4779 return check_hash_table (table
)->weak
;
4783 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4784 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4788 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4792 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4793 doc
: /* Clear hash table TABLE and return it. */)
4797 hash_clear (check_hash_table (table
));
4798 /* Be compatible with XEmacs. */
4803 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4804 doc
: /* Look up KEY in TABLE and return its associated value.
4805 If KEY is not found, return DFLT which defaults to nil. */)
4807 Lisp_Object key
, table
, dflt
;
4809 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4810 int i
= hash_lookup (h
, key
, NULL
);
4811 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4815 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4816 doc
: /* Associate KEY with VALUE in hash table TABLE.
4817 If KEY is already present in table, replace its current value with
4820 Lisp_Object key
, value
, table
;
4822 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4826 i
= hash_lookup (h
, key
, &hash
);
4828 HASH_VALUE (h
, i
) = value
;
4830 hash_put (h
, key
, value
, hash
);
4836 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4837 doc
: /* Remove KEY from TABLE. */)
4839 Lisp_Object key
, table
;
4841 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4842 hash_remove_from_table (h
, key
);
4847 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4848 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4849 FUNCTION is called with two arguments, KEY and VALUE. */)
4851 Lisp_Object function
, table
;
4853 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4854 Lisp_Object args
[3];
4857 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4858 if (!NILP (HASH_HASH (h
, i
)))
4861 args
[1] = HASH_KEY (h
, i
);
4862 args
[2] = HASH_VALUE (h
, i
);
4870 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4871 Sdefine_hash_table_test
, 3, 3, 0,
4872 doc
: /* Define a new hash table test with name NAME, a symbol.
4874 In hash tables created with NAME specified as test, use TEST to
4875 compare keys, and HASH for computing hash codes of keys.
4877 TEST must be a function taking two arguments and returning non-nil if
4878 both arguments are the same. HASH must be a function taking one
4879 argument and return an integer that is the hash code of the argument.
4880 Hash code computation should use the whole value range of integers,
4881 including negative integers. */)
4883 Lisp_Object name
, test
, hash
;
4885 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4890 /************************************************************************
4892 ************************************************************************/
4896 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4897 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4899 A message digest is a cryptographic checksum of a document, and the
4900 algorithm to calculate it is defined in RFC 1321.
4902 The two optional arguments START and END are character positions
4903 specifying for which part of OBJECT the message digest should be
4904 computed. If nil or omitted, the digest is computed for the whole
4907 The MD5 message digest is computed from the result of encoding the
4908 text in a coding system, not directly from the internal Emacs form of
4909 the text. The optional fourth argument CODING-SYSTEM specifies which
4910 coding system to encode the text with. It should be the same coding
4911 system that you used or will use when actually writing the text into a
4914 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4915 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4916 system would be chosen by default for writing this text into a file.
4918 If OBJECT is a string, the most preferred coding system (see the
4919 command `prefer-coding-system') is used.
4921 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4922 guesswork fails. Normally, an error is signaled in such case. */)
4923 (object
, start
, end
, coding_system
, noerror
)
4924 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4926 unsigned char digest
[16];
4927 unsigned char value
[33];
4931 int start_char
= 0, end_char
= 0;
4932 int start_byte
= 0, end_byte
= 0;
4934 register struct buffer
*bp
;
4937 if (STRINGP (object
))
4939 if (NILP (coding_system
))
4941 /* Decide the coding-system to encode the data with. */
4943 if (STRING_MULTIBYTE (object
))
4944 /* use default, we can't guess correct value */
4945 coding_system
= preferred_coding_system ();
4947 coding_system
= Qraw_text
;
4950 if (NILP (Fcoding_system_p (coding_system
)))
4952 /* Invalid coding system. */
4954 if (!NILP (noerror
))
4955 coding_system
= Qraw_text
;
4957 xsignal1 (Qcoding_system_error
, coding_system
);
4960 if (STRING_MULTIBYTE (object
))
4961 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4963 size
= SCHARS (object
);
4964 size_byte
= SBYTES (object
);
4968 CHECK_NUMBER (start
);
4970 start_char
= XINT (start
);
4975 start_byte
= string_char_to_byte (object
, start_char
);
4981 end_byte
= size_byte
;
4987 end_char
= XINT (end
);
4992 end_byte
= string_char_to_byte (object
, end_char
);
4995 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4996 args_out_of_range_3 (object
, make_number (start_char
),
4997 make_number (end_char
));
5001 struct buffer
*prev
= current_buffer
;
5003 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5005 CHECK_BUFFER (object
);
5007 bp
= XBUFFER (object
);
5008 if (bp
!= current_buffer
)
5009 set_buffer_internal (bp
);
5015 CHECK_NUMBER_COERCE_MARKER (start
);
5023 CHECK_NUMBER_COERCE_MARKER (end
);
5028 temp
= b
, b
= e
, e
= temp
;
5030 if (!(BEGV
<= b
&& e
<= ZV
))
5031 args_out_of_range (start
, end
);
5033 if (NILP (coding_system
))
5035 /* Decide the coding-system to encode the data with.
5036 See fileio.c:Fwrite-region */
5038 if (!NILP (Vcoding_system_for_write
))
5039 coding_system
= Vcoding_system_for_write
;
5042 int force_raw_text
= 0;
5044 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5045 if (NILP (coding_system
)
5046 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5048 coding_system
= Qnil
;
5049 if (NILP (current_buffer
->enable_multibyte_characters
))
5053 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5055 /* Check file-coding-system-alist. */
5056 Lisp_Object args
[4], val
;
5058 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5059 args
[3] = Fbuffer_file_name(object
);
5060 val
= Ffind_operation_coding_system (4, args
);
5061 if (CONSP (val
) && !NILP (XCDR (val
)))
5062 coding_system
= XCDR (val
);
5065 if (NILP (coding_system
)
5066 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5068 /* If we still have not decided a coding system, use the
5069 default value of buffer-file-coding-system. */
5070 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5074 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5075 /* Confirm that VAL can surely encode the current region. */
5076 coding_system
= call4 (Vselect_safe_coding_system_function
,
5077 make_number (b
), make_number (e
),
5078 coding_system
, Qnil
);
5081 coding_system
= Qraw_text
;
5084 if (NILP (Fcoding_system_p (coding_system
)))
5086 /* Invalid coding system. */
5088 if (!NILP (noerror
))
5089 coding_system
= Qraw_text
;
5091 xsignal1 (Qcoding_system_error
, coding_system
);
5095 object
= make_buffer_string (b
, e
, 0);
5096 if (prev
!= current_buffer
)
5097 set_buffer_internal (prev
);
5098 /* Discard the unwind protect for recovering the current
5102 if (STRING_MULTIBYTE (object
))
5103 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5106 md5_buffer (SDATA (object
) + start_byte
,
5107 SBYTES (object
) - (size_byte
- end_byte
),
5110 for (i
= 0; i
< 16; i
++)
5111 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5114 return make_string (value
, 32);
5121 /* Hash table stuff. */
5122 Qhash_table_p
= intern_c_string ("hash-table-p");
5123 staticpro (&Qhash_table_p
);
5124 Qeq
= intern_c_string ("eq");
5126 Qeql
= intern_c_string ("eql");
5128 Qequal
= intern_c_string ("equal");
5129 staticpro (&Qequal
);
5130 QCtest
= intern_c_string (":test");
5131 staticpro (&QCtest
);
5132 QCsize
= intern_c_string (":size");
5133 staticpro (&QCsize
);
5134 QCrehash_size
= intern_c_string (":rehash-size");
5135 staticpro (&QCrehash_size
);
5136 QCrehash_threshold
= intern_c_string (":rehash-threshold");
5137 staticpro (&QCrehash_threshold
);
5138 QCweakness
= intern_c_string (":weakness");
5139 staticpro (&QCweakness
);
5140 Qkey
= intern_c_string ("key");
5142 Qvalue
= intern_c_string ("value");
5143 staticpro (&Qvalue
);
5144 Qhash_table_test
= intern_c_string ("hash-table-test");
5145 staticpro (&Qhash_table_test
);
5146 Qkey_or_value
= intern_c_string ("key-or-value");
5147 staticpro (&Qkey_or_value
);
5148 Qkey_and_value
= intern_c_string ("key-and-value");
5149 staticpro (&Qkey_and_value
);
5152 defsubr (&Smake_hash_table
);
5153 defsubr (&Scopy_hash_table
);
5154 defsubr (&Shash_table_count
);
5155 defsubr (&Shash_table_rehash_size
);
5156 defsubr (&Shash_table_rehash_threshold
);
5157 defsubr (&Shash_table_size
);
5158 defsubr (&Shash_table_test
);
5159 defsubr (&Shash_table_weakness
);
5160 defsubr (&Shash_table_p
);
5161 defsubr (&Sclrhash
);
5162 defsubr (&Sgethash
);
5163 defsubr (&Sputhash
);
5164 defsubr (&Sremhash
);
5165 defsubr (&Smaphash
);
5166 defsubr (&Sdefine_hash_table_test
);
5168 Qstring_lessp
= intern_c_string ("string-lessp");
5169 staticpro (&Qstring_lessp
);
5170 Qprovide
= intern_c_string ("provide");
5171 staticpro (&Qprovide
);
5172 Qrequire
= intern_c_string ("require");
5173 staticpro (&Qrequire
);
5174 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
5175 staticpro (&Qyes_or_no_p_history
);
5176 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
5177 staticpro (&Qcursor_in_echo_area
);
5178 Qwidget_type
= intern_c_string ("widget-type");
5179 staticpro (&Qwidget_type
);
5181 staticpro (&string_char_byte_cache_string
);
5182 string_char_byte_cache_string
= Qnil
;
5184 require_nesting_list
= Qnil
;
5185 staticpro (&require_nesting_list
);
5187 Fset (Qyes_or_no_p_history
, Qnil
);
5189 DEFVAR_LISP ("features", &Vfeatures
,
5190 doc
: /* A list of symbols which are the features of the executing Emacs.
5191 Used by `featurep' and `require', and altered by `provide'. */);
5192 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
5193 Qsubfeatures
= intern_c_string ("subfeatures");
5194 staticpro (&Qsubfeatures
);
5196 #ifdef HAVE_LANGINFO_CODESET
5197 Qcodeset
= intern_c_string ("codeset");
5198 staticpro (&Qcodeset
);
5199 Qdays
= intern_c_string ("days");
5201 Qmonths
= intern_c_string ("months");
5202 staticpro (&Qmonths
);
5203 Qpaper
= intern_c_string ("paper");
5204 staticpro (&Qpaper
);
5205 #endif /* HAVE_LANGINFO_CODESET */
5207 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5208 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5209 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5210 invoked by mouse clicks and mouse menu items.
5212 On some platforms, file selection dialogs are also enabled if this is
5216 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5217 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5218 This applies to commands from menus and tool bar buttons even when
5219 they are initiated from the keyboard. If `use-dialog-box' is nil,
5220 that disables the use of a file dialog, regardless of the value of
5222 use_file_dialog
= 1;
5224 defsubr (&Sidentity
);
5227 defsubr (&Ssafe_length
);
5228 defsubr (&Sstring_bytes
);
5229 defsubr (&Sstring_equal
);
5230 defsubr (&Scompare_strings
);
5231 defsubr (&Sstring_lessp
);
5234 defsubr (&Svconcat
);
5235 defsubr (&Scopy_sequence
);
5236 defsubr (&Sstring_make_multibyte
);
5237 defsubr (&Sstring_make_unibyte
);
5238 defsubr (&Sstring_as_multibyte
);
5239 defsubr (&Sstring_as_unibyte
);
5240 defsubr (&Sstring_to_multibyte
);
5241 defsubr (&Sstring_to_unibyte
);
5242 defsubr (&Scopy_alist
);
5243 defsubr (&Ssubstring
);
5244 defsubr (&Ssubstring_no_properties
);
5257 defsubr (&Snreverse
);
5258 defsubr (&Sreverse
);
5260 defsubr (&Splist_get
);
5262 defsubr (&Splist_put
);
5264 defsubr (&Slax_plist_get
);
5265 defsubr (&Slax_plist_put
);
5268 defsubr (&Sequal_including_properties
);
5269 defsubr (&Sfillarray
);
5270 defsubr (&Sclear_string
);
5274 defsubr (&Smapconcat
);
5275 defsubr (&Sy_or_n_p
);
5276 defsubr (&Syes_or_no_p
);
5277 defsubr (&Sload_average
);
5278 defsubr (&Sfeaturep
);
5279 defsubr (&Srequire
);
5280 defsubr (&Sprovide
);
5281 defsubr (&Splist_member
);
5282 defsubr (&Swidget_put
);
5283 defsubr (&Swidget_get
);
5284 defsubr (&Swidget_apply
);
5285 defsubr (&Sbase64_encode_region
);
5286 defsubr (&Sbase64_decode_region
);
5287 defsubr (&Sbase64_encode_string
);
5288 defsubr (&Sbase64_decode_string
);
5290 defsubr (&Slocale_info
);
5299 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5300 (do not change this comment) */