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 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
29 /* On Mac OS, defining this conflicts with precompiled headers. */
31 /* Note on some machines this defines `vector' as a typedef,
32 so make sure we don't use that name in this file. */
36 #endif /* ! MAC_OSX */
40 #include "character.h"
45 #include "intervals.h"
48 #include "blockinput.h"
50 #if defined (HAVE_X_WINDOWS)
52 #elif defined (MAC_OS)
58 #define NULL ((POINTER_TYPE *)0)
61 /* Nonzero enables use of dialog boxes for questions
62 asked by mouse commands. */
65 /* Nonzero enables use of a file dialog for file name
66 questions asked by mouse commands. */
69 extern int minibuffer_auto_raise
;
70 extern Lisp_Object minibuf_window
;
71 extern Lisp_Object Vlocale_coding_system
;
72 extern int load_in_progress
;
74 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
75 Lisp_Object Qyes_or_no_p_history
;
76 Lisp_Object Qcursor_in_echo_area
;
77 Lisp_Object Qwidget_type
;
78 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
80 extern Lisp_Object Qinput_method_function
;
82 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
84 extern long get_random ();
85 extern void seed_random
P_ ((long));
91 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
92 doc
: /* Return the argument unchanged. */)
99 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
100 doc
: /* Return a pseudo-random number.
101 All integers representable in Lisp are equally likely.
102 On most systems, this is 29 bits' worth.
103 With positive integer argument N, return random number in interval [0,N).
104 With argument t, set the random number seed from the current time and pid. */)
109 Lisp_Object lispy_val
;
110 unsigned long denominator
;
113 seed_random (getpid () + time (NULL
));
114 if (NATNUMP (n
) && XFASTINT (n
) != 0)
116 /* Try to take our random number from the higher bits of VAL,
117 not the lower, since (says Gentzel) the low bits of `random'
118 are less random than the higher ones. We do this by using the
119 quotient rather than the remainder. At the high end of the RNG
120 it's possible to get a quotient larger than n; discarding
121 these values eliminates the bias that would otherwise appear
122 when using a large n. */
123 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
125 val
= get_random () / denominator
;
126 while (val
>= XFASTINT (n
));
130 XSETINT (lispy_val
, val
);
134 /* Random data-structure functions */
136 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
137 doc
: /* Return the length of vector, list or string SEQUENCE.
138 A byte-code function object is also allowed.
139 If the string contains multibyte characters, this is not necessarily
140 the number of bytes in the string; it is the number of characters.
141 To get the number of bytes, use `string-bytes'. */)
143 register Lisp_Object sequence
;
145 register Lisp_Object val
;
148 if (STRINGP (sequence
))
149 XSETFASTINT (val
, SCHARS (sequence
));
150 else if (VECTORP (sequence
))
151 XSETFASTINT (val
, ASIZE (sequence
));
152 else if (CHAR_TABLE_P (sequence
))
153 XSETFASTINT (val
, MAX_CHAR
);
154 else if (BOOL_VECTOR_P (sequence
))
155 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
156 else if (COMPILEDP (sequence
))
157 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
158 else if (CONSP (sequence
))
161 while (CONSP (sequence
))
163 sequence
= XCDR (sequence
);
166 if (!CONSP (sequence
))
169 sequence
= XCDR (sequence
);
174 CHECK_LIST_END (sequence
, sequence
);
176 val
= make_number (i
);
178 else if (NILP (sequence
))
179 XSETFASTINT (val
, 0);
181 wrong_type_argument (Qsequencep
, sequence
);
186 /* This does not check for quits. That is safe since it must terminate. */
188 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
189 doc
: /* Return the length of a list, but avoid error or infinite loop.
190 This function never gets an error. If LIST is not really a list,
191 it returns 0. If LIST is circular, it returns a finite value
192 which is at least the number of distinct elements. */)
196 Lisp_Object tail
, halftail
, length
;
199 /* halftail is used to detect circular lists. */
201 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
203 if (EQ (tail
, halftail
) && len
!= 0)
207 halftail
= XCDR (halftail
);
210 XSETINT (length
, len
);
214 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
215 doc
: /* Return the number of bytes in STRING.
216 If STRING is multibyte, this may be greater than the length of STRING. */)
220 CHECK_STRING (string
);
221 return make_number (SBYTES (string
));
224 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
225 doc
: /* Return t if two strings have identical contents.
226 Case is significant, but text properties are ignored.
227 Symbols are also allowed; their print names are used instead. */)
229 register Lisp_Object s1
, s2
;
232 s1
= SYMBOL_NAME (s1
);
234 s2
= SYMBOL_NAME (s2
);
238 if (SCHARS (s1
) != SCHARS (s2
)
239 || SBYTES (s1
) != SBYTES (s2
)
240 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
245 DEFUN ("compare-strings", Fcompare_strings
,
246 Scompare_strings
, 6, 7, 0,
247 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
248 In string STR1, skip the first START1 characters and stop at END1.
249 In string STR2, skip the first START2 characters and stop at END2.
250 END1 and END2 default to the full lengths of the respective strings.
252 Case is significant in this comparison if IGNORE-CASE is nil.
253 Unibyte strings are converted to multibyte for comparison.
255 The value is t if the strings (or specified portions) match.
256 If string STR1 is less, the value is a negative number N;
257 - 1 - N is the number of characters that match at the beginning.
258 If string STR1 is greater, the value is a positive number N;
259 N - 1 is the number of characters that match at the beginning. */)
260 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
261 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
263 register int end1_char
, end2_char
;
264 register int i1
, i1_byte
, i2
, i2_byte
;
269 start1
= make_number (0);
271 start2
= make_number (0);
272 CHECK_NATNUM (start1
);
273 CHECK_NATNUM (start2
);
282 i1_byte
= string_char_to_byte (str1
, i1
);
283 i2_byte
= string_char_to_byte (str2
, i2
);
285 end1_char
= SCHARS (str1
);
286 if (! NILP (end1
) && end1_char
> XINT (end1
))
287 end1_char
= XINT (end1
);
289 end2_char
= SCHARS (str2
);
290 if (! NILP (end2
) && end2_char
> XINT (end2
))
291 end2_char
= XINT (end2
);
293 while (i1
< end1_char
&& i2
< end2_char
)
295 /* When we find a mismatch, we must compare the
296 characters, not just the bytes. */
299 if (STRING_MULTIBYTE (str1
))
300 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
303 c1
= SREF (str1
, i1
++);
304 c1
= unibyte_char_to_multibyte (c1
);
307 if (STRING_MULTIBYTE (str2
))
308 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
311 c2
= SREF (str2
, i2
++);
312 c2
= unibyte_char_to_multibyte (c2
);
318 if (! NILP (ignore_case
))
322 tem
= Fupcase (make_number (c1
));
324 tem
= Fupcase (make_number (c2
));
331 /* Note that I1 has already been incremented
332 past the character that we are comparing;
333 hence we don't add or subtract 1 here. */
335 return make_number (- i1
+ XINT (start1
));
337 return make_number (i1
- XINT (start1
));
341 return make_number (i1
- XINT (start1
) + 1);
343 return make_number (- i1
+ XINT (start1
) - 1);
348 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
349 doc
: /* Return t if first arg string is less than second in lexicographic order.
351 Symbols are also allowed; their print names are used instead. */)
353 register Lisp_Object s1
, s2
;
356 register int i1
, i1_byte
, i2
, i2_byte
;
359 s1
= SYMBOL_NAME (s1
);
361 s2
= SYMBOL_NAME (s2
);
365 i1
= i1_byte
= i2
= i2_byte
= 0;
368 if (end
> SCHARS (s2
))
373 /* When we find a mismatch, we must compare the
374 characters, not just the bytes. */
377 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
378 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
381 return c1
< c2
? Qt
: Qnil
;
383 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
387 /* "gcc -O3" enables automatic function inlining, which optimizes out
388 the arguments for the invocations of this function, whereas it
389 expects these values on the stack. */
390 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
391 #else /* !__GNUC__ */
392 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
404 return concat (2, args
, Lisp_String
, 0);
406 return concat (2, &s1
, Lisp_String
, 0);
407 #endif /* NO_ARG_ARRAY */
413 Lisp_Object s1
, s2
, s3
;
420 return concat (3, args
, Lisp_String
, 0);
422 return concat (3, &s1
, Lisp_String
, 0);
423 #endif /* NO_ARG_ARRAY */
426 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
427 doc
: /* Concatenate all the arguments and make the result a list.
428 The result is a list whose elements are the elements of all the arguments.
429 Each argument may be a list, vector or string.
430 The last argument is not copied, just used as the tail of the new list.
431 usage: (append &rest SEQUENCES) */)
436 return concat (nargs
, args
, Lisp_Cons
, 1);
439 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
440 doc
: /* Concatenate all the arguments and make the result a string.
441 The result is a string whose elements are the elements of all the arguments.
442 Each argument may be a string or a list or vector of characters (integers).
443 usage: (concat &rest SEQUENCES) */)
448 return concat (nargs
, args
, Lisp_String
, 0);
451 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
452 doc
: /* Concatenate all the arguments and make the result a vector.
453 The result is a vector whose elements are the elements of all the arguments.
454 Each argument may be a list, vector or string.
455 usage: (vconcat &rest SEQUENCES) */)
460 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
464 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
465 doc
: /* Return a copy of a list, vector, string or char-table.
466 The elements of a list or vector are not copied; they are shared
467 with the original. */)
471 if (NILP (arg
)) return arg
;
473 if (CHAR_TABLE_P (arg
))
475 return copy_char_table (arg
);
478 if (BOOL_VECTOR_P (arg
))
482 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
483 / BOOL_VECTOR_BITS_PER_CHAR
);
485 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
486 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
491 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
492 wrong_type_argument (Qsequencep
, arg
);
494 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
497 /* This structure holds information of an argument of `concat' that is
498 a string and has text properties to be copied. */
501 int argnum
; /* refer to ARGS (arguments of `concat') */
502 int from
; /* refer to ARGS[argnum] (argument string) */
503 int to
; /* refer to VAL (the target string) */
507 concat (nargs
, args
, target_type
, last_special
)
510 enum Lisp_Type target_type
;
514 register Lisp_Object tail
;
515 register Lisp_Object
this;
517 int toindex_byte
= 0;
518 register int result_len
;
519 register int result_len_byte
;
521 Lisp_Object last_tail
;
524 /* When we make a multibyte string, we can't copy text properties
525 while concatinating each string because the length of resulting
526 string can't be decided until we finish the whole concatination.
527 So, we record strings that have text properties to be copied
528 here, and copy the text properties after the concatination. */
529 struct textprop_rec
*textprops
= NULL
;
530 /* Number of elments in textprops. */
531 int num_textprops
= 0;
536 /* In append, the last arg isn't treated like the others */
537 if (last_special
&& nargs
> 0)
540 last_tail
= args
[nargs
];
545 /* Check each argument. */
546 for (argnum
= 0; argnum
< nargs
; argnum
++)
549 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
550 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
551 wrong_type_argument (Qsequencep
, this);
554 /* Compute total length in chars of arguments in RESULT_LEN.
555 If desired output is a string, also compute length in bytes
556 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
557 whether the result should be a multibyte string. */
561 for (argnum
= 0; argnum
< nargs
; argnum
++)
565 len
= XFASTINT (Flength (this));
566 if (target_type
== Lisp_String
)
568 /* We must count the number of bytes needed in the string
569 as well as the number of characters. */
575 for (i
= 0; i
< len
; i
++)
578 CHECK_CHARACTER (ch
);
579 this_len_byte
= CHAR_BYTES (XINT (ch
));
580 result_len_byte
+= this_len_byte
;
581 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
584 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
585 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
586 else if (CONSP (this))
587 for (; CONSP (this); this = XCDR (this))
590 CHECK_CHARACTER (ch
);
591 this_len_byte
= CHAR_BYTES (XINT (ch
));
592 result_len_byte
+= this_len_byte
;
593 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
596 else if (STRINGP (this))
598 if (STRING_MULTIBYTE (this))
601 result_len_byte
+= SBYTES (this);
604 result_len_byte
+= count_size_as_multibyte (SDATA (this),
612 if (! some_multibyte
)
613 result_len_byte
= result_len
;
615 /* Create the output object. */
616 if (target_type
== Lisp_Cons
)
617 val
= Fmake_list (make_number (result_len
), Qnil
);
618 else if (target_type
== Lisp_Vectorlike
)
619 val
= Fmake_vector (make_number (result_len
), Qnil
);
620 else if (some_multibyte
)
621 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
623 val
= make_uninit_string (result_len
);
625 /* In `append', if all but last arg are nil, return last arg. */
626 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
629 /* Copy the contents of the args into the result. */
631 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
633 toindex
= 0, toindex_byte
= 0;
637 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
639 for (argnum
= 0; argnum
< nargs
; argnum
++)
643 register unsigned int thisindex
= 0;
644 register unsigned int thisindex_byte
= 0;
648 thislen
= Flength (this), thisleni
= XINT (thislen
);
650 /* Between strings of the same kind, copy fast. */
651 if (STRINGP (this) && STRINGP (val
)
652 && STRING_MULTIBYTE (this) == some_multibyte
)
654 int thislen_byte
= SBYTES (this);
656 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
658 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
660 textprops
[num_textprops
].argnum
= argnum
;
661 textprops
[num_textprops
].from
= 0;
662 textprops
[num_textprops
++].to
= toindex
;
664 toindex_byte
+= thislen_byte
;
666 STRING_SET_CHARS (val
, SCHARS (val
));
668 /* Copy a single-byte string to a multibyte string. */
669 else if (STRINGP (this) && STRINGP (val
))
671 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
673 textprops
[num_textprops
].argnum
= argnum
;
674 textprops
[num_textprops
].from
= 0;
675 textprops
[num_textprops
++].to
= toindex
;
677 toindex_byte
+= copy_text (SDATA (this),
678 SDATA (val
) + toindex_byte
,
679 SCHARS (this), 0, 1);
683 /* Copy element by element. */
686 register Lisp_Object elt
;
688 /* Fetch next element of `this' arg into `elt', or break if
689 `this' is exhausted. */
690 if (NILP (this)) break;
692 elt
= XCAR (this), this = XCDR (this);
693 else if (thisindex
>= thisleni
)
695 else if (STRINGP (this))
698 if (STRING_MULTIBYTE (this))
700 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
703 XSETFASTINT (elt
, c
);
707 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
709 && XINT (elt
) >= 0200
710 && XINT (elt
) < 0400)
712 c
= unibyte_char_to_multibyte (XINT (elt
));
717 else if (BOOL_VECTOR_P (this))
720 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
721 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
729 elt
= AREF (this, thisindex
);
733 /* Store this element into the result. */
740 else if (VECTORP (val
))
742 ASET (val
, toindex
, elt
);
749 toindex_byte
+= CHAR_STRING (XINT (elt
),
750 SDATA (val
) + toindex_byte
);
752 SSET (val
, toindex_byte
++, XINT (elt
));
758 XSETCDR (prev
, last_tail
);
760 if (num_textprops
> 0)
763 int last_to_end
= -1;
765 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
767 this = args
[textprops
[argnum
].argnum
];
768 props
= text_property_list (this,
770 make_number (SCHARS (this)),
772 /* If successive arguments have properites, be sure that the
773 value of `composition' property be the copy. */
774 if (last_to_end
== textprops
[argnum
].to
)
775 make_composition_value_copy (props
);
776 add_text_properties_from_list (val
, props
,
777 make_number (textprops
[argnum
].to
));
778 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
786 static Lisp_Object string_char_byte_cache_string
;
787 static EMACS_INT string_char_byte_cache_charpos
;
788 static EMACS_INT string_char_byte_cache_bytepos
;
791 clear_string_char_byte_cache ()
793 string_char_byte_cache_string
= Qnil
;
796 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
799 string_char_to_byte (string
, char_index
)
801 EMACS_INT char_index
;
804 EMACS_INT best_below
, best_below_byte
;
805 EMACS_INT best_above
, best_above_byte
;
807 best_below
= best_below_byte
= 0;
808 best_above
= SCHARS (string
);
809 best_above_byte
= SBYTES (string
);
810 if (best_above
== best_above_byte
)
813 if (EQ (string
, string_char_byte_cache_string
))
815 if (string_char_byte_cache_charpos
< char_index
)
817 best_below
= string_char_byte_cache_charpos
;
818 best_below_byte
= string_char_byte_cache_bytepos
;
822 best_above
= string_char_byte_cache_charpos
;
823 best_above_byte
= string_char_byte_cache_bytepos
;
827 if (char_index
- best_below
< best_above
- char_index
)
829 unsigned char *p
= SDATA (string
) + best_below_byte
;
831 while (best_below
< char_index
)
833 p
+= BYTES_BY_CHAR_HEAD (*p
);
836 i_byte
= p
- SDATA (string
);
840 unsigned char *p
= SDATA (string
) + best_above_byte
;
842 while (best_above
> char_index
)
845 while (!CHAR_HEAD_P (*p
)) p
--;
848 i_byte
= p
- SDATA (string
);
851 string_char_byte_cache_bytepos
= i_byte
;
852 string_char_byte_cache_charpos
= char_index
;
853 string_char_byte_cache_string
= string
;
858 /* Return the character index corresponding to BYTE_INDEX in STRING. */
861 string_byte_to_char (string
, byte_index
)
863 EMACS_INT byte_index
;
866 EMACS_INT best_below
, best_below_byte
;
867 EMACS_INT best_above
, best_above_byte
;
869 best_below
= best_below_byte
= 0;
870 best_above
= SCHARS (string
);
871 best_above_byte
= SBYTES (string
);
872 if (best_above
== best_above_byte
)
875 if (EQ (string
, string_char_byte_cache_string
))
877 if (string_char_byte_cache_bytepos
< byte_index
)
879 best_below
= string_char_byte_cache_charpos
;
880 best_below_byte
= string_char_byte_cache_bytepos
;
884 best_above
= string_char_byte_cache_charpos
;
885 best_above_byte
= string_char_byte_cache_bytepos
;
889 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
891 unsigned char *p
= SDATA (string
) + best_below_byte
;
892 unsigned char *pend
= SDATA (string
) + byte_index
;
896 p
+= BYTES_BY_CHAR_HEAD (*p
);
900 i_byte
= p
- SDATA (string
);
904 unsigned char *p
= SDATA (string
) + best_above_byte
;
905 unsigned char *pbeg
= SDATA (string
) + byte_index
;
910 while (!CHAR_HEAD_P (*p
)) p
--;
914 i_byte
= p
- SDATA (string
);
917 string_char_byte_cache_bytepos
= i_byte
;
918 string_char_byte_cache_charpos
= i
;
919 string_char_byte_cache_string
= string
;
924 /* Convert STRING to a multibyte string. */
927 string_make_multibyte (string
)
935 if (STRING_MULTIBYTE (string
))
938 nbytes
= count_size_as_multibyte (SDATA (string
),
940 /* If all the chars are ASCII, they won't need any more bytes
941 once converted. In that case, we can return STRING itself. */
942 if (nbytes
== SBYTES (string
))
945 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
946 copy_text (SDATA (string
), buf
, SBYTES (string
),
949 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
956 /* Convert STRING (if unibyte) to a multibyte string without changing
957 the number of characters. Characters 0200 trough 0237 are
958 converted to eight-bit characters. */
961 string_to_multibyte (string
)
969 if (STRING_MULTIBYTE (string
))
972 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
973 /* If all the chars are ASCII, they won't need any more bytes once
975 if (nbytes
== SBYTES (string
))
976 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
978 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
979 bcopy (SDATA (string
), buf
, SBYTES (string
));
980 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
982 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
989 /* Convert STRING to a single-byte string. */
992 string_make_unibyte (string
)
1000 if (! STRING_MULTIBYTE (string
))
1003 nchars
= SCHARS (string
);
1005 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1006 copy_text (SDATA (string
), buf
, SBYTES (string
),
1009 ret
= make_unibyte_string (buf
, nchars
);
1015 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1017 doc
: /* Return the multibyte equivalent of STRING.
1018 If STRING is unibyte and contains non-ASCII characters, the function
1019 `unibyte-char-to-multibyte' is used to convert each unibyte character
1020 to a multibyte character. In this case, the returned string is a
1021 newly created string with no text properties. If STRING is multibyte
1022 or entirely ASCII, it is returned unchanged. In particular, when
1023 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1024 \(When the characters are all ASCII, Emacs primitives will treat the
1025 string the same way whether it is unibyte or multibyte.) */)
1029 CHECK_STRING (string
);
1031 return string_make_multibyte (string
);
1034 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1036 doc
: /* Return the unibyte equivalent of STRING.
1037 Multibyte character codes are converted to unibyte according to
1038 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1039 If the lookup in the translation table fails, this function takes just
1040 the low 8 bits of each character. */)
1044 CHECK_STRING (string
);
1046 return string_make_unibyte (string
);
1049 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1051 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1052 If STRING is unibyte, the result is STRING itself.
1053 Otherwise it is a newly created string, with no text properties.
1054 If STRING is multibyte and contains a character of charset
1055 `eight-bit', it is converted to the corresponding single byte. */)
1059 CHECK_STRING (string
);
1061 if (STRING_MULTIBYTE (string
))
1063 int bytes
= SBYTES (string
);
1064 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1066 bcopy (SDATA (string
), str
, bytes
);
1067 bytes
= str_as_unibyte (str
, bytes
);
1068 string
= make_unibyte_string (str
, bytes
);
1074 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1076 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1077 If STRING is multibyte, the result is STRING itself.
1078 Otherwise it is a newly created string, with no text properties.
1080 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1081 part of a correct utf-8 sequence), it is converted to the corresponding
1082 multibyte character of charset `eight-bit'.
1083 See also `string-to-multibyte'.
1085 Beware, this often doesn't really do what you think it does.
1086 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1087 If you're not sure, whether to use `string-as-multibyte' or
1088 `string-to-multibyte', use `string-to-multibyte'. */)
1092 CHECK_STRING (string
);
1094 if (! STRING_MULTIBYTE (string
))
1096 Lisp_Object new_string
;
1099 parse_str_as_multibyte (SDATA (string
),
1102 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1103 bcopy (SDATA (string
), SDATA (new_string
),
1105 if (nbytes
!= SBYTES (string
))
1106 str_as_multibyte (SDATA (new_string
), nbytes
,
1107 SBYTES (string
), NULL
);
1108 string
= new_string
;
1109 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1114 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1116 doc
: /* Return a multibyte string with the same individual chars as STRING.
1117 If STRING is multibyte, the result is STRING itself.
1118 Otherwise it is a newly created string, with no text properties.
1120 If STRING is unibyte and contains an 8-bit byte, it is converted to
1121 the corresponding multibyte character of charset `eight-bit'.
1123 This differs from `string-as-multibyte' by converting each byte of a correct
1124 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1125 correct sequence. */)
1129 CHECK_STRING (string
);
1131 return string_to_multibyte (string
);
1134 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1136 doc
: /* Return a unibyte string with the same individual chars as STRING.
1137 If STRING is unibyte, the result is STRING itself.
1138 Otherwise it is a newly created string, with no text properties,
1139 where each `eight-bit' character is converted to the corresponding byte.
1140 If STRING contains a non-ASCII, non-`eight-bit' character,
1141 an error is signaled. */)
1145 CHECK_STRING (string
);
1147 if (STRING_MULTIBYTE (string
))
1149 EMACS_INT chars
= SCHARS (string
);
1150 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1151 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1153 if (converted
< chars
)
1154 error ("Can't convert the %dth character to unibyte", converted
);
1155 string
= make_unibyte_string (str
, chars
);
1162 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1163 doc
: /* Return a copy of ALIST.
1164 This is an alist which represents the same mapping from objects to objects,
1165 but does not share the alist structure with ALIST.
1166 The objects mapped (cars and cdrs of elements of the alist)
1167 are shared, however.
1168 Elements of ALIST that are not conses are also shared. */)
1172 register Lisp_Object tem
;
1177 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1178 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1180 register Lisp_Object car
;
1184 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1189 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1190 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1191 TO may be nil or omitted; then the substring runs to the end of STRING.
1192 FROM and TO start at 0. If either is negative, it counts from the end.
1194 This function allows vectors as well as strings. */)
1197 register Lisp_Object from
, to
;
1202 int from_char
, to_char
;
1203 int from_byte
= 0, to_byte
= 0;
1205 CHECK_VECTOR_OR_STRING (string
);
1206 CHECK_NUMBER (from
);
1208 if (STRINGP (string
))
1210 size
= SCHARS (string
);
1211 size_byte
= SBYTES (string
);
1214 size
= ASIZE (string
);
1219 to_byte
= size_byte
;
1225 to_char
= XINT (to
);
1229 if (STRINGP (string
))
1230 to_byte
= string_char_to_byte (string
, to_char
);
1233 from_char
= XINT (from
);
1236 if (STRINGP (string
))
1237 from_byte
= string_char_to_byte (string
, from_char
);
1239 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1240 args_out_of_range_3 (string
, make_number (from_char
),
1241 make_number (to_char
));
1243 if (STRINGP (string
))
1245 res
= make_specified_string (SDATA (string
) + from_byte
,
1246 to_char
- from_char
, to_byte
- from_byte
,
1247 STRING_MULTIBYTE (string
));
1248 copy_text_properties (make_number (from_char
), make_number (to_char
),
1249 string
, make_number (0), res
, Qnil
);
1252 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1258 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1259 doc
: /* Return a substring of STRING, without text properties.
1260 It starts at index FROM and ending before TO.
1261 TO may be nil or omitted; then the substring runs to the end of STRING.
1262 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1263 If FROM or TO is negative, it counts from the end.
1265 With one argument, just copy STRING without its properties. */)
1268 register Lisp_Object from
, to
;
1270 int size
, size_byte
;
1271 int from_char
, to_char
;
1272 int from_byte
, to_byte
;
1274 CHECK_STRING (string
);
1276 size
= SCHARS (string
);
1277 size_byte
= SBYTES (string
);
1280 from_char
= from_byte
= 0;
1283 CHECK_NUMBER (from
);
1284 from_char
= XINT (from
);
1288 from_byte
= string_char_to_byte (string
, from_char
);
1294 to_byte
= size_byte
;
1300 to_char
= XINT (to
);
1304 to_byte
= string_char_to_byte (string
, to_char
);
1307 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1308 args_out_of_range_3 (string
, make_number (from_char
),
1309 make_number (to_char
));
1311 return make_specified_string (SDATA (string
) + from_byte
,
1312 to_char
- from_char
, to_byte
- from_byte
,
1313 STRING_MULTIBYTE (string
));
1316 /* Extract a substring of STRING, giving start and end positions
1317 both in characters and in bytes. */
1320 substring_both (string
, from
, from_byte
, to
, to_byte
)
1322 int from
, from_byte
, to
, to_byte
;
1328 CHECK_VECTOR_OR_STRING (string
);
1330 if (STRINGP (string
))
1332 size
= SCHARS (string
);
1333 size_byte
= SBYTES (string
);
1336 size
= ASIZE (string
);
1338 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1339 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1341 if (STRINGP (string
))
1343 res
= make_specified_string (SDATA (string
) + from_byte
,
1344 to
- from
, to_byte
- from_byte
,
1345 STRING_MULTIBYTE (string
));
1346 copy_text_properties (make_number (from
), make_number (to
),
1347 string
, make_number (0), res
, Qnil
);
1350 res
= Fvector (to
- from
, &AREF (string
, from
));
1355 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1356 doc
: /* Take cdr N times on LIST, returns the result. */)
1359 register Lisp_Object list
;
1361 register int i
, num
;
1364 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1367 CHECK_LIST_CONS (list
, list
);
1373 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1374 doc
: /* Return the Nth element of LIST.
1375 N counts from zero. If LIST is not that long, nil is returned. */)
1377 Lisp_Object n
, list
;
1379 return Fcar (Fnthcdr (n
, list
));
1382 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1383 doc
: /* Return element of SEQUENCE at index N. */)
1385 register Lisp_Object sequence
, n
;
1388 if (CONSP (sequence
) || NILP (sequence
))
1389 return Fcar (Fnthcdr (n
, sequence
));
1391 /* Faref signals a "not array" error, so check here. */
1392 CHECK_ARRAY (sequence
, Qsequencep
);
1393 return Faref (sequence
, n
);
1396 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1397 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1398 The value is actually the tail of LIST whose car is ELT. */)
1400 register Lisp_Object elt
;
1403 register Lisp_Object tail
;
1404 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1406 register Lisp_Object tem
;
1407 CHECK_LIST_CONS (tail
, list
);
1409 if (! NILP (Fequal (elt
, tem
)))
1416 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1417 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1418 The value is actually the tail of LIST whose car is ELT. */)
1420 register Lisp_Object elt
, list
;
1424 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1428 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1432 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1443 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1444 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1445 The value is actually the tail of LIST whose car is ELT. */)
1447 register Lisp_Object elt
;
1450 register Lisp_Object tail
;
1453 return Fmemq (elt
, list
);
1455 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1457 register Lisp_Object tem
;
1458 CHECK_LIST_CONS (tail
, list
);
1460 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1467 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1468 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1469 The value is actually the first element of LIST whose car is KEY.
1470 Elements of LIST that are not conses are ignored. */)
1472 Lisp_Object key
, list
;
1477 || (CONSP (XCAR (list
))
1478 && EQ (XCAR (XCAR (list
)), key
)))
1483 || (CONSP (XCAR (list
))
1484 && EQ (XCAR (XCAR (list
)), key
)))
1489 || (CONSP (XCAR (list
))
1490 && EQ (XCAR (XCAR (list
)), key
)))
1500 /* Like Fassq but never report an error and do not allow quits.
1501 Use only on lists known never to be circular. */
1504 assq_no_quit (key
, list
)
1505 Lisp_Object key
, list
;
1508 && (!CONSP (XCAR (list
))
1509 || !EQ (XCAR (XCAR (list
)), key
)))
1512 return CAR_SAFE (list
);
1515 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1516 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1517 The value is actually the first element of LIST whose car equals KEY. */)
1519 Lisp_Object key
, list
;
1526 || (CONSP (XCAR (list
))
1527 && (car
= XCAR (XCAR (list
)),
1528 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1533 || (CONSP (XCAR (list
))
1534 && (car
= XCAR (XCAR (list
)),
1535 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1540 || (CONSP (XCAR (list
))
1541 && (car
= XCAR (XCAR (list
)),
1542 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1552 /* Like Fassoc but never report an error and do not allow quits.
1553 Use only on lists known never to be circular. */
1556 assoc_no_quit (key
, list
)
1557 Lisp_Object key
, list
;
1560 && (!CONSP (XCAR (list
))
1561 || (!EQ (XCAR (XCAR (list
)), key
)
1562 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1565 return CONSP (list
) ? XCAR (list
) : Qnil
;
1568 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1569 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1570 The value is actually the first element of LIST whose cdr is KEY. */)
1572 register Lisp_Object key
;
1578 || (CONSP (XCAR (list
))
1579 && EQ (XCDR (XCAR (list
)), key
)))
1584 || (CONSP (XCAR (list
))
1585 && EQ (XCDR (XCAR (list
)), key
)))
1590 || (CONSP (XCAR (list
))
1591 && EQ (XCDR (XCAR (list
)), key
)))
1601 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1602 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1603 The value is actually the first element of LIST whose cdr equals KEY. */)
1605 Lisp_Object key
, list
;
1612 || (CONSP (XCAR (list
))
1613 && (cdr
= XCDR (XCAR (list
)),
1614 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1619 || (CONSP (XCAR (list
))
1620 && (cdr
= XCDR (XCAR (list
)),
1621 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1626 || (CONSP (XCAR (list
))
1627 && (cdr
= XCDR (XCAR (list
)),
1628 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1638 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1639 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1640 The modified LIST is returned. Comparison is done with `eq'.
1641 If the first member of LIST is ELT, there is no way to remove it by side effect;
1642 therefore, write `(setq foo (delq element foo))'
1643 to be sure of changing the value of `foo'. */)
1645 register Lisp_Object elt
;
1648 register Lisp_Object tail
, prev
;
1649 register Lisp_Object tem
;
1653 while (!NILP (tail
))
1655 CHECK_LIST_CONS (tail
, list
);
1662 Fsetcdr (prev
, XCDR (tail
));
1672 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1673 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1674 SEQ must be a list, a vector, or a string.
1675 The modified SEQ is returned. Comparison is done with `equal'.
1676 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1677 is not a side effect; it is simply using a different sequence.
1678 Therefore, write `(setq foo (delete element foo))'
1679 to be sure of changing the value of `foo'. */)
1681 Lisp_Object elt
, seq
;
1687 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1688 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1691 if (n
!= ASIZE (seq
))
1693 struct Lisp_Vector
*p
= allocate_vector (n
);
1695 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1696 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1697 p
->contents
[n
++] = AREF (seq
, i
);
1699 XSETVECTOR (seq
, p
);
1702 else if (STRINGP (seq
))
1704 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1707 for (i
= nchars
= nbytes
= ibyte
= 0;
1709 ++i
, ibyte
+= cbytes
)
1711 if (STRING_MULTIBYTE (seq
))
1713 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1714 SBYTES (seq
) - ibyte
);
1715 cbytes
= CHAR_BYTES (c
);
1723 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1730 if (nchars
!= SCHARS (seq
))
1734 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1735 if (!STRING_MULTIBYTE (seq
))
1736 STRING_SET_UNIBYTE (tem
);
1738 for (i
= nchars
= nbytes
= ibyte
= 0;
1740 ++i
, ibyte
+= cbytes
)
1742 if (STRING_MULTIBYTE (seq
))
1744 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1745 SBYTES (seq
) - ibyte
);
1746 cbytes
= CHAR_BYTES (c
);
1754 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1756 unsigned char *from
= SDATA (seq
) + ibyte
;
1757 unsigned char *to
= SDATA (tem
) + nbytes
;
1763 for (n
= cbytes
; n
--; )
1773 Lisp_Object tail
, prev
;
1775 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1777 CHECK_LIST_CONS (tail
, seq
);
1779 if (!NILP (Fequal (elt
, XCAR (tail
))))
1784 Fsetcdr (prev
, XCDR (tail
));
1795 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1796 doc
: /* Reverse LIST by modifying cdr pointers.
1797 Return the reversed list. */)
1801 register Lisp_Object prev
, tail
, next
;
1803 if (NILP (list
)) return list
;
1806 while (!NILP (tail
))
1809 CHECK_LIST_CONS (tail
, list
);
1811 Fsetcdr (tail
, prev
);
1818 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1819 doc
: /* Reverse LIST, copying. Return the reversed list.
1820 See also the function `nreverse', which is used more often. */)
1826 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1829 new = Fcons (XCAR (list
), new);
1831 CHECK_LIST_END (list
, list
);
1835 Lisp_Object
merge ();
1837 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1838 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1839 Returns the sorted list. LIST is modified by side effects.
1840 PREDICATE is called with two elements of LIST, and should return non-nil
1841 if the first element should sort before the second. */)
1843 Lisp_Object list
, predicate
;
1845 Lisp_Object front
, back
;
1846 register Lisp_Object len
, tem
;
1847 struct gcpro gcpro1
, gcpro2
;
1848 register int length
;
1851 len
= Flength (list
);
1852 length
= XINT (len
);
1856 XSETINT (len
, (length
/ 2) - 1);
1857 tem
= Fnthcdr (len
, list
);
1859 Fsetcdr (tem
, Qnil
);
1861 GCPRO2 (front
, back
);
1862 front
= Fsort (front
, predicate
);
1863 back
= Fsort (back
, predicate
);
1865 return merge (front
, back
, predicate
);
1869 merge (org_l1
, org_l2
, pred
)
1870 Lisp_Object org_l1
, org_l2
;
1874 register Lisp_Object tail
;
1876 register Lisp_Object l1
, l2
;
1877 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1884 /* It is sufficient to protect org_l1 and org_l2.
1885 When l1 and l2 are updated, we copy the new values
1886 back into the org_ vars. */
1887 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1907 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1923 Fsetcdr (tail
, tem
);
1929 #if 0 /* Unsafe version. */
1930 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1931 doc
: /* Extract a value from a property list.
1932 PLIST is a property list, which is a list of the form
1933 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1934 corresponding to the given PROP, or nil if PROP is not
1935 one of the properties on the list. */)
1943 CONSP (tail
) && CONSP (XCDR (tail
));
1944 tail
= XCDR (XCDR (tail
)))
1946 if (EQ (prop
, XCAR (tail
)))
1947 return XCAR (XCDR (tail
));
1949 /* This function can be called asynchronously
1950 (setup_coding_system). Don't QUIT in that case. */
1951 if (!interrupt_input_blocked
)
1955 CHECK_LIST_END (tail
, prop
);
1961 /* This does not check for quits. That is safe since it must terminate. */
1963 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1964 doc
: /* Extract a value from a property list.
1965 PLIST is a property list, which is a list of the form
1966 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1967 corresponding to the given PROP, or nil if PROP is not one of the
1968 properties on the list. This function never signals an error. */)
1973 Lisp_Object tail
, halftail
;
1975 /* halftail is used to detect circular lists. */
1976 tail
= halftail
= plist
;
1977 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1979 if (EQ (prop
, XCAR (tail
)))
1980 return XCAR (XCDR (tail
));
1982 tail
= XCDR (XCDR (tail
));
1983 halftail
= XCDR (halftail
);
1984 if (EQ (tail
, halftail
))
1991 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1992 doc
: /* Return the value of SYMBOL's PROPNAME property.
1993 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1995 Lisp_Object symbol
, propname
;
1997 CHECK_SYMBOL (symbol
);
1998 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2001 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2002 doc
: /* Change value in PLIST of PROP to VAL.
2003 PLIST is a property list, which is a list of the form
2004 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2005 If PROP is already a property on the list, its value is set to VAL,
2006 otherwise the new PROP VAL pair is added. The new plist is returned;
2007 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2008 The PLIST is modified by side effects. */)
2011 register Lisp_Object prop
;
2014 register Lisp_Object tail
, prev
;
2015 Lisp_Object newcell
;
2017 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2018 tail
= XCDR (XCDR (tail
)))
2020 if (EQ (prop
, XCAR (tail
)))
2022 Fsetcar (XCDR (tail
), val
);
2029 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2033 Fsetcdr (XCDR (prev
), newcell
);
2037 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2038 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2039 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2040 (symbol
, propname
, value
)
2041 Lisp_Object symbol
, propname
, value
;
2043 CHECK_SYMBOL (symbol
);
2044 XSYMBOL (symbol
)->plist
2045 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2049 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2050 doc
: /* Extract a value from a property list, comparing with `equal'.
2051 PLIST is a property list, which is a list of the form
2052 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2053 corresponding to the given PROP, or nil if PROP is not
2054 one of the properties on the list. */)
2062 CONSP (tail
) && CONSP (XCDR (tail
));
2063 tail
= XCDR (XCDR (tail
)))
2065 if (! NILP (Fequal (prop
, XCAR (tail
))))
2066 return XCAR (XCDR (tail
));
2071 CHECK_LIST_END (tail
, prop
);
2076 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2077 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2078 PLIST is a property list, which is a list of the form
2079 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2080 If PROP is already a property on the list, its value is set to VAL,
2081 otherwise the new PROP VAL pair is added. The new plist is returned;
2082 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2083 The PLIST is modified by side effects. */)
2086 register Lisp_Object prop
;
2089 register Lisp_Object tail
, prev
;
2090 Lisp_Object newcell
;
2092 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2093 tail
= XCDR (XCDR (tail
)))
2095 if (! NILP (Fequal (prop
, XCAR (tail
))))
2097 Fsetcar (XCDR (tail
), val
);
2104 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2108 Fsetcdr (XCDR (prev
), newcell
);
2112 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2113 doc
: /* Return t if the two args are the same Lisp object.
2114 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2116 Lisp_Object obj1
, obj2
;
2119 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2121 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2124 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2125 doc
: /* Return t if two Lisp objects have similar structure and contents.
2126 They must have the same data type.
2127 Conses are compared by comparing the cars and the cdrs.
2128 Vectors and strings are compared element by element.
2129 Numbers are compared by value, but integers cannot equal floats.
2130 (Use `=' if you want integers and floats to be able to be equal.)
2131 Symbols must match exactly. */)
2133 register Lisp_Object o1
, o2
;
2135 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2138 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2139 doc
: /* Return t if two Lisp objects have similar structure and contents.
2140 This is like `equal' except that it compares the text properties
2141 of strings. (`equal' ignores text properties.) */)
2143 register Lisp_Object o1
, o2
;
2145 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2148 /* DEPTH is current depth of recursion. Signal an error if it
2150 PROPS, if non-nil, means compare string text properties too. */
2153 internal_equal (o1
, o2
, depth
, props
)
2154 register Lisp_Object o1
, o2
;
2158 error ("Stack overflow in equal");
2164 if (XTYPE (o1
) != XTYPE (o2
))
2173 d1
= extract_float (o1
);
2174 d2
= extract_float (o2
);
2175 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2176 though they are not =. */
2177 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2181 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2188 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2192 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2194 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2197 o1
= XOVERLAY (o1
)->plist
;
2198 o2
= XOVERLAY (o2
)->plist
;
2203 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2204 && (XMARKER (o1
)->buffer
== 0
2205 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2209 case Lisp_Vectorlike
:
2212 EMACS_INT size
= ASIZE (o1
);
2213 /* Pseudovectors have the type encoded in the size field, so this test
2214 actually checks that the objects have the same type as well as the
2216 if (ASIZE (o2
) != size
)
2218 /* Boolvectors are compared much like strings. */
2219 if (BOOL_VECTOR_P (o1
))
2222 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2223 / BOOL_VECTOR_BITS_PER_CHAR
);
2225 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2227 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2232 if (WINDOW_CONFIGURATIONP (o1
))
2233 return compare_window_configurations (o1
, o2
, 0);
2235 /* Aside from them, only true vectors, char-tables, compiled
2236 functions, and fonts (font-spec, font-entity, font-ojbect)
2237 are sensible to compare, so eliminate the others now. */
2238 if (size
& PSEUDOVECTOR_FLAG
)
2240 if (!(size
& (PVEC_COMPILED
2241 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2243 size
&= PSEUDOVECTOR_SIZE_MASK
;
2245 for (i
= 0; i
< size
; i
++)
2250 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2258 if (SCHARS (o1
) != SCHARS (o2
))
2260 if (SBYTES (o1
) != SBYTES (o2
))
2262 if (bcmp (SDATA (o1
), SDATA (o2
),
2265 if (props
&& !compare_string_intervals (o1
, o2
))
2271 case Lisp_Type_Limit
:
2278 extern Lisp_Object
Fmake_char_internal ();
2280 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2281 doc
: /* Store each element of ARRAY with ITEM.
2282 ARRAY is a vector, string, char-table, or bool-vector. */)
2284 Lisp_Object array
, item
;
2286 register int size
, index
, charval
;
2287 if (VECTORP (array
))
2289 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2290 size
= ASIZE (array
);
2291 for (index
= 0; index
< size
; index
++)
2294 else if (CHAR_TABLE_P (array
))
2298 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2299 XCHAR_TABLE (array
)->contents
[i
] = item
;
2300 XCHAR_TABLE (array
)->defalt
= item
;
2302 else if (STRINGP (array
))
2304 register unsigned char *p
= SDATA (array
);
2305 CHECK_NUMBER (item
);
2306 charval
= XINT (item
);
2307 size
= SCHARS (array
);
2308 if (STRING_MULTIBYTE (array
))
2310 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2311 int len
= CHAR_STRING (charval
, str
);
2312 int size_byte
= SBYTES (array
);
2313 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2316 if (size
!= size_byte
)
2319 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2320 if (len
!= this_len
)
2321 error ("Attempt to change byte length of a string");
2324 for (i
= 0; i
< size_byte
; i
++)
2325 *p
++ = str
[i
% len
];
2328 for (index
= 0; index
< size
; index
++)
2331 else if (BOOL_VECTOR_P (array
))
2333 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2335 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2336 / BOOL_VECTOR_BITS_PER_CHAR
);
2338 charval
= (! NILP (item
) ? -1 : 0);
2339 for (index
= 0; index
< size_in_chars
- 1; index
++)
2341 if (index
< size_in_chars
)
2343 /* Mask out bits beyond the vector size. */
2344 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2345 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2350 wrong_type_argument (Qarrayp
, array
);
2354 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2356 doc
: /* Clear the contents of STRING.
2357 This makes STRING unibyte and may change its length. */)
2362 CHECK_STRING (string
);
2363 len
= SBYTES (string
);
2364 bzero (SDATA (string
), len
);
2365 STRING_SET_CHARS (string
, len
);
2366 STRING_SET_UNIBYTE (string
);
2376 Lisp_Object args
[2];
2379 return Fnconc (2, args
);
2381 return Fnconc (2, &s1
);
2382 #endif /* NO_ARG_ARRAY */
2385 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2386 doc
: /* Concatenate any number of lists by altering them.
2387 Only the last argument is not altered, and need not be a list.
2388 usage: (nconc &rest LISTS) */)
2393 register int argnum
;
2394 register Lisp_Object tail
, tem
, val
;
2398 for (argnum
= 0; argnum
< nargs
; argnum
++)
2401 if (NILP (tem
)) continue;
2406 if (argnum
+ 1 == nargs
) break;
2408 CHECK_LIST_CONS (tem
, tem
);
2417 tem
= args
[argnum
+ 1];
2418 Fsetcdr (tail
, tem
);
2420 args
[argnum
+ 1] = tail
;
2426 /* This is the guts of all mapping functions.
2427 Apply FN to each element of SEQ, one by one,
2428 storing the results into elements of VALS, a C vector of Lisp_Objects.
2429 LENI is the length of VALS, which should also be the length of SEQ. */
2432 mapcar1 (leni
, vals
, fn
, seq
)
2435 Lisp_Object fn
, seq
;
2437 register Lisp_Object tail
;
2440 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2444 /* Don't let vals contain any garbage when GC happens. */
2445 for (i
= 0; i
< leni
; i
++)
2448 GCPRO3 (dummy
, fn
, seq
);
2450 gcpro1
.nvars
= leni
;
2454 /* We need not explicitly protect `tail' because it is used only on lists, and
2455 1) lists are not relocated and 2) the list is marked via `seq' so will not
2460 for (i
= 0; i
< leni
; i
++)
2462 dummy
= call1 (fn
, AREF (seq
, i
));
2467 else if (BOOL_VECTOR_P (seq
))
2469 for (i
= 0; i
< leni
; i
++)
2472 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2473 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2474 dummy
= call1 (fn
, dummy
);
2479 else if (STRINGP (seq
))
2483 for (i
= 0, i_byte
= 0; i
< leni
;)
2488 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2489 XSETFASTINT (dummy
, c
);
2490 dummy
= call1 (fn
, dummy
);
2492 vals
[i_before
] = dummy
;
2495 else /* Must be a list, since Flength did not get an error */
2498 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2500 dummy
= call1 (fn
, XCAR (tail
));
2510 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2511 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2512 In between each pair of results, stick in SEPARATOR. Thus, " " as
2513 SEPARATOR results in spaces between the values returned by FUNCTION.
2514 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2515 (function
, sequence
, separator
)
2516 Lisp_Object function
, sequence
, separator
;
2521 register Lisp_Object
*args
;
2523 struct gcpro gcpro1
;
2527 len
= Flength (sequence
);
2528 if (CHAR_TABLE_P (sequence
))
2529 wrong_type_argument (Qlistp
, sequence
);
2531 nargs
= leni
+ leni
- 1;
2532 if (nargs
< 0) return empty_unibyte_string
;
2534 SAFE_ALLOCA_LISP (args
, nargs
);
2537 mapcar1 (leni
, args
, function
, sequence
);
2540 for (i
= leni
- 1; i
> 0; i
--)
2541 args
[i
+ i
] = args
[i
];
2543 for (i
= 1; i
< nargs
; i
+= 2)
2544 args
[i
] = separator
;
2546 ret
= Fconcat (nargs
, args
);
2552 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2553 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2554 The result is a list just as long as SEQUENCE.
2555 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2556 (function
, sequence
)
2557 Lisp_Object function
, sequence
;
2559 register Lisp_Object len
;
2561 register Lisp_Object
*args
;
2565 len
= Flength (sequence
);
2566 if (CHAR_TABLE_P (sequence
))
2567 wrong_type_argument (Qlistp
, sequence
);
2568 leni
= XFASTINT (len
);
2570 SAFE_ALLOCA_LISP (args
, leni
);
2572 mapcar1 (leni
, args
, function
, sequence
);
2574 ret
= Flist (leni
, args
);
2580 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2581 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2582 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2583 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2584 (function
, sequence
)
2585 Lisp_Object function
, sequence
;
2589 leni
= XFASTINT (Flength (sequence
));
2590 if (CHAR_TABLE_P (sequence
))
2591 wrong_type_argument (Qlistp
, sequence
);
2592 mapcar1 (leni
, 0, function
, sequence
);
2597 /* Anything that calls this function must protect from GC! */
2599 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2600 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2601 Takes one argument, which is the string to display to ask the question.
2602 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2603 No confirmation of the answer is requested; a single character is enough.
2604 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2605 the bindings in `query-replace-map'; see the documentation of that variable
2606 for more information. In this case, the useful bindings are `act', `skip',
2607 `recenter', and `quit'.\)
2609 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2610 is nil and `use-dialog-box' is non-nil. */)
2614 register Lisp_Object obj
, key
, def
, map
;
2615 register int answer
;
2616 Lisp_Object xprompt
;
2617 Lisp_Object args
[2];
2618 struct gcpro gcpro1
, gcpro2
;
2619 int count
= SPECPDL_INDEX ();
2621 specbind (Qcursor_in_echo_area
, Qt
);
2623 map
= Fsymbol_value (intern ("query-replace-map"));
2625 CHECK_STRING (prompt
);
2627 GCPRO2 (prompt
, xprompt
);
2629 #ifdef HAVE_WINDOW_SYSTEM
2630 if (display_hourglass_p
)
2631 cancel_hourglass ();
2638 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2639 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2643 Lisp_Object pane
, menu
;
2644 redisplay_preserve_echo_area (3);
2645 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2646 Fcons (Fcons (build_string ("No"), Qnil
),
2648 menu
= Fcons (prompt
, pane
);
2649 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2650 answer
= !NILP (obj
);
2653 #endif /* HAVE_MENUS */
2654 cursor_in_echo_area
= 1;
2655 choose_minibuf_frame ();
2658 Lisp_Object pargs
[3];
2660 /* Colorize prompt according to `minibuffer-prompt' face. */
2661 pargs
[0] = build_string ("%s(y or n) ");
2662 pargs
[1] = intern ("face");
2663 pargs
[2] = intern ("minibuffer-prompt");
2664 args
[0] = Fpropertize (3, pargs
);
2669 if (minibuffer_auto_raise
)
2671 Lisp_Object mini_frame
;
2673 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2675 Fraise_frame (mini_frame
);
2678 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2679 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2680 cursor_in_echo_area
= 0;
2681 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2684 key
= Fmake_vector (make_number (1), obj
);
2685 def
= Flookup_key (map
, key
, Qt
);
2687 if (EQ (def
, intern ("skip")))
2692 else if (EQ (def
, intern ("act")))
2697 else if (EQ (def
, intern ("recenter")))
2703 else if (EQ (def
, intern ("quit")))
2705 /* We want to exit this command for exit-prefix,
2706 and this is the only way to do it. */
2707 else if (EQ (def
, intern ("exit-prefix")))
2712 /* If we don't clear this, then the next call to read_char will
2713 return quit_char again, and we'll enter an infinite loop. */
2718 if (EQ (xprompt
, prompt
))
2720 args
[0] = build_string ("Please answer y or n. ");
2722 xprompt
= Fconcat (2, args
);
2727 if (! noninteractive
)
2729 cursor_in_echo_area
= -1;
2730 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2734 unbind_to (count
, Qnil
);
2735 return answer
? Qt
: Qnil
;
2738 /* This is how C code calls `yes-or-no-p' and allows the user
2741 Anything that calls this function must protect from GC! */
2744 do_yes_or_no_p (prompt
)
2747 return call1 (intern ("yes-or-no-p"), prompt
);
2750 /* Anything that calls this function must protect from GC! */
2752 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2753 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2754 Takes one argument, which is the string to display to ask the question.
2755 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2756 The user must confirm the answer with RET,
2757 and can edit it until it has been confirmed.
2759 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2760 is nil, and `use-dialog-box' is non-nil. */)
2764 register Lisp_Object ans
;
2765 Lisp_Object args
[2];
2766 struct gcpro gcpro1
;
2768 CHECK_STRING (prompt
);
2771 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2772 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2776 Lisp_Object pane
, menu
, obj
;
2777 redisplay_preserve_echo_area (4);
2778 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2779 Fcons (Fcons (build_string ("No"), Qnil
),
2782 menu
= Fcons (prompt
, pane
);
2783 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2787 #endif /* HAVE_MENUS */
2790 args
[1] = build_string ("(yes or no) ");
2791 prompt
= Fconcat (2, args
);
2797 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2798 Qyes_or_no_p_history
, Qnil
,
2800 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2805 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2813 message ("Please answer yes or no.");
2814 Fsleep_for (make_number (2), Qnil
);
2818 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2819 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2821 Each of the three load averages is multiplied by 100, then converted
2824 When USE-FLOATS is non-nil, floats will be used instead of integers.
2825 These floats are not multiplied by 100.
2827 If the 5-minute or 15-minute load averages are not available, return a
2828 shortened list, containing only those averages which are available.
2830 An error is thrown if the load average can't be obtained. In some
2831 cases making it work would require Emacs being installed setuid or
2832 setgid so that it can read kernel information, and that usually isn't
2835 Lisp_Object use_floats
;
2838 int loads
= getloadavg (load_ave
, 3);
2839 Lisp_Object ret
= Qnil
;
2842 error ("load-average not implemented for this operating system");
2846 Lisp_Object load
= (NILP (use_floats
) ?
2847 make_number ((int) (100.0 * load_ave
[loads
]))
2848 : make_float (load_ave
[loads
]));
2849 ret
= Fcons (load
, ret
);
2855 Lisp_Object Vfeatures
, Qsubfeatures
;
2856 extern Lisp_Object Vafter_load_alist
;
2858 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2859 doc
: /* Returns t if FEATURE is present in this Emacs.
2861 Use this to conditionalize execution of lisp code based on the
2862 presence or absence of Emacs or environment extensions.
2863 Use `provide' to declare that a feature is available. This function
2864 looks at the value of the variable `features'. The optional argument
2865 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2866 (feature
, subfeature
)
2867 Lisp_Object feature
, subfeature
;
2869 register Lisp_Object tem
;
2870 CHECK_SYMBOL (feature
);
2871 tem
= Fmemq (feature
, Vfeatures
);
2872 if (!NILP (tem
) && !NILP (subfeature
))
2873 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2874 return (NILP (tem
)) ? Qnil
: Qt
;
2877 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2878 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2879 The optional argument SUBFEATURES should be a list of symbols listing
2880 particular subfeatures supported in this version of FEATURE. */)
2881 (feature
, subfeatures
)
2882 Lisp_Object feature
, subfeatures
;
2884 register Lisp_Object tem
;
2885 CHECK_SYMBOL (feature
);
2886 CHECK_LIST (subfeatures
);
2887 if (!NILP (Vautoload_queue
))
2888 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2890 tem
= Fmemq (feature
, Vfeatures
);
2892 Vfeatures
= Fcons (feature
, Vfeatures
);
2893 if (!NILP (subfeatures
))
2894 Fput (feature
, Qsubfeatures
, subfeatures
);
2895 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2897 /* Run any load-hooks for this file. */
2898 tem
= Fassq (feature
, Vafter_load_alist
);
2900 Fprogn (XCDR (tem
));
2905 /* `require' and its subroutines. */
2907 /* List of features currently being require'd, innermost first. */
2909 Lisp_Object require_nesting_list
;
2912 require_unwind (old_value
)
2913 Lisp_Object old_value
;
2915 return require_nesting_list
= old_value
;
2918 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2919 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2920 If FEATURE is not a member of the list `features', then the feature
2921 is not loaded; so load the file FILENAME.
2922 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2923 and `load' will try to load this name appended with the suffix `.elc' or
2924 `.el', in that order. The name without appended suffix will not be used.
2925 If the optional third argument NOERROR is non-nil,
2926 then return nil if the file is not found instead of signaling an error.
2927 Normally the return value is FEATURE.
2928 The normal messages at start and end of loading FILENAME are suppressed. */)
2929 (feature
, filename
, noerror
)
2930 Lisp_Object feature
, filename
, noerror
;
2932 register Lisp_Object tem
;
2933 struct gcpro gcpro1
, gcpro2
;
2934 int from_file
= load_in_progress
;
2936 CHECK_SYMBOL (feature
);
2938 /* Record the presence of `require' in this file
2939 even if the feature specified is already loaded.
2940 But not more than once in any file,
2941 and not when we aren't loading or reading from a file. */
2943 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2944 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2949 tem
= Fcons (Qrequire
, feature
);
2950 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2951 LOADHIST_ATTACH (tem
);
2953 tem
= Fmemq (feature
, Vfeatures
);
2957 int count
= SPECPDL_INDEX ();
2960 /* This is to make sure that loadup.el gives a clear picture
2961 of what files are preloaded and when. */
2962 if (! NILP (Vpurify_flag
))
2963 error ("(require %s) while preparing to dump",
2964 SDATA (SYMBOL_NAME (feature
)));
2966 /* A certain amount of recursive `require' is legitimate,
2967 but if we require the same feature recursively 3 times,
2969 tem
= require_nesting_list
;
2970 while (! NILP (tem
))
2972 if (! NILP (Fequal (feature
, XCAR (tem
))))
2977 error ("Recursive `require' for feature `%s'",
2978 SDATA (SYMBOL_NAME (feature
)));
2980 /* Update the list for any nested `require's that occur. */
2981 record_unwind_protect (require_unwind
, require_nesting_list
);
2982 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2984 /* Value saved here is to be restored into Vautoload_queue */
2985 record_unwind_protect (un_autoload
, Vautoload_queue
);
2986 Vautoload_queue
= Qt
;
2988 /* Load the file. */
2989 GCPRO2 (feature
, filename
);
2990 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2991 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2994 /* If load failed entirely, return nil. */
2996 return unbind_to (count
, Qnil
);
2998 tem
= Fmemq (feature
, Vfeatures
);
3000 error ("Required feature `%s' was not provided",
3001 SDATA (SYMBOL_NAME (feature
)));
3003 /* Once loading finishes, don't undo it. */
3004 Vautoload_queue
= Qt
;
3005 feature
= unbind_to (count
, feature
);
3011 /* Primitives for work of the "widget" library.
3012 In an ideal world, this section would not have been necessary.
3013 However, lisp function calls being as slow as they are, it turns
3014 out that some functions in the widget library (wid-edit.el) are the
3015 bottleneck of Widget operation. Here is their translation to C,
3016 for the sole reason of efficiency. */
3018 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3019 doc
: /* Return non-nil if PLIST has the property PROP.
3020 PLIST is a property list, which is a list of the form
3021 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3022 Unlike `plist-get', this allows you to distinguish between a missing
3023 property and a property with the value nil.
3024 The value is actually the tail of PLIST whose car is PROP. */)
3026 Lisp_Object plist
, prop
;
3028 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3031 plist
= XCDR (plist
);
3032 plist
= CDR (plist
);
3037 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3038 doc
: /* In WIDGET, set PROPERTY to VALUE.
3039 The value can later be retrieved with `widget-get'. */)
3040 (widget
, property
, value
)
3041 Lisp_Object widget
, property
, value
;
3043 CHECK_CONS (widget
);
3044 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3048 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3049 doc
: /* In WIDGET, get the value of PROPERTY.
3050 The value could either be specified when the widget was created, or
3051 later with `widget-put'. */)
3053 Lisp_Object widget
, property
;
3061 CHECK_CONS (widget
);
3062 tmp
= Fplist_member (XCDR (widget
), property
);
3068 tmp
= XCAR (widget
);
3071 widget
= Fget (tmp
, Qwidget_type
);
3075 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3076 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3077 ARGS are passed as extra arguments to the function.
3078 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3083 /* This function can GC. */
3084 Lisp_Object newargs
[3];
3085 struct gcpro gcpro1
, gcpro2
;
3088 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3089 newargs
[1] = args
[0];
3090 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3091 GCPRO2 (newargs
[0], newargs
[2]);
3092 result
= Fapply (3, newargs
);
3097 #ifdef HAVE_LANGINFO_CODESET
3098 #include <langinfo.h>
3101 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3102 doc
: /* Access locale data ITEM for the current C locale, if available.
3103 ITEM should be one of the following:
3105 `codeset', returning the character set as a string (locale item CODESET);
3107 `days', returning a 7-element vector of day names (locale items DAY_n);
3109 `months', returning a 12-element vector of month names (locale items MON_n);
3111 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3112 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3114 If the system can't provide such information through a call to
3115 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3117 See also Info node `(libc)Locales'.
3119 The data read from the system are decoded using `locale-coding-system'. */)
3124 #ifdef HAVE_LANGINFO_CODESET
3126 if (EQ (item
, Qcodeset
))
3128 str
= nl_langinfo (CODESET
);
3129 return build_string (str
);
3132 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3134 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3135 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3137 synchronize_system_time_locale ();
3138 for (i
= 0; i
< 7; i
++)
3140 str
= nl_langinfo (days
[i
]);
3141 val
= make_unibyte_string (str
, strlen (str
));
3142 /* Fixme: Is this coding system necessarily right, even if
3143 it is consistent with CODESET? If not, what to do? */
3144 Faset (v
, make_number (i
),
3145 code_convert_string_norecord (val
, Vlocale_coding_system
,
3152 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3154 struct Lisp_Vector
*p
= allocate_vector (12);
3155 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3156 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3158 synchronize_system_time_locale ();
3159 for (i
= 0; i
< 12; i
++)
3161 str
= nl_langinfo (months
[i
]);
3162 val
= make_unibyte_string (str
, strlen (str
));
3164 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3166 XSETVECTOR (val
, p
);
3170 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3171 but is in the locale files. This could be used by ps-print. */
3173 else if (EQ (item
, Qpaper
))
3175 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3176 make_number (nl_langinfo (PAPER_HEIGHT
)));
3178 #endif /* PAPER_WIDTH */
3179 #endif /* HAVE_LANGINFO_CODESET*/
3183 /* base64 encode/decode functions (RFC 2045).
3184 Based on code from GNU recode. */
3186 #define MIME_LINE_LENGTH 76
3188 #define IS_ASCII(Character) \
3190 #define IS_BASE64(Character) \
3191 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3192 #define IS_BASE64_IGNORABLE(Character) \
3193 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3194 || (Character) == '\f' || (Character) == '\r')
3196 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3197 character or return retval if there are no characters left to
3199 #define READ_QUADRUPLET_BYTE(retval) \
3204 if (nchars_return) \
3205 *nchars_return = nchars; \
3210 while (IS_BASE64_IGNORABLE (c))
3212 /* Table of characters coding the 64 values. */
3213 static char base64_value_to_char
[64] =
3215 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3216 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3217 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3218 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3219 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3220 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3221 '8', '9', '+', '/' /* 60-63 */
3224 /* Table of base64 values for first 128 characters. */
3225 static short base64_char_to_value
[128] =
3227 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3228 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3229 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3230 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3231 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3232 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3233 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3234 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3235 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3236 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3237 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3238 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3239 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3242 /* The following diagram shows the logical steps by which three octets
3243 get transformed into four base64 characters.
3245 .--------. .--------. .--------.
3246 |aaaaaabb| |bbbbcccc| |ccdddddd|
3247 `--------' `--------' `--------'
3249 .--------+--------+--------+--------.
3250 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3251 `--------+--------+--------+--------'
3253 .--------+--------+--------+--------.
3254 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3255 `--------+--------+--------+--------'
3257 The octets are divided into 6 bit chunks, which are then encoded into
3258 base64 characters. */
3261 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3262 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3264 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3266 doc
: /* Base64-encode the region between BEG and END.
3267 Return the length of the encoded text.
3268 Optional third argument NO-LINE-BREAK means do not break long lines
3269 into shorter lines. */)
3270 (beg
, end
, no_line_break
)
3271 Lisp_Object beg
, end
, no_line_break
;
3274 int allength
, length
;
3275 int ibeg
, iend
, encoded_length
;
3279 validate_region (&beg
, &end
);
3281 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3282 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3283 move_gap_both (XFASTINT (beg
), ibeg
);
3285 /* We need to allocate enough room for encoding the text.
3286 We need 33 1/3% more space, plus a newline every 76
3287 characters, and then we round up. */
3288 length
= iend
- ibeg
;
3289 allength
= length
+ length
/3 + 1;
3290 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3292 SAFE_ALLOCA (encoded
, char *, allength
);
3293 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3294 NILP (no_line_break
),
3295 !NILP (current_buffer
->enable_multibyte_characters
));
3296 if (encoded_length
> allength
)
3299 if (encoded_length
< 0)
3301 /* The encoding wasn't possible. */
3303 error ("Multibyte character in data for base64 encoding");
3306 /* Now we have encoded the region, so we insert the new contents
3307 and delete the old. (Insert first in order to preserve markers.) */
3308 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3309 insert (encoded
, encoded_length
);
3311 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3313 /* If point was outside of the region, restore it exactly; else just
3314 move to the beginning of the region. */
3315 if (old_pos
>= XFASTINT (end
))
3316 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3317 else if (old_pos
> XFASTINT (beg
))
3318 old_pos
= XFASTINT (beg
);
3321 /* We return the length of the encoded text. */
3322 return make_number (encoded_length
);
3325 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3327 doc
: /* Base64-encode STRING and return the result.
3328 Optional second argument NO-LINE-BREAK means do not break long lines
3329 into shorter lines. */)
3330 (string
, no_line_break
)
3331 Lisp_Object string
, no_line_break
;
3333 int allength
, length
, encoded_length
;
3335 Lisp_Object encoded_string
;
3338 CHECK_STRING (string
);
3340 /* We need to allocate enough room for encoding the text.
3341 We need 33 1/3% more space, plus a newline every 76
3342 characters, and then we round up. */
3343 length
= SBYTES (string
);
3344 allength
= length
+ length
/3 + 1;
3345 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3347 /* We need to allocate enough room for decoding the text. */
3348 SAFE_ALLOCA (encoded
, char *, allength
);
3350 encoded_length
= base64_encode_1 (SDATA (string
),
3351 encoded
, length
, NILP (no_line_break
),
3352 STRING_MULTIBYTE (string
));
3353 if (encoded_length
> allength
)
3356 if (encoded_length
< 0)
3358 /* The encoding wasn't possible. */
3360 error ("Multibyte character in data for base64 encoding");
3363 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3366 return encoded_string
;
3370 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3377 int counter
= 0, i
= 0;
3387 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3388 if (CHAR_BYTE8_P (c
))
3389 c
= CHAR_TO_BYTE8 (c
);
3397 /* Wrap line every 76 characters. */
3401 if (counter
< MIME_LINE_LENGTH
/ 4)
3410 /* Process first byte of a triplet. */
3412 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3413 value
= (0x03 & c
) << 4;
3415 /* Process second byte of a triplet. */
3419 *e
++ = base64_value_to_char
[value
];
3427 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3428 if (CHAR_BYTE8_P (c
))
3429 c
= CHAR_TO_BYTE8 (c
);
3437 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3438 value
= (0x0f & c
) << 2;
3440 /* Process third byte of a triplet. */
3444 *e
++ = base64_value_to_char
[value
];
3451 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3452 if (CHAR_BYTE8_P (c
))
3453 c
= CHAR_TO_BYTE8 (c
);
3461 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3462 *e
++ = base64_value_to_char
[0x3f & c
];
3469 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3471 doc
: /* Base64-decode the region between BEG and END.
3472 Return the length of the decoded text.
3473 If the region can't be decoded, signal an error and don't modify the buffer. */)
3475 Lisp_Object beg
, end
;
3477 int ibeg
, iend
, length
, allength
;
3482 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3485 validate_region (&beg
, &end
);
3487 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3488 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3490 length
= iend
- ibeg
;
3492 /* We need to allocate enough room for decoding the text. If we are
3493 working on a multibyte buffer, each decoded code may occupy at
3495 allength
= multibyte
? length
* 2 : length
;
3496 SAFE_ALLOCA (decoded
, char *, allength
);
3498 move_gap_both (XFASTINT (beg
), ibeg
);
3499 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3500 multibyte
, &inserted_chars
);
3501 if (decoded_length
> allength
)
3504 if (decoded_length
< 0)
3506 /* The decoding wasn't possible. */
3508 error ("Invalid base64 data");
3511 /* Now we have decoded the region, so we insert the new contents
3512 and delete the old. (Insert first in order to preserve markers.) */
3513 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3514 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3517 /* Delete the original text. */
3518 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3519 iend
+ decoded_length
, 1);
3521 /* If point was outside of the region, restore it exactly; else just
3522 move to the beginning of the region. */
3523 if (old_pos
>= XFASTINT (end
))
3524 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3525 else if (old_pos
> XFASTINT (beg
))
3526 old_pos
= XFASTINT (beg
);
3527 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3529 return make_number (inserted_chars
);
3532 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3534 doc
: /* Base64-decode STRING and return the result. */)
3539 int length
, decoded_length
;
3540 Lisp_Object decoded_string
;
3543 CHECK_STRING (string
);
3545 length
= SBYTES (string
);
3546 /* We need to allocate enough room for decoding the text. */
3547 SAFE_ALLOCA (decoded
, char *, length
);
3549 /* The decoded result should be unibyte. */
3550 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3552 if (decoded_length
> length
)
3554 else if (decoded_length
>= 0)
3555 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3557 decoded_string
= Qnil
;
3560 if (!STRINGP (decoded_string
))
3561 error ("Invalid base64 data");
3563 return decoded_string
;
3566 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3567 MULTIBYTE is nonzero, the decoded result should be in multibyte
3568 form. If NCHARS_RETRUN is not NULL, store the number of produced
3569 characters in *NCHARS_RETURN. */
3572 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3582 unsigned long value
;
3587 /* Process first byte of a quadruplet. */
3589 READ_QUADRUPLET_BYTE (e
-to
);
3593 value
= base64_char_to_value
[c
] << 18;
3595 /* Process second byte of a quadruplet. */
3597 READ_QUADRUPLET_BYTE (-1);
3601 value
|= base64_char_to_value
[c
] << 12;
3603 c
= (unsigned char) (value
>> 16);
3604 if (multibyte
&& c
>= 128)
3605 e
+= BYTE8_STRING (c
, e
);
3610 /* Process third byte of a quadruplet. */
3612 READ_QUADRUPLET_BYTE (-1);
3616 READ_QUADRUPLET_BYTE (-1);
3625 value
|= base64_char_to_value
[c
] << 6;
3627 c
= (unsigned char) (0xff & value
>> 8);
3628 if (multibyte
&& c
>= 128)
3629 e
+= BYTE8_STRING (c
, e
);
3634 /* Process fourth byte of a quadruplet. */
3636 READ_QUADRUPLET_BYTE (-1);
3643 value
|= base64_char_to_value
[c
];
3645 c
= (unsigned char) (0xff & value
);
3646 if (multibyte
&& c
>= 128)
3647 e
+= BYTE8_STRING (c
, e
);
3656 /***********************************************************************
3658 ***** Hash Tables *****
3660 ***********************************************************************/
3662 /* Implemented by gerd@gnu.org. This hash table implementation was
3663 inspired by CMUCL hash tables. */
3667 1. For small tables, association lists are probably faster than
3668 hash tables because they have lower overhead.
3670 For uses of hash tables where the O(1) behavior of table
3671 operations is not a requirement, it might therefore be a good idea
3672 not to hash. Instead, we could just do a linear search in the
3673 key_and_value vector of the hash table. This could be done
3674 if a `:linear-search t' argument is given to make-hash-table. */
3677 /* The list of all weak hash tables. Don't staticpro this one. */
3679 struct Lisp_Hash_Table
*weak_hash_tables
;
3681 /* Various symbols. */
3683 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3684 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3685 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3687 /* Function prototypes. */
3689 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3690 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3691 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3692 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3693 Lisp_Object
, unsigned));
3694 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3695 Lisp_Object
, unsigned));
3696 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3697 unsigned, Lisp_Object
, unsigned));
3698 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3699 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3700 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3701 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3703 static unsigned sxhash_string
P_ ((unsigned char *, int));
3704 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3705 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3706 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3707 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3711 /***********************************************************************
3713 ***********************************************************************/
3715 /* If OBJ is a Lisp hash table, return a pointer to its struct
3716 Lisp_Hash_Table. Otherwise, signal an error. */
3718 static struct Lisp_Hash_Table
*
3719 check_hash_table (obj
)
3722 CHECK_HASH_TABLE (obj
);
3723 return XHASH_TABLE (obj
);
3727 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3731 next_almost_prime (n
)
3744 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3745 which USED[I] is non-zero. If found at index I in ARGS, set
3746 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3747 -1. This function is used to extract a keyword/argument pair from
3748 a DEFUN parameter list. */
3751 get_key_arg (key
, nargs
, args
, used
)
3759 for (i
= 0; i
< nargs
- 1; ++i
)
3760 if (!used
[i
] && EQ (args
[i
], key
))
3775 /* Return a Lisp vector which has the same contents as VEC but has
3776 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3777 vector that are not copied from VEC are set to INIT. */
3780 larger_vector (vec
, new_size
, init
)
3785 struct Lisp_Vector
*v
;
3788 xassert (VECTORP (vec
));
3789 old_size
= ASIZE (vec
);
3790 xassert (new_size
>= old_size
);
3792 v
= allocate_vector (new_size
);
3793 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3794 old_size
* sizeof *v
->contents
);
3795 for (i
= old_size
; i
< new_size
; ++i
)
3796 v
->contents
[i
] = init
;
3797 XSETVECTOR (vec
, v
);
3802 /***********************************************************************
3804 ***********************************************************************/
3806 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3807 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3808 KEY2 are the same. */
3811 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3812 struct Lisp_Hash_Table
*h
;
3813 Lisp_Object key1
, key2
;
3814 unsigned hash1
, hash2
;
3816 return (FLOATP (key1
)
3818 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3822 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3823 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3824 KEY2 are the same. */
3827 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3828 struct Lisp_Hash_Table
*h
;
3829 Lisp_Object key1
, key2
;
3830 unsigned hash1
, hash2
;
3832 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3836 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3837 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3838 if KEY1 and KEY2 are the same. */
3841 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3842 struct Lisp_Hash_Table
*h
;
3843 Lisp_Object key1
, key2
;
3844 unsigned hash1
, hash2
;
3848 Lisp_Object args
[3];
3850 args
[0] = h
->user_cmp_function
;
3853 return !NILP (Ffuncall (3, args
));
3860 /* Value is a hash code for KEY for use in hash table H which uses
3861 `eq' to compare keys. The hash code returned is guaranteed to fit
3862 in a Lisp integer. */
3866 struct Lisp_Hash_Table
*h
;
3869 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3870 xassert ((hash
& ~INTMASK
) == 0);
3875 /* Value is a hash code for KEY for use in hash table H which uses
3876 `eql' to compare keys. The hash code returned is guaranteed to fit
3877 in a Lisp integer. */
3881 struct Lisp_Hash_Table
*h
;
3886 hash
= sxhash (key
, 0);
3888 hash
= XUINT (key
) ^ XTYPE (key
);
3889 xassert ((hash
& ~INTMASK
) == 0);
3894 /* Value is a hash code for KEY for use in hash table H which uses
3895 `equal' to compare keys. The hash code returned is guaranteed to fit
3896 in a Lisp integer. */
3899 hashfn_equal (h
, key
)
3900 struct Lisp_Hash_Table
*h
;
3903 unsigned hash
= sxhash (key
, 0);
3904 xassert ((hash
& ~INTMASK
) == 0);
3909 /* Value is a hash code for KEY for use in hash table H which uses as
3910 user-defined function to compare keys. The hash code returned is
3911 guaranteed to fit in a Lisp integer. */
3914 hashfn_user_defined (h
, key
)
3915 struct Lisp_Hash_Table
*h
;
3918 Lisp_Object args
[2], hash
;
3920 args
[0] = h
->user_hash_function
;
3922 hash
= Ffuncall (2, args
);
3923 if (!INTEGERP (hash
))
3924 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3925 return XUINT (hash
);
3929 /* Create and initialize a new hash table.
3931 TEST specifies the test the hash table will use to compare keys.
3932 It must be either one of the predefined tests `eq', `eql' or
3933 `equal' or a symbol denoting a user-defined test named TEST with
3934 test and hash functions USER_TEST and USER_HASH.
3936 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3938 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3939 new size when it becomes full is computed by adding REHASH_SIZE to
3940 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3941 table's new size is computed by multiplying its old size with
3944 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3945 be resized when the ratio of (number of entries in the table) /
3946 (table size) is >= REHASH_THRESHOLD.
3948 WEAK specifies the weakness of the table. If non-nil, it must be
3949 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3952 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3953 user_test
, user_hash
)
3954 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3955 Lisp_Object user_test
, user_hash
;
3957 struct Lisp_Hash_Table
*h
;
3959 int index_size
, i
, sz
;
3961 /* Preconditions. */
3962 xassert (SYMBOLP (test
));
3963 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3964 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3965 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3966 xassert (FLOATP (rehash_threshold
)
3967 && XFLOATINT (rehash_threshold
) > 0
3968 && XFLOATINT (rehash_threshold
) <= 1.0);
3970 if (XFASTINT (size
) == 0)
3971 size
= make_number (1);
3973 /* Allocate a table and initialize it. */
3974 h
= allocate_hash_table ();
3976 /* Initialize hash table slots. */
3977 sz
= XFASTINT (size
);
3980 if (EQ (test
, Qeql
))
3982 h
->cmpfn
= cmpfn_eql
;
3983 h
->hashfn
= hashfn_eql
;
3985 else if (EQ (test
, Qeq
))
3988 h
->hashfn
= hashfn_eq
;
3990 else if (EQ (test
, Qequal
))
3992 h
->cmpfn
= cmpfn_equal
;
3993 h
->hashfn
= hashfn_equal
;
3997 h
->user_cmp_function
= user_test
;
3998 h
->user_hash_function
= user_hash
;
3999 h
->cmpfn
= cmpfn_user_defined
;
4000 h
->hashfn
= hashfn_user_defined
;
4004 h
->rehash_threshold
= rehash_threshold
;
4005 h
->rehash_size
= rehash_size
;
4007 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4008 h
->hash
= Fmake_vector (size
, Qnil
);
4009 h
->next
= Fmake_vector (size
, Qnil
);
4010 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4011 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4012 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4014 /* Set up the free list. */
4015 for (i
= 0; i
< sz
- 1; ++i
)
4016 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4017 h
->next_free
= make_number (0);
4019 XSET_HASH_TABLE (table
, h
);
4020 xassert (HASH_TABLE_P (table
));
4021 xassert (XHASH_TABLE (table
) == h
);
4023 /* Maybe add this hash table to the list of all weak hash tables. */
4025 h
->next_weak
= NULL
;
4028 h
->next_weak
= weak_hash_tables
;
4029 weak_hash_tables
= h
;
4036 /* Return a copy of hash table H1. Keys and values are not copied,
4037 only the table itself is. */
4040 copy_hash_table (h1
)
4041 struct Lisp_Hash_Table
*h1
;
4044 struct Lisp_Hash_Table
*h2
;
4045 struct Lisp_Vector
*next
;
4047 h2
= allocate_hash_table ();
4048 next
= h2
->vec_next
;
4049 bcopy (h1
, h2
, sizeof *h2
);
4050 h2
->vec_next
= next
;
4051 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4052 h2
->hash
= Fcopy_sequence (h1
->hash
);
4053 h2
->next
= Fcopy_sequence (h1
->next
);
4054 h2
->index
= Fcopy_sequence (h1
->index
);
4055 XSET_HASH_TABLE (table
, h2
);
4057 /* Maybe add this hash table to the list of all weak hash tables. */
4058 if (!NILP (h2
->weak
))
4060 h2
->next_weak
= weak_hash_tables
;
4061 weak_hash_tables
= h2
;
4068 /* Resize hash table H if it's too full. If H cannot be resized
4069 because it's already too large, throw an error. */
4072 maybe_resize_hash_table (h
)
4073 struct Lisp_Hash_Table
*h
;
4075 if (NILP (h
->next_free
))
4077 int old_size
= HASH_TABLE_SIZE (h
);
4078 int i
, new_size
, index_size
;
4081 if (INTEGERP (h
->rehash_size
))
4082 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4084 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4085 new_size
= max (old_size
+ 1, new_size
);
4086 index_size
= next_almost_prime ((int)
4088 / XFLOATINT (h
->rehash_threshold
)));
4089 /* Assignment to EMACS_INT stops GCC whining about limited range
4091 nsize
= max (index_size
, 2 * new_size
);
4092 if (nsize
> MOST_POSITIVE_FIXNUM
)
4093 error ("Hash table too large to resize");
4095 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4096 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4097 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4098 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4100 /* Update the free list. Do it so that new entries are added at
4101 the end of the free list. This makes some operations like
4103 for (i
= old_size
; i
< new_size
- 1; ++i
)
4104 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4106 if (!NILP (h
->next_free
))
4108 Lisp_Object last
, next
;
4110 last
= h
->next_free
;
4111 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4115 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4118 XSETFASTINT (h
->next_free
, old_size
);
4121 for (i
= 0; i
< old_size
; ++i
)
4122 if (!NILP (HASH_HASH (h
, i
)))
4124 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4125 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4126 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4127 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4133 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4134 the hash code of KEY. Value is the index of the entry in H
4135 matching KEY, or -1 if not found. */
4138 hash_lookup (h
, key
, hash
)
4139 struct Lisp_Hash_Table
*h
;
4144 int start_of_bucket
;
4147 hash_code
= h
->hashfn (h
, key
);
4151 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4152 idx
= HASH_INDEX (h
, start_of_bucket
);
4154 /* We need not gcpro idx since it's either an integer or nil. */
4157 int i
= XFASTINT (idx
);
4158 if (EQ (key
, HASH_KEY (h
, i
))
4160 && h
->cmpfn (h
, key
, hash_code
,
4161 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4163 idx
= HASH_NEXT (h
, i
);
4166 return NILP (idx
) ? -1 : XFASTINT (idx
);
4170 /* Put an entry into hash table H that associates KEY with VALUE.
4171 HASH is a previously computed hash code of KEY.
4172 Value is the index of the entry in H matching KEY. */
4175 hash_put (h
, key
, value
, hash
)
4176 struct Lisp_Hash_Table
*h
;
4177 Lisp_Object key
, value
;
4180 int start_of_bucket
, i
;
4182 xassert ((hash
& ~INTMASK
) == 0);
4184 /* Increment count after resizing because resizing may fail. */
4185 maybe_resize_hash_table (h
);
4188 /* Store key/value in the key_and_value vector. */
4189 i
= XFASTINT (h
->next_free
);
4190 h
->next_free
= HASH_NEXT (h
, i
);
4191 HASH_KEY (h
, i
) = key
;
4192 HASH_VALUE (h
, i
) = value
;
4194 /* Remember its hash code. */
4195 HASH_HASH (h
, i
) = make_number (hash
);
4197 /* Add new entry to its collision chain. */
4198 start_of_bucket
= hash
% ASIZE (h
->index
);
4199 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4200 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4205 /* Remove the entry matching KEY from hash table H, if there is one. */
4208 hash_remove (h
, key
)
4209 struct Lisp_Hash_Table
*h
;
4213 int start_of_bucket
;
4214 Lisp_Object idx
, prev
;
4216 hash_code
= h
->hashfn (h
, key
);
4217 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4218 idx
= HASH_INDEX (h
, start_of_bucket
);
4221 /* We need not gcpro idx, prev since they're either integers or nil. */
4224 int i
= XFASTINT (idx
);
4226 if (EQ (key
, HASH_KEY (h
, i
))
4228 && h
->cmpfn (h
, key
, hash_code
,
4229 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4231 /* Take entry out of collision chain. */
4233 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4235 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4237 /* Clear slots in key_and_value and add the slots to
4239 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4240 HASH_NEXT (h
, i
) = h
->next_free
;
4241 h
->next_free
= make_number (i
);
4243 xassert (h
->count
>= 0);
4249 idx
= HASH_NEXT (h
, i
);
4255 /* Clear hash table H. */
4259 struct Lisp_Hash_Table
*h
;
4263 int i
, size
= HASH_TABLE_SIZE (h
);
4265 for (i
= 0; i
< size
; ++i
)
4267 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4268 HASH_KEY (h
, i
) = Qnil
;
4269 HASH_VALUE (h
, i
) = Qnil
;
4270 HASH_HASH (h
, i
) = Qnil
;
4273 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4274 ASET (h
->index
, i
, Qnil
);
4276 h
->next_free
= make_number (0);
4283 /************************************************************************
4285 ************************************************************************/
4288 init_weak_hash_tables ()
4290 weak_hash_tables
= NULL
;
4293 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4294 entries from the table that don't survive the current GC.
4295 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4296 non-zero if anything was marked. */
4299 sweep_weak_table (h
, remove_entries_p
)
4300 struct Lisp_Hash_Table
*h
;
4301 int remove_entries_p
;
4303 int bucket
, n
, marked
;
4305 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4308 for (bucket
= 0; bucket
< n
; ++bucket
)
4310 Lisp_Object idx
, next
, prev
;
4312 /* Follow collision chain, removing entries that
4313 don't survive this garbage collection. */
4315 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4317 int i
= XFASTINT (idx
);
4318 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4319 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4322 if (EQ (h
->weak
, Qkey
))
4323 remove_p
= !key_known_to_survive_p
;
4324 else if (EQ (h
->weak
, Qvalue
))
4325 remove_p
= !value_known_to_survive_p
;
4326 else if (EQ (h
->weak
, Qkey_or_value
))
4327 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4328 else if (EQ (h
->weak
, Qkey_and_value
))
4329 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4333 next
= HASH_NEXT (h
, i
);
4335 if (remove_entries_p
)
4339 /* Take out of collision chain. */
4341 HASH_INDEX (h
, bucket
) = next
;
4343 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4345 /* Add to free list. */
4346 HASH_NEXT (h
, i
) = h
->next_free
;
4349 /* Clear key, value, and hash. */
4350 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4351 HASH_HASH (h
, i
) = Qnil
;
4364 /* Make sure key and value survive. */
4365 if (!key_known_to_survive_p
)
4367 mark_object (HASH_KEY (h
, i
));
4371 if (!value_known_to_survive_p
)
4373 mark_object (HASH_VALUE (h
, i
));
4384 /* Remove elements from weak hash tables that don't survive the
4385 current garbage collection. Remove weak tables that don't survive
4386 from Vweak_hash_tables. Called from gc_sweep. */
4389 sweep_weak_hash_tables ()
4391 struct Lisp_Hash_Table
*h
, *used
, *next
;
4394 /* Mark all keys and values that are in use. Keep on marking until
4395 there is no more change. This is necessary for cases like
4396 value-weak table A containing an entry X -> Y, where Y is used in a
4397 key-weak table B, Z -> Y. If B comes after A in the list of weak
4398 tables, X -> Y might be removed from A, although when looking at B
4399 one finds that it shouldn't. */
4403 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4405 if (h
->size
& ARRAY_MARK_FLAG
)
4406 marked
|= sweep_weak_table (h
, 0);
4411 /* Remove tables and entries that aren't used. */
4412 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4414 next
= h
->next_weak
;
4416 if (h
->size
& ARRAY_MARK_FLAG
)
4418 /* TABLE is marked as used. Sweep its contents. */
4420 sweep_weak_table (h
, 1);
4422 /* Add table to the list of used weak hash tables. */
4423 h
->next_weak
= used
;
4428 weak_hash_tables
= used
;
4433 /***********************************************************************
4434 Hash Code Computation
4435 ***********************************************************************/
4437 /* Maximum depth up to which to dive into Lisp structures. */
4439 #define SXHASH_MAX_DEPTH 3
4441 /* Maximum length up to which to take list and vector elements into
4444 #define SXHASH_MAX_LEN 7
4446 /* Combine two integers X and Y for hashing. */
4448 #define SXHASH_COMBINE(X, Y) \
4449 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4453 /* Return a hash for string PTR which has length LEN. The hash
4454 code returned is guaranteed to fit in a Lisp integer. */
4457 sxhash_string (ptr
, len
)
4461 unsigned char *p
= ptr
;
4462 unsigned char *end
= p
+ len
;
4471 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4474 return hash
& INTMASK
;
4478 /* Return a hash for list LIST. DEPTH is the current depth in the
4479 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4482 sxhash_list (list
, depth
)
4489 if (depth
< SXHASH_MAX_DEPTH
)
4491 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4492 list
= XCDR (list
), ++i
)
4494 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4495 hash
= SXHASH_COMBINE (hash
, hash2
);
4500 unsigned hash2
= sxhash (list
, depth
+ 1);
4501 hash
= SXHASH_COMBINE (hash
, hash2
);
4508 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4509 the Lisp structure. */
4512 sxhash_vector (vec
, depth
)
4516 unsigned hash
= ASIZE (vec
);
4519 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4520 for (i
= 0; i
< n
; ++i
)
4522 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4523 hash
= SXHASH_COMBINE (hash
, hash2
);
4530 /* Return a hash for bool-vector VECTOR. */
4533 sxhash_bool_vector (vec
)
4536 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4539 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4540 for (i
= 0; i
< n
; ++i
)
4541 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4547 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4548 structure. Value is an unsigned integer clipped to INTMASK. */
4557 if (depth
> SXHASH_MAX_DEPTH
)
4560 switch (XTYPE (obj
))
4571 obj
= SYMBOL_NAME (obj
);
4575 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4578 /* This can be everything from a vector to an overlay. */
4579 case Lisp_Vectorlike
:
4581 /* According to the CL HyperSpec, two arrays are equal only if
4582 they are `eq', except for strings and bit-vectors. In
4583 Emacs, this works differently. We have to compare element
4585 hash
= sxhash_vector (obj
, depth
);
4586 else if (BOOL_VECTOR_P (obj
))
4587 hash
= sxhash_bool_vector (obj
);
4589 /* Others are `equal' if they are `eq', so let's take their
4595 hash
= sxhash_list (obj
, depth
);
4600 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4601 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4602 for (hash
= 0; p
< e
; ++p
)
4603 hash
= SXHASH_COMBINE (hash
, *p
);
4611 return hash
& INTMASK
;
4616 /***********************************************************************
4618 ***********************************************************************/
4621 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4622 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4626 unsigned hash
= sxhash (obj
, 0);
4627 return make_number (hash
);
4631 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4632 doc
: /* Create and return a new hash table.
4634 Arguments are specified as keyword/argument pairs. The following
4635 arguments are defined:
4637 :test TEST -- TEST must be a symbol that specifies how to compare
4638 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4639 `equal'. User-supplied test and hash functions can be specified via
4640 `define-hash-table-test'.
4642 :size SIZE -- A hint as to how many elements will be put in the table.
4645 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4646 fills up. If REHASH-SIZE is an integer, add that many space. If it
4647 is a float, it must be > 1.0, and the new size is computed by
4648 multiplying the old size with that factor. Default is 1.5.
4650 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4651 Resize the hash table when ratio of the number of entries in the
4652 table. Default is 0.8.
4654 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4655 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4656 returned is a weak table. Key/value pairs are removed from a weak
4657 hash table when there are no non-weak references pointing to their
4658 key, value, one of key or value, or both key and value, depending on
4659 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4662 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4667 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4668 Lisp_Object user_test
, user_hash
;
4672 /* The vector `used' is used to keep track of arguments that
4673 have been consumed. */
4674 used
= (char *) alloca (nargs
* sizeof *used
);
4675 bzero (used
, nargs
* sizeof *used
);
4677 /* See if there's a `:test TEST' among the arguments. */
4678 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4679 test
= i
< 0 ? Qeql
: args
[i
];
4680 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4682 /* See if it is a user-defined test. */
4685 prop
= Fget (test
, Qhash_table_test
);
4686 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4687 signal_error ("Invalid hash table test", test
);
4688 user_test
= XCAR (prop
);
4689 user_hash
= XCAR (XCDR (prop
));
4692 user_test
= user_hash
= Qnil
;
4694 /* See if there's a `:size SIZE' argument. */
4695 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4696 size
= i
< 0 ? Qnil
: args
[i
];
4698 size
= make_number (DEFAULT_HASH_SIZE
);
4699 else if (!INTEGERP (size
) || XINT (size
) < 0)
4700 signal_error ("Invalid hash table size", size
);
4702 /* Look for `:rehash-size SIZE'. */
4703 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4704 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4705 if (!NUMBERP (rehash_size
)
4706 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4707 || XFLOATINT (rehash_size
) <= 1.0)
4708 signal_error ("Invalid hash table rehash size", rehash_size
);
4710 /* Look for `:rehash-threshold THRESHOLD'. */
4711 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4712 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4713 if (!FLOATP (rehash_threshold
)
4714 || XFLOATINT (rehash_threshold
) <= 0.0
4715 || XFLOATINT (rehash_threshold
) > 1.0)
4716 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4718 /* Look for `:weakness WEAK'. */
4719 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4720 weak
= i
< 0 ? Qnil
: args
[i
];
4722 weak
= Qkey_and_value
;
4725 && !EQ (weak
, Qvalue
)
4726 && !EQ (weak
, Qkey_or_value
)
4727 && !EQ (weak
, Qkey_and_value
))
4728 signal_error ("Invalid hash table weakness", weak
);
4730 /* Now, all args should have been used up, or there's a problem. */
4731 for (i
= 0; i
< nargs
; ++i
)
4733 signal_error ("Invalid argument list", args
[i
]);
4735 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4736 user_test
, user_hash
);
4740 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4741 doc
: /* Return a copy of hash table TABLE. */)
4745 return copy_hash_table (check_hash_table (table
));
4749 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4750 doc
: /* Return the number of elements in TABLE. */)
4754 return make_number (check_hash_table (table
)->count
);
4758 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4759 Shash_table_rehash_size
, 1, 1, 0,
4760 doc
: /* Return the current rehash size of TABLE. */)
4764 return check_hash_table (table
)->rehash_size
;
4768 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4769 Shash_table_rehash_threshold
, 1, 1, 0,
4770 doc
: /* Return the current rehash threshold of TABLE. */)
4774 return check_hash_table (table
)->rehash_threshold
;
4778 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4779 doc
: /* Return the size of TABLE.
4780 The size can be used as an argument to `make-hash-table' to create
4781 a hash table than can hold as many elements of TABLE holds
4782 without need for resizing. */)
4786 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4787 return make_number (HASH_TABLE_SIZE (h
));
4791 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4792 doc
: /* Return the test TABLE uses. */)
4796 return check_hash_table (table
)->test
;
4800 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4802 doc
: /* Return the weakness of TABLE. */)
4806 return check_hash_table (table
)->weak
;
4810 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4811 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4815 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4819 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4820 doc
: /* Clear hash table TABLE and return it. */)
4824 hash_clear (check_hash_table (table
));
4825 /* Be compatible with XEmacs. */
4830 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4831 doc
: /* Look up KEY in TABLE and return its associated value.
4832 If KEY is not found, return DFLT which defaults to nil. */)
4834 Lisp_Object key
, table
, dflt
;
4836 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4837 int i
= hash_lookup (h
, key
, NULL
);
4838 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4842 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4843 doc
: /* Associate KEY with VALUE in hash table TABLE.
4844 If KEY is already present in table, replace its current value with
4847 Lisp_Object key
, value
, table
;
4849 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4853 i
= hash_lookup (h
, key
, &hash
);
4855 HASH_VALUE (h
, i
) = value
;
4857 hash_put (h
, key
, value
, hash
);
4863 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4864 doc
: /* Remove KEY from TABLE. */)
4866 Lisp_Object key
, table
;
4868 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4869 hash_remove (h
, key
);
4874 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4875 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4876 FUNCTION is called with two arguments, KEY and VALUE. */)
4878 Lisp_Object function
, table
;
4880 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4881 Lisp_Object args
[3];
4884 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4885 if (!NILP (HASH_HASH (h
, i
)))
4888 args
[1] = HASH_KEY (h
, i
);
4889 args
[2] = HASH_VALUE (h
, i
);
4897 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4898 Sdefine_hash_table_test
, 3, 3, 0,
4899 doc
: /* Define a new hash table test with name NAME, a symbol.
4901 In hash tables created with NAME specified as test, use TEST to
4902 compare keys, and HASH for computing hash codes of keys.
4904 TEST must be a function taking two arguments and returning non-nil if
4905 both arguments are the same. HASH must be a function taking one
4906 argument and return an integer that is the hash code of the argument.
4907 Hash code computation should use the whole value range of integers,
4908 including negative integers. */)
4910 Lisp_Object name
, test
, hash
;
4912 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4917 /************************************************************************
4919 ************************************************************************/
4923 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4924 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4926 A message digest is a cryptographic checksum of a document, and the
4927 algorithm to calculate it is defined in RFC 1321.
4929 The two optional arguments START and END are character positions
4930 specifying for which part of OBJECT the message digest should be
4931 computed. If nil or omitted, the digest is computed for the whole
4934 The MD5 message digest is computed from the result of encoding the
4935 text in a coding system, not directly from the internal Emacs form of
4936 the text. The optional fourth argument CODING-SYSTEM specifies which
4937 coding system to encode the text with. It should be the same coding
4938 system that you used or will use when actually writing the text into a
4941 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4942 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4943 system would be chosen by default for writing this text into a file.
4945 If OBJECT is a string, the most preferred coding system (see the
4946 command `prefer-coding-system') is used.
4948 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4949 guesswork fails. Normally, an error is signaled in such case. */)
4950 (object
, start
, end
, coding_system
, noerror
)
4951 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4953 unsigned char digest
[16];
4954 unsigned char value
[33];
4958 int start_char
= 0, end_char
= 0;
4959 int start_byte
= 0, end_byte
= 0;
4961 register struct buffer
*bp
;
4964 if (STRINGP (object
))
4966 if (NILP (coding_system
))
4968 /* Decide the coding-system to encode the data with. */
4970 if (STRING_MULTIBYTE (object
))
4971 /* use default, we can't guess correct value */
4972 coding_system
= preferred_coding_system ();
4974 coding_system
= Qraw_text
;
4977 if (NILP (Fcoding_system_p (coding_system
)))
4979 /* Invalid coding system. */
4981 if (!NILP (noerror
))
4982 coding_system
= Qraw_text
;
4984 xsignal1 (Qcoding_system_error
, coding_system
);
4987 if (STRING_MULTIBYTE (object
))
4988 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4990 size
= SCHARS (object
);
4991 size_byte
= SBYTES (object
);
4995 CHECK_NUMBER (start
);
4997 start_char
= XINT (start
);
5002 start_byte
= string_char_to_byte (object
, start_char
);
5008 end_byte
= size_byte
;
5014 end_char
= XINT (end
);
5019 end_byte
= string_char_to_byte (object
, end_char
);
5022 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5023 args_out_of_range_3 (object
, make_number (start_char
),
5024 make_number (end_char
));
5028 struct buffer
*prev
= current_buffer
;
5030 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5032 CHECK_BUFFER (object
);
5034 bp
= XBUFFER (object
);
5035 if (bp
!= current_buffer
)
5036 set_buffer_internal (bp
);
5042 CHECK_NUMBER_COERCE_MARKER (start
);
5050 CHECK_NUMBER_COERCE_MARKER (end
);
5055 temp
= b
, b
= e
, e
= temp
;
5057 if (!(BEGV
<= b
&& e
<= ZV
))
5058 args_out_of_range (start
, end
);
5060 if (NILP (coding_system
))
5062 /* Decide the coding-system to encode the data with.
5063 See fileio.c:Fwrite-region */
5065 if (!NILP (Vcoding_system_for_write
))
5066 coding_system
= Vcoding_system_for_write
;
5069 int force_raw_text
= 0;
5071 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5072 if (NILP (coding_system
)
5073 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5075 coding_system
= Qnil
;
5076 if (NILP (current_buffer
->enable_multibyte_characters
))
5080 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5082 /* Check file-coding-system-alist. */
5083 Lisp_Object args
[4], val
;
5085 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5086 args
[3] = Fbuffer_file_name(object
);
5087 val
= Ffind_operation_coding_system (4, args
);
5088 if (CONSP (val
) && !NILP (XCDR (val
)))
5089 coding_system
= XCDR (val
);
5092 if (NILP (coding_system
)
5093 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5095 /* If we still have not decided a coding system, use the
5096 default value of buffer-file-coding-system. */
5097 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5101 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5102 /* Confirm that VAL can surely encode the current region. */
5103 coding_system
= call4 (Vselect_safe_coding_system_function
,
5104 make_number (b
), make_number (e
),
5105 coding_system
, Qnil
);
5108 coding_system
= Qraw_text
;
5111 if (NILP (Fcoding_system_p (coding_system
)))
5113 /* Invalid coding system. */
5115 if (!NILP (noerror
))
5116 coding_system
= Qraw_text
;
5118 xsignal1 (Qcoding_system_error
, coding_system
);
5122 object
= make_buffer_string (b
, e
, 0);
5123 if (prev
!= current_buffer
)
5124 set_buffer_internal (prev
);
5125 /* Discard the unwind protect for recovering the current
5129 if (STRING_MULTIBYTE (object
))
5130 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5133 md5_buffer (SDATA (object
) + start_byte
,
5134 SBYTES (object
) - (size_byte
- end_byte
),
5137 for (i
= 0; i
< 16; i
++)
5138 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5141 return make_string (value
, 32);
5148 /* Hash table stuff. */
5149 Qhash_table_p
= intern ("hash-table-p");
5150 staticpro (&Qhash_table_p
);
5151 Qeq
= intern ("eq");
5153 Qeql
= intern ("eql");
5155 Qequal
= intern ("equal");
5156 staticpro (&Qequal
);
5157 QCtest
= intern (":test");
5158 staticpro (&QCtest
);
5159 QCsize
= intern (":size");
5160 staticpro (&QCsize
);
5161 QCrehash_size
= intern (":rehash-size");
5162 staticpro (&QCrehash_size
);
5163 QCrehash_threshold
= intern (":rehash-threshold");
5164 staticpro (&QCrehash_threshold
);
5165 QCweakness
= intern (":weakness");
5166 staticpro (&QCweakness
);
5167 Qkey
= intern ("key");
5169 Qvalue
= intern ("value");
5170 staticpro (&Qvalue
);
5171 Qhash_table_test
= intern ("hash-table-test");
5172 staticpro (&Qhash_table_test
);
5173 Qkey_or_value
= intern ("key-or-value");
5174 staticpro (&Qkey_or_value
);
5175 Qkey_and_value
= intern ("key-and-value");
5176 staticpro (&Qkey_and_value
);
5179 defsubr (&Smake_hash_table
);
5180 defsubr (&Scopy_hash_table
);
5181 defsubr (&Shash_table_count
);
5182 defsubr (&Shash_table_rehash_size
);
5183 defsubr (&Shash_table_rehash_threshold
);
5184 defsubr (&Shash_table_size
);
5185 defsubr (&Shash_table_test
);
5186 defsubr (&Shash_table_weakness
);
5187 defsubr (&Shash_table_p
);
5188 defsubr (&Sclrhash
);
5189 defsubr (&Sgethash
);
5190 defsubr (&Sputhash
);
5191 defsubr (&Sremhash
);
5192 defsubr (&Smaphash
);
5193 defsubr (&Sdefine_hash_table_test
);
5195 Qstring_lessp
= intern ("string-lessp");
5196 staticpro (&Qstring_lessp
);
5197 Qprovide
= intern ("provide");
5198 staticpro (&Qprovide
);
5199 Qrequire
= intern ("require");
5200 staticpro (&Qrequire
);
5201 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5202 staticpro (&Qyes_or_no_p_history
);
5203 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5204 staticpro (&Qcursor_in_echo_area
);
5205 Qwidget_type
= intern ("widget-type");
5206 staticpro (&Qwidget_type
);
5208 staticpro (&string_char_byte_cache_string
);
5209 string_char_byte_cache_string
= Qnil
;
5211 require_nesting_list
= Qnil
;
5212 staticpro (&require_nesting_list
);
5214 Fset (Qyes_or_no_p_history
, Qnil
);
5216 DEFVAR_LISP ("features", &Vfeatures
,
5217 doc
: /* A list of symbols which are the features of the executing Emacs.
5218 Used by `featurep' and `require', and altered by `provide'. */);
5219 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5220 Qsubfeatures
= intern ("subfeatures");
5221 staticpro (&Qsubfeatures
);
5223 #ifdef HAVE_LANGINFO_CODESET
5224 Qcodeset
= intern ("codeset");
5225 staticpro (&Qcodeset
);
5226 Qdays
= intern ("days");
5228 Qmonths
= intern ("months");
5229 staticpro (&Qmonths
);
5230 Qpaper
= intern ("paper");
5231 staticpro (&Qpaper
);
5232 #endif /* HAVE_LANGINFO_CODESET */
5234 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5235 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5236 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5237 invoked by mouse clicks and mouse menu items. */);
5240 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5241 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5242 This applies to commands from menus and tool bar buttons even when
5243 they are initiated from the keyboard. The value of `use-dialog-box'
5244 takes precedence over this variable, so a file dialog is only used if
5245 both `use-dialog-box' and this variable are non-nil. */);
5246 use_file_dialog
= 1;
5248 defsubr (&Sidentity
);
5251 defsubr (&Ssafe_length
);
5252 defsubr (&Sstring_bytes
);
5253 defsubr (&Sstring_equal
);
5254 defsubr (&Scompare_strings
);
5255 defsubr (&Sstring_lessp
);
5258 defsubr (&Svconcat
);
5259 defsubr (&Scopy_sequence
);
5260 defsubr (&Sstring_make_multibyte
);
5261 defsubr (&Sstring_make_unibyte
);
5262 defsubr (&Sstring_as_multibyte
);
5263 defsubr (&Sstring_as_unibyte
);
5264 defsubr (&Sstring_to_multibyte
);
5265 defsubr (&Sstring_to_unibyte
);
5266 defsubr (&Scopy_alist
);
5267 defsubr (&Ssubstring
);
5268 defsubr (&Ssubstring_no_properties
);
5281 defsubr (&Snreverse
);
5282 defsubr (&Sreverse
);
5284 defsubr (&Splist_get
);
5286 defsubr (&Splist_put
);
5288 defsubr (&Slax_plist_get
);
5289 defsubr (&Slax_plist_put
);
5292 defsubr (&Sequal_including_properties
);
5293 defsubr (&Sfillarray
);
5294 defsubr (&Sclear_string
);
5298 defsubr (&Smapconcat
);
5299 defsubr (&Sy_or_n_p
);
5300 defsubr (&Syes_or_no_p
);
5301 defsubr (&Sload_average
);
5302 defsubr (&Sfeaturep
);
5303 defsubr (&Srequire
);
5304 defsubr (&Sprovide
);
5305 defsubr (&Splist_member
);
5306 defsubr (&Swidget_put
);
5307 defsubr (&Swidget_get
);
5308 defsubr (&Swidget_apply
);
5309 defsubr (&Sbase64_encode_region
);
5310 defsubr (&Sbase64_decode_region
);
5311 defsubr (&Sbase64_encode_string
);
5312 defsubr (&Sbase64_decode_string
);
5314 defsubr (&Slocale_info
);
5323 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5324 (do not change this comment) */