1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008, 2009, 2010
5 Free Software Foundation, Inc.
7 This file is part of GNU Emacs.
9 GNU Emacs is free software: you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation, either version 3 of the License, or
12 (at your option) any later version.
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
37 #include "character.h"
42 #include "intervals.h"
45 #include "blockinput.h"
47 #if defined (HAVE_X_WINDOWS)
50 #endif /* HAVE_MENUS */
53 #define NULL ((POINTER_TYPE *)0)
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 /* Nonzero enables use of a file dialog for file name
61 questions asked by mouse commands. */
64 extern int minibuffer_auto_raise
;
65 extern Lisp_Object minibuf_window
;
66 extern Lisp_Object Vlocale_coding_system
;
67 extern int load_in_progress
;
69 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
70 Lisp_Object Qyes_or_no_p_history
;
71 Lisp_Object Qcursor_in_echo_area
;
72 Lisp_Object Qwidget_type
;
73 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
75 extern Lisp_Object Qinput_method_function
;
77 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
79 extern long get_random ();
80 extern void seed_random
P_ ((long));
86 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
87 doc
: /* Return the argument unchanged. */)
94 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
95 doc
: /* Return a pseudo-random number.
96 All integers representable in Lisp are equally likely.
97 On most systems, this is 29 bits' worth.
98 With positive integer LIMIT, return random number in interval [0,LIMIT).
99 With argument t, set the random number seed from the current time and pid.
100 Other values of LIMIT are ignored. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (limit
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
144 if (STRINGP (sequence
))
145 XSETFASTINT (val
, SCHARS (sequence
));
146 else if (VECTORP (sequence
))
147 XSETFASTINT (val
, ASIZE (sequence
));
148 else if (CHAR_TABLE_P (sequence
))
149 XSETFASTINT (val
, MAX_CHAR
);
150 else if (BOOL_VECTOR_P (sequence
))
151 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
152 else if (COMPILEDP (sequence
))
153 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
154 else if (CONSP (sequence
))
157 while (CONSP (sequence
))
159 sequence
= XCDR (sequence
);
162 if (!CONSP (sequence
))
165 sequence
= XCDR (sequence
);
170 CHECK_LIST_END (sequence
, sequence
);
172 val
= make_number (i
);
174 else if (NILP (sequence
))
175 XSETFASTINT (val
, 0);
177 wrong_type_argument (Qsequencep
, sequence
);
182 /* This does not check for quits. That is safe since it must terminate. */
184 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
185 doc
: /* Return the length of a list, but avoid error or infinite loop.
186 This function never gets an error. If LIST is not really a list,
187 it returns 0. If LIST is circular, it returns a finite value
188 which is at least the number of distinct elements. */)
192 Lisp_Object tail
, halftail
, length
;
195 /* halftail is used to detect circular lists. */
197 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
199 if (EQ (tail
, halftail
) && len
!= 0)
203 halftail
= XCDR (halftail
);
206 XSETINT (length
, len
);
210 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
211 doc
: /* Return the number of bytes in STRING.
212 If STRING is multibyte, this may be greater than the length of STRING. */)
216 CHECK_STRING (string
);
217 return make_number (SBYTES (string
));
220 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
221 doc
: /* Return t if two strings have identical contents.
222 Case is significant, but text properties are ignored.
223 Symbols are also allowed; their print names are used instead. */)
225 register Lisp_Object s1
, s2
;
228 s1
= SYMBOL_NAME (s1
);
230 s2
= SYMBOL_NAME (s2
);
234 if (SCHARS (s1
) != SCHARS (s2
)
235 || SBYTES (s1
) != SBYTES (s2
)
236 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
241 DEFUN ("compare-strings", Fcompare_strings
,
242 Scompare_strings
, 6, 7, 0,
243 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
244 In string STR1, skip the first START1 characters and stop at END1.
245 In string STR2, skip the first START2 characters and stop at END2.
246 END1 and END2 default to the full lengths of the respective strings.
248 Case is significant in this comparison if IGNORE-CASE is nil.
249 Unibyte strings are converted to multibyte for comparison.
251 The value is t if the strings (or specified portions) match.
252 If string STR1 is less, the value is a negative number N;
253 - 1 - N is the number of characters that match at the beginning.
254 If string STR1 is greater, the value is a positive number N;
255 N - 1 is the number of characters that match at the beginning. */)
256 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
257 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
259 register int end1_char
, end2_char
;
260 register int i1
, i1_byte
, i2
, i2_byte
;
265 start1
= make_number (0);
267 start2
= make_number (0);
268 CHECK_NATNUM (start1
);
269 CHECK_NATNUM (start2
);
278 i1_byte
= string_char_to_byte (str1
, i1
);
279 i2_byte
= string_char_to_byte (str2
, i2
);
281 end1_char
= SCHARS (str1
);
282 if (! NILP (end1
) && end1_char
> XINT (end1
))
283 end1_char
= XINT (end1
);
285 end2_char
= SCHARS (str2
);
286 if (! NILP (end2
) && end2_char
> XINT (end2
))
287 end2_char
= XINT (end2
);
289 while (i1
< end1_char
&& i2
< end2_char
)
291 /* When we find a mismatch, we must compare the
292 characters, not just the bytes. */
295 if (STRING_MULTIBYTE (str1
))
296 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
299 c1
= SREF (str1
, i1
++);
300 MAKE_CHAR_MULTIBYTE (c1
);
303 if (STRING_MULTIBYTE (str2
))
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
307 c2
= SREF (str2
, i2
++);
308 MAKE_CHAR_MULTIBYTE (c2
);
314 if (! NILP (ignore_case
))
318 tem
= Fupcase (make_number (c1
));
320 tem
= Fupcase (make_number (c2
));
327 /* Note that I1 has already been incremented
328 past the character that we are comparing;
329 hence we don't add or subtract 1 here. */
331 return make_number (- i1
+ XINT (start1
));
333 return make_number (i1
- XINT (start1
));
337 return make_number (i1
- XINT (start1
) + 1);
339 return make_number (- i1
+ XINT (start1
) - 1);
344 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
345 doc
: /* Return t if first arg string is less than second in lexicographic order.
347 Symbols are also allowed; their print names are used instead. */)
349 register Lisp_Object s1
, s2
;
352 register int i1
, i1_byte
, i2
, i2_byte
;
355 s1
= SYMBOL_NAME (s1
);
357 s2
= SYMBOL_NAME (s2
);
361 i1
= i1_byte
= i2
= i2_byte
= 0;
364 if (end
> SCHARS (s2
))
369 /* When we find a mismatch, we must compare the
370 characters, not just the bytes. */
373 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
374 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
377 return c1
< c2
? Qt
: Qnil
;
379 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
383 /* "gcc -O3" enables automatic function inlining, which optimizes out
384 the arguments for the invocations of this function, whereas it
385 expects these values on the stack. */
386 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
387 #else /* !__GNUC__ */
388 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
399 return concat (2, args
, Lisp_String
, 0);
405 Lisp_Object s1
, s2
, s3
;
411 return concat (3, args
, Lisp_String
, 0);
414 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
415 doc
: /* Concatenate all the arguments and make the result a list.
416 The result is a list whose elements are the elements of all the arguments.
417 Each argument may be a list, vector or string.
418 The last argument is not copied, just used as the tail of the new list.
419 usage: (append &rest SEQUENCES) */)
424 return concat (nargs
, args
, Lisp_Cons
, 1);
427 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
428 doc
: /* Concatenate all the arguments and make the result a string.
429 The result is a string whose elements are the elements of all the arguments.
430 Each argument may be a string or a list or vector of characters (integers).
431 usage: (concat &rest SEQUENCES) */)
436 return concat (nargs
, args
, Lisp_String
, 0);
439 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
440 doc
: /* Concatenate all the arguments and make the result a vector.
441 The result is a vector whose elements are the elements of all the arguments.
442 Each argument may be a list, vector or string.
443 usage: (vconcat &rest SEQUENCES) */)
448 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
452 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
453 doc
: /* Return a copy of a list, vector, string or char-table.
454 The elements of a list or vector are not copied; they are shared
455 with the original. */)
459 if (NILP (arg
)) return arg
;
461 if (CHAR_TABLE_P (arg
))
463 return copy_char_table (arg
);
466 if (BOOL_VECTOR_P (arg
))
470 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
471 / BOOL_VECTOR_BITS_PER_CHAR
);
473 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
474 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
479 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
480 wrong_type_argument (Qsequencep
, arg
);
482 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
485 /* This structure holds information of an argument of `concat' that is
486 a string and has text properties to be copied. */
489 int argnum
; /* refer to ARGS (arguments of `concat') */
490 int from
; /* refer to ARGS[argnum] (argument string) */
491 int to
; /* refer to VAL (the target string) */
495 concat (nargs
, args
, target_type
, last_special
)
498 enum Lisp_Type target_type
;
502 register Lisp_Object tail
;
503 register Lisp_Object
this;
505 int toindex_byte
= 0;
506 register int result_len
;
507 register int result_len_byte
;
509 Lisp_Object last_tail
;
512 /* When we make a multibyte string, we can't copy text properties
513 while concatinating each string because the length of resulting
514 string can't be decided until we finish the whole concatination.
515 So, we record strings that have text properties to be copied
516 here, and copy the text properties after the concatination. */
517 struct textprop_rec
*textprops
= NULL
;
518 /* Number of elements in textprops. */
519 int num_textprops
= 0;
524 /* In append, the last arg isn't treated like the others */
525 if (last_special
&& nargs
> 0)
528 last_tail
= args
[nargs
];
533 /* Check each argument. */
534 for (argnum
= 0; argnum
< nargs
; argnum
++)
537 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
538 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
539 wrong_type_argument (Qsequencep
, this);
542 /* Compute total length in chars of arguments in RESULT_LEN.
543 If desired output is a string, also compute length in bytes
544 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
545 whether the result should be a multibyte string. */
549 for (argnum
= 0; argnum
< nargs
; argnum
++)
553 len
= XFASTINT (Flength (this));
554 if (target_type
== Lisp_String
)
556 /* We must count the number of bytes needed in the string
557 as well as the number of characters. */
563 for (i
= 0; i
< len
; i
++)
566 CHECK_CHARACTER (ch
);
567 this_len_byte
= CHAR_BYTES (XINT (ch
));
568 result_len_byte
+= this_len_byte
;
569 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
572 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
573 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
574 else if (CONSP (this))
575 for (; CONSP (this); this = XCDR (this))
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 (STRINGP (this))
586 if (STRING_MULTIBYTE (this))
589 result_len_byte
+= SBYTES (this);
592 result_len_byte
+= count_size_as_multibyte (SDATA (this),
599 error ("String overflow");
602 if (! some_multibyte
)
603 result_len_byte
= result_len
;
605 /* Create the output object. */
606 if (target_type
== Lisp_Cons
)
607 val
= Fmake_list (make_number (result_len
), Qnil
);
608 else if (target_type
== Lisp_Vectorlike
)
609 val
= Fmake_vector (make_number (result_len
), Qnil
);
610 else if (some_multibyte
)
611 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
613 val
= make_uninit_string (result_len
);
615 /* In `append', if all but last arg are nil, return last arg. */
616 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
619 /* Copy the contents of the args into the result. */
621 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
623 toindex
= 0, toindex_byte
= 0;
627 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
629 for (argnum
= 0; argnum
< nargs
; argnum
++)
633 register unsigned int thisindex
= 0;
634 register unsigned int thisindex_byte
= 0;
638 thislen
= Flength (this), thisleni
= XINT (thislen
);
640 /* Between strings of the same kind, copy fast. */
641 if (STRINGP (this) && STRINGP (val
)
642 && STRING_MULTIBYTE (this) == some_multibyte
)
644 int thislen_byte
= SBYTES (this);
646 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
648 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
650 textprops
[num_textprops
].argnum
= argnum
;
651 textprops
[num_textprops
].from
= 0;
652 textprops
[num_textprops
++].to
= toindex
;
654 toindex_byte
+= thislen_byte
;
657 /* Copy a single-byte string to a multibyte string. */
658 else if (STRINGP (this) && STRINGP (val
))
660 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
662 textprops
[num_textprops
].argnum
= argnum
;
663 textprops
[num_textprops
].from
= 0;
664 textprops
[num_textprops
++].to
= toindex
;
666 toindex_byte
+= copy_text (SDATA (this),
667 SDATA (val
) + toindex_byte
,
668 SCHARS (this), 0, 1);
672 /* Copy element by element. */
675 register Lisp_Object elt
;
677 /* Fetch next element of `this' arg into `elt', or break if
678 `this' is exhausted. */
679 if (NILP (this)) break;
681 elt
= XCAR (this), this = XCDR (this);
682 else if (thisindex
>= thisleni
)
684 else if (STRINGP (this))
687 if (STRING_MULTIBYTE (this))
689 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
692 XSETFASTINT (elt
, c
);
696 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
698 && !ASCII_CHAR_P (XINT (elt
))
699 && XINT (elt
) < 0400)
701 c
= BYTE8_TO_CHAR (XINT (elt
));
706 else if (BOOL_VECTOR_P (this))
709 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
710 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
718 elt
= AREF (this, thisindex
);
722 /* Store this element into the result. */
729 else if (VECTORP (val
))
731 ASET (val
, toindex
, elt
);
738 toindex_byte
+= CHAR_STRING (XINT (elt
),
739 SDATA (val
) + toindex_byte
);
741 SSET (val
, toindex_byte
++, XINT (elt
));
747 XSETCDR (prev
, last_tail
);
749 if (num_textprops
> 0)
752 int last_to_end
= -1;
754 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
756 this = args
[textprops
[argnum
].argnum
];
757 props
= text_property_list (this,
759 make_number (SCHARS (this)),
761 /* If successive arguments have properites, be sure that the
762 value of `composition' property be the copy. */
763 if (last_to_end
== textprops
[argnum
].to
)
764 make_composition_value_copy (props
);
765 add_text_properties_from_list (val
, props
,
766 make_number (textprops
[argnum
].to
));
767 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
775 static Lisp_Object string_char_byte_cache_string
;
776 static EMACS_INT string_char_byte_cache_charpos
;
777 static EMACS_INT string_char_byte_cache_bytepos
;
780 clear_string_char_byte_cache ()
782 string_char_byte_cache_string
= Qnil
;
785 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
788 string_char_to_byte (string
, char_index
)
790 EMACS_INT char_index
;
793 EMACS_INT best_below
, best_below_byte
;
794 EMACS_INT best_above
, best_above_byte
;
796 best_below
= best_below_byte
= 0;
797 best_above
= SCHARS (string
);
798 best_above_byte
= SBYTES (string
);
799 if (best_above
== best_above_byte
)
802 if (EQ (string
, string_char_byte_cache_string
))
804 if (string_char_byte_cache_charpos
< char_index
)
806 best_below
= string_char_byte_cache_charpos
;
807 best_below_byte
= string_char_byte_cache_bytepos
;
811 best_above
= string_char_byte_cache_charpos
;
812 best_above_byte
= string_char_byte_cache_bytepos
;
816 if (char_index
- best_below
< best_above
- char_index
)
818 unsigned char *p
= SDATA (string
) + best_below_byte
;
820 while (best_below
< char_index
)
822 p
+= BYTES_BY_CHAR_HEAD (*p
);
825 i_byte
= p
- SDATA (string
);
829 unsigned char *p
= SDATA (string
) + best_above_byte
;
831 while (best_above
> char_index
)
834 while (!CHAR_HEAD_P (*p
)) p
--;
837 i_byte
= p
- SDATA (string
);
840 string_char_byte_cache_bytepos
= i_byte
;
841 string_char_byte_cache_charpos
= char_index
;
842 string_char_byte_cache_string
= string
;
847 /* Return the character index corresponding to BYTE_INDEX in STRING. */
850 string_byte_to_char (string
, byte_index
)
852 EMACS_INT byte_index
;
855 EMACS_INT best_below
, best_below_byte
;
856 EMACS_INT best_above
, best_above_byte
;
858 best_below
= best_below_byte
= 0;
859 best_above
= SCHARS (string
);
860 best_above_byte
= SBYTES (string
);
861 if (best_above
== best_above_byte
)
864 if (EQ (string
, string_char_byte_cache_string
))
866 if (string_char_byte_cache_bytepos
< byte_index
)
868 best_below
= string_char_byte_cache_charpos
;
869 best_below_byte
= string_char_byte_cache_bytepos
;
873 best_above
= string_char_byte_cache_charpos
;
874 best_above_byte
= string_char_byte_cache_bytepos
;
878 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
880 unsigned char *p
= SDATA (string
) + best_below_byte
;
881 unsigned char *pend
= SDATA (string
) + byte_index
;
885 p
+= BYTES_BY_CHAR_HEAD (*p
);
889 i_byte
= p
- SDATA (string
);
893 unsigned char *p
= SDATA (string
) + best_above_byte
;
894 unsigned char *pbeg
= SDATA (string
) + byte_index
;
899 while (!CHAR_HEAD_P (*p
)) p
--;
903 i_byte
= p
- SDATA (string
);
906 string_char_byte_cache_bytepos
= i_byte
;
907 string_char_byte_cache_charpos
= i
;
908 string_char_byte_cache_string
= string
;
913 /* Convert STRING to a multibyte string. */
916 string_make_multibyte (string
)
924 if (STRING_MULTIBYTE (string
))
927 nbytes
= count_size_as_multibyte (SDATA (string
),
929 /* If all the chars are ASCII, they won't need any more bytes
930 once converted. In that case, we can return STRING itself. */
931 if (nbytes
== SBYTES (string
))
934 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
935 copy_text (SDATA (string
), buf
, SBYTES (string
),
938 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
945 /* Convert STRING (if unibyte) to a multibyte string without changing
946 the number of characters. Characters 0200 trough 0237 are
947 converted to eight-bit characters. */
950 string_to_multibyte (string
)
958 if (STRING_MULTIBYTE (string
))
961 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
962 /* If all the chars are ASCII, they won't need any more bytes once
964 if (nbytes
== SBYTES (string
))
965 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
967 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
968 bcopy (SDATA (string
), buf
, SBYTES (string
));
969 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
971 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
978 /* Convert STRING to a single-byte string. */
981 string_make_unibyte (string
)
989 if (! STRING_MULTIBYTE (string
))
992 nchars
= SCHARS (string
);
994 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
995 copy_text (SDATA (string
), buf
, SBYTES (string
),
998 ret
= make_unibyte_string (buf
, nchars
);
1004 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1006 doc
: /* Return the multibyte equivalent of STRING.
1007 If STRING is unibyte and contains non-ASCII characters, the function
1008 `unibyte-char-to-multibyte' is used to convert each unibyte character
1009 to a multibyte character. In this case, the returned string is a
1010 newly created string with no text properties. If STRING is multibyte
1011 or entirely ASCII, it is returned unchanged. In particular, when
1012 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1013 \(When the characters are all ASCII, Emacs primitives will treat the
1014 string the same way whether it is unibyte or multibyte.) */)
1018 CHECK_STRING (string
);
1020 return string_make_multibyte (string
);
1023 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1025 doc
: /* Return the unibyte equivalent of STRING.
1026 Multibyte character codes are converted to unibyte according to
1027 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1028 If the lookup in the translation table fails, this function takes just
1029 the low 8 bits of each character. */)
1033 CHECK_STRING (string
);
1035 return string_make_unibyte (string
);
1038 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1040 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1041 If STRING is unibyte, the result is STRING itself.
1042 Otherwise it is a newly created string, with no text properties.
1043 If STRING is multibyte and contains a character of charset
1044 `eight-bit', it is converted to the corresponding single byte. */)
1048 CHECK_STRING (string
);
1050 if (STRING_MULTIBYTE (string
))
1052 int bytes
= SBYTES (string
);
1053 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1055 bcopy (SDATA (string
), str
, bytes
);
1056 bytes
= str_as_unibyte (str
, bytes
);
1057 string
= make_unibyte_string (str
, bytes
);
1063 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1065 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1066 If STRING is multibyte, the result is STRING itself.
1067 Otherwise it is a newly created string, with no text properties.
1069 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1070 part of a correct utf-8 sequence), it is converted to the corresponding
1071 multibyte character of charset `eight-bit'.
1072 See also `string-to-multibyte'.
1074 Beware, this often doesn't really do what you think it does.
1075 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1076 If you're not sure, whether to use `string-as-multibyte' or
1077 `string-to-multibyte', use `string-to-multibyte'. */)
1081 CHECK_STRING (string
);
1083 if (! STRING_MULTIBYTE (string
))
1085 Lisp_Object new_string
;
1088 parse_str_as_multibyte (SDATA (string
),
1091 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1092 bcopy (SDATA (string
), SDATA (new_string
),
1094 if (nbytes
!= SBYTES (string
))
1095 str_as_multibyte (SDATA (new_string
), nbytes
,
1096 SBYTES (string
), NULL
);
1097 string
= new_string
;
1098 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1103 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1105 doc
: /* Return a multibyte string with the same individual chars as STRING.
1106 If STRING is multibyte, the result is STRING itself.
1107 Otherwise it is a newly created string, with no text properties.
1109 If STRING is unibyte and contains an 8-bit byte, it is converted to
1110 the corresponding multibyte character of charset `eight-bit'.
1112 This differs from `string-as-multibyte' by converting each byte of a correct
1113 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1114 correct sequence. */)
1118 CHECK_STRING (string
);
1120 return string_to_multibyte (string
);
1123 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1125 doc
: /* Return a unibyte string with the same individual chars as STRING.
1126 If STRING is unibyte, the result is STRING itself.
1127 Otherwise it is a newly created string, with no text properties,
1128 where each `eight-bit' character is converted to the corresponding byte.
1129 If STRING contains a non-ASCII, non-`eight-bit' character,
1130 an error is signaled. */)
1134 CHECK_STRING (string
);
1136 if (STRING_MULTIBYTE (string
))
1138 EMACS_INT chars
= SCHARS (string
);
1139 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1140 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1142 if (converted
< chars
)
1143 error ("Can't convert the %dth character to unibyte", converted
);
1144 string
= make_unibyte_string (str
, chars
);
1151 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1152 doc
: /* Return a copy of ALIST.
1153 This is an alist which represents the same mapping from objects to objects,
1154 but does not share the alist structure with ALIST.
1155 The objects mapped (cars and cdrs of elements of the alist)
1156 are shared, however.
1157 Elements of ALIST that are not conses are also shared. */)
1161 register Lisp_Object tem
;
1166 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1167 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1169 register Lisp_Object car
;
1173 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1178 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1179 doc
: /* Return a new string whose contents are a substring of STRING.
1180 The returned string consists of the characters between index FROM
1181 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1182 zero-indexed: 0 means the first character of STRING. Negative values
1183 are counted from the end of STRING. If TO is nil, the substring runs
1184 to the end of STRING.
1186 The STRING argument may also be a vector. In that case, the return
1187 value is a new vector that contains the elements between index FROM
1188 \(inclusive) and index TO (exclusive) of that vector argument. */)
1191 register Lisp_Object from
, to
;
1196 int from_char
, to_char
;
1197 int from_byte
= 0, to_byte
= 0;
1199 CHECK_VECTOR_OR_STRING (string
);
1200 CHECK_NUMBER (from
);
1202 if (STRINGP (string
))
1204 size
= SCHARS (string
);
1205 size_byte
= SBYTES (string
);
1208 size
= ASIZE (string
);
1213 to_byte
= size_byte
;
1219 to_char
= XINT (to
);
1223 if (STRINGP (string
))
1224 to_byte
= string_char_to_byte (string
, to_char
);
1227 from_char
= XINT (from
);
1230 if (STRINGP (string
))
1231 from_byte
= string_char_to_byte (string
, from_char
);
1233 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1234 args_out_of_range_3 (string
, make_number (from_char
),
1235 make_number (to_char
));
1237 if (STRINGP (string
))
1239 res
= make_specified_string (SDATA (string
) + from_byte
,
1240 to_char
- from_char
, to_byte
- from_byte
,
1241 STRING_MULTIBYTE (string
));
1242 copy_text_properties (make_number (from_char
), make_number (to_char
),
1243 string
, make_number (0), res
, Qnil
);
1246 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1252 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1253 doc
: /* Return a substring of STRING, without text properties.
1254 It starts at index FROM and ending before TO.
1255 TO may be nil or omitted; then the substring runs to the end of STRING.
1256 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1257 If FROM or TO is negative, it counts from the end.
1259 With one argument, just copy STRING without its properties. */)
1262 register Lisp_Object from
, to
;
1264 int size
, size_byte
;
1265 int from_char
, to_char
;
1266 int from_byte
, to_byte
;
1268 CHECK_STRING (string
);
1270 size
= SCHARS (string
);
1271 size_byte
= SBYTES (string
);
1274 from_char
= from_byte
= 0;
1277 CHECK_NUMBER (from
);
1278 from_char
= XINT (from
);
1282 from_byte
= string_char_to_byte (string
, from_char
);
1288 to_byte
= size_byte
;
1294 to_char
= XINT (to
);
1298 to_byte
= string_char_to_byte (string
, to_char
);
1301 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1302 args_out_of_range_3 (string
, make_number (from_char
),
1303 make_number (to_char
));
1305 return make_specified_string (SDATA (string
) + from_byte
,
1306 to_char
- from_char
, to_byte
- from_byte
,
1307 STRING_MULTIBYTE (string
));
1310 /* Extract a substring of STRING, giving start and end positions
1311 both in characters and in bytes. */
1314 substring_both (string
, from
, from_byte
, to
, to_byte
)
1316 int from
, from_byte
, to
, to_byte
;
1322 CHECK_VECTOR_OR_STRING (string
);
1324 if (STRINGP (string
))
1326 size
= SCHARS (string
);
1327 size_byte
= SBYTES (string
);
1330 size
= ASIZE (string
);
1332 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1333 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1335 if (STRINGP (string
))
1337 res
= make_specified_string (SDATA (string
) + from_byte
,
1338 to
- from
, to_byte
- from_byte
,
1339 STRING_MULTIBYTE (string
));
1340 copy_text_properties (make_number (from
), make_number (to
),
1341 string
, make_number (0), res
, Qnil
);
1344 res
= Fvector (to
- from
, &AREF (string
, from
));
1349 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1350 doc
: /* Take cdr N times on LIST, returns the result. */)
1353 register Lisp_Object list
;
1355 register int i
, num
;
1358 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1361 CHECK_LIST_CONS (list
, list
);
1367 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1368 doc
: /* Return the Nth element of LIST.
1369 N counts from zero. If LIST is not that long, nil is returned. */)
1371 Lisp_Object n
, list
;
1373 return Fcar (Fnthcdr (n
, list
));
1376 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1377 doc
: /* Return element of SEQUENCE at index N. */)
1379 register Lisp_Object sequence
, n
;
1382 if (CONSP (sequence
) || NILP (sequence
))
1383 return Fcar (Fnthcdr (n
, sequence
));
1385 /* Faref signals a "not array" error, so check here. */
1386 CHECK_ARRAY (sequence
, Qsequencep
);
1387 return Faref (sequence
, n
);
1390 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1391 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1392 The value is actually the tail of LIST whose car is ELT. */)
1394 register Lisp_Object elt
;
1397 register Lisp_Object tail
;
1398 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1400 register Lisp_Object tem
;
1401 CHECK_LIST_CONS (tail
, list
);
1403 if (! NILP (Fequal (elt
, tem
)))
1410 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1411 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1412 The value is actually the tail of LIST whose car is ELT. */)
1414 register Lisp_Object elt
, list
;
1418 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1422 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1426 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1437 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1438 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1439 The value is actually the tail of LIST whose car is ELT. */)
1441 register Lisp_Object elt
;
1444 register Lisp_Object tail
;
1447 return Fmemq (elt
, list
);
1449 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1451 register Lisp_Object tem
;
1452 CHECK_LIST_CONS (tail
, list
);
1454 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1461 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1462 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1463 The value is actually the first element of LIST whose car is KEY.
1464 Elements of LIST that are not conses are ignored. */)
1466 Lisp_Object key
, list
;
1471 || (CONSP (XCAR (list
))
1472 && EQ (XCAR (XCAR (list
)), key
)))
1477 || (CONSP (XCAR (list
))
1478 && EQ (XCAR (XCAR (list
)), key
)))
1483 || (CONSP (XCAR (list
))
1484 && EQ (XCAR (XCAR (list
)), key
)))
1494 /* Like Fassq but never report an error and do not allow quits.
1495 Use only on lists known never to be circular. */
1498 assq_no_quit (key
, list
)
1499 Lisp_Object key
, list
;
1502 && (!CONSP (XCAR (list
))
1503 || !EQ (XCAR (XCAR (list
)), key
)))
1506 return CAR_SAFE (list
);
1509 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1510 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1511 The value is actually the first element of LIST whose car equals KEY. */)
1513 Lisp_Object key
, list
;
1520 || (CONSP (XCAR (list
))
1521 && (car
= XCAR (XCAR (list
)),
1522 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1527 || (CONSP (XCAR (list
))
1528 && (car
= XCAR (XCAR (list
)),
1529 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1534 || (CONSP (XCAR (list
))
1535 && (car
= XCAR (XCAR (list
)),
1536 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1546 /* Like Fassoc but never report an error and do not allow quits.
1547 Use only on lists known never to be circular. */
1550 assoc_no_quit (key
, list
)
1551 Lisp_Object key
, list
;
1554 && (!CONSP (XCAR (list
))
1555 || (!EQ (XCAR (XCAR (list
)), key
)
1556 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1559 return CONSP (list
) ? XCAR (list
) : Qnil
;
1562 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1563 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1564 The value is actually the first element of LIST whose cdr is KEY. */)
1566 register Lisp_Object key
;
1572 || (CONSP (XCAR (list
))
1573 && EQ (XCDR (XCAR (list
)), key
)))
1578 || (CONSP (XCAR (list
))
1579 && EQ (XCDR (XCAR (list
)), key
)))
1584 || (CONSP (XCAR (list
))
1585 && EQ (XCDR (XCAR (list
)), key
)))
1595 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1596 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1597 The value is actually the first element of LIST whose cdr equals KEY. */)
1599 Lisp_Object key
, list
;
1606 || (CONSP (XCAR (list
))
1607 && (cdr
= XCDR (XCAR (list
)),
1608 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1613 || (CONSP (XCAR (list
))
1614 && (cdr
= XCDR (XCAR (list
)),
1615 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1620 || (CONSP (XCAR (list
))
1621 && (cdr
= XCDR (XCAR (list
)),
1622 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1632 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1633 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1634 The modified LIST is returned. Comparison is done with `eq'.
1635 If the first member of LIST is ELT, there is no way to remove it by side effect;
1636 therefore, write `(setq foo (delq element foo))'
1637 to be sure of changing the value of `foo'. */)
1639 register Lisp_Object elt
;
1642 register Lisp_Object tail
, prev
;
1643 register Lisp_Object tem
;
1647 while (!NILP (tail
))
1649 CHECK_LIST_CONS (tail
, list
);
1656 Fsetcdr (prev
, XCDR (tail
));
1666 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1667 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1668 SEQ must be a list, a vector, or a string.
1669 The modified SEQ is returned. Comparison is done with `equal'.
1670 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1671 is not a side effect; it is simply using a different sequence.
1672 Therefore, write `(setq foo (delete element foo))'
1673 to be sure of changing the value of `foo'. */)
1675 Lisp_Object elt
, seq
;
1681 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1682 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1685 if (n
!= ASIZE (seq
))
1687 struct Lisp_Vector
*p
= allocate_vector (n
);
1689 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1690 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1691 p
->contents
[n
++] = AREF (seq
, i
);
1693 XSETVECTOR (seq
, p
);
1696 else if (STRINGP (seq
))
1698 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1701 for (i
= nchars
= nbytes
= ibyte
= 0;
1703 ++i
, ibyte
+= cbytes
)
1705 if (STRING_MULTIBYTE (seq
))
1707 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1708 cbytes
= CHAR_BYTES (c
);
1716 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1723 if (nchars
!= SCHARS (seq
))
1727 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1728 if (!STRING_MULTIBYTE (seq
))
1729 STRING_SET_UNIBYTE (tem
);
1731 for (i
= nchars
= nbytes
= ibyte
= 0;
1733 ++i
, ibyte
+= cbytes
)
1735 if (STRING_MULTIBYTE (seq
))
1737 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1738 cbytes
= CHAR_BYTES (c
);
1746 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1748 unsigned char *from
= SDATA (seq
) + ibyte
;
1749 unsigned char *to
= SDATA (tem
) + nbytes
;
1755 for (n
= cbytes
; n
--; )
1765 Lisp_Object tail
, prev
;
1767 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1769 CHECK_LIST_CONS (tail
, seq
);
1771 if (!NILP (Fequal (elt
, XCAR (tail
))))
1776 Fsetcdr (prev
, XCDR (tail
));
1787 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1788 doc
: /* Reverse LIST by modifying cdr pointers.
1789 Return the reversed list. */)
1793 register Lisp_Object prev
, tail
, next
;
1795 if (NILP (list
)) return list
;
1798 while (!NILP (tail
))
1801 CHECK_LIST_CONS (tail
, list
);
1803 Fsetcdr (tail
, prev
);
1810 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1811 doc
: /* Reverse LIST, copying. Return the reversed list.
1812 See also the function `nreverse', which is used more often. */)
1818 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1821 new = Fcons (XCAR (list
), new);
1823 CHECK_LIST_END (list
, list
);
1827 Lisp_Object
merge ();
1829 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1830 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1831 Returns the sorted list. LIST is modified by side effects.
1832 PREDICATE is called with two elements of LIST, and should return non-nil
1833 if the first element should sort before the second. */)
1835 Lisp_Object list
, predicate
;
1837 Lisp_Object front
, back
;
1838 register Lisp_Object len
, tem
;
1839 struct gcpro gcpro1
, gcpro2
;
1840 register int length
;
1843 len
= Flength (list
);
1844 length
= XINT (len
);
1848 XSETINT (len
, (length
/ 2) - 1);
1849 tem
= Fnthcdr (len
, list
);
1851 Fsetcdr (tem
, Qnil
);
1853 GCPRO2 (front
, back
);
1854 front
= Fsort (front
, predicate
);
1855 back
= Fsort (back
, predicate
);
1857 return merge (front
, back
, predicate
);
1861 merge (org_l1
, org_l2
, pred
)
1862 Lisp_Object org_l1
, org_l2
;
1866 register Lisp_Object tail
;
1868 register Lisp_Object l1
, l2
;
1869 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1876 /* It is sufficient to protect org_l1 and org_l2.
1877 When l1 and l2 are updated, we copy the new values
1878 back into the org_ vars. */
1879 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1899 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1915 Fsetcdr (tail
, tem
);
1921 /* This does not check for quits. That is safe since it must terminate. */
1923 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1924 doc
: /* Extract a value from a property list.
1925 PLIST is a property list, which is a list of the form
1926 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1927 corresponding to the given PROP, or nil if PROP is not one of the
1928 properties on the list. This function never signals an error. */)
1933 Lisp_Object tail
, halftail
;
1935 /* halftail is used to detect circular lists. */
1936 tail
= halftail
= plist
;
1937 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1939 if (EQ (prop
, XCAR (tail
)))
1940 return XCAR (XCDR (tail
));
1942 tail
= XCDR (XCDR (tail
));
1943 halftail
= XCDR (halftail
);
1944 if (EQ (tail
, halftail
))
1947 #if 0 /* Unsafe version. */
1948 /* This function can be called asynchronously
1949 (setup_coding_system). Don't QUIT in that case. */
1950 if (!interrupt_input_blocked
)
1958 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1959 doc
: /* Return the value of SYMBOL's PROPNAME property.
1960 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1962 Lisp_Object symbol
, propname
;
1964 CHECK_SYMBOL (symbol
);
1965 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1968 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1969 doc
: /* Change value in PLIST of PROP to VAL.
1970 PLIST is a property list, which is a list of the form
1971 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1972 If PROP is already a property on the list, its value is set to VAL,
1973 otherwise the new PROP VAL pair is added. The new plist is returned;
1974 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1975 The PLIST is modified by side effects. */)
1978 register Lisp_Object prop
;
1981 register Lisp_Object tail
, prev
;
1982 Lisp_Object newcell
;
1984 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1985 tail
= XCDR (XCDR (tail
)))
1987 if (EQ (prop
, XCAR (tail
)))
1989 Fsetcar (XCDR (tail
), val
);
1996 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2000 Fsetcdr (XCDR (prev
), newcell
);
2004 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2005 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2006 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2007 (symbol
, propname
, value
)
2008 Lisp_Object symbol
, propname
, value
;
2010 CHECK_SYMBOL (symbol
);
2011 XSYMBOL (symbol
)->plist
2012 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2016 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2017 doc
: /* Extract a value from a property list, comparing with `equal'.
2018 PLIST is a property list, which is a list of the form
2019 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2020 corresponding to the given PROP, or nil if PROP is not
2021 one of the properties on the list. */)
2029 CONSP (tail
) && CONSP (XCDR (tail
));
2030 tail
= XCDR (XCDR (tail
)))
2032 if (! NILP (Fequal (prop
, XCAR (tail
))))
2033 return XCAR (XCDR (tail
));
2038 CHECK_LIST_END (tail
, prop
);
2043 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2044 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2045 PLIST is a property list, which is a list of the form
2046 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2047 If PROP is already a property on the list, its value is set to VAL,
2048 otherwise the new PROP VAL pair is added. The new plist is returned;
2049 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2050 The PLIST is modified by side effects. */)
2053 register Lisp_Object prop
;
2056 register Lisp_Object tail
, prev
;
2057 Lisp_Object newcell
;
2059 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2060 tail
= XCDR (XCDR (tail
)))
2062 if (! NILP (Fequal (prop
, XCAR (tail
))))
2064 Fsetcar (XCDR (tail
), val
);
2071 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2075 Fsetcdr (XCDR (prev
), newcell
);
2079 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2080 doc
: /* Return t if the two args are the same Lisp object.
2081 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2083 Lisp_Object obj1
, obj2
;
2086 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2088 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2091 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2092 doc
: /* Return t if two Lisp objects have similar structure and contents.
2093 They must have the same data type.
2094 Conses are compared by comparing the cars and the cdrs.
2095 Vectors and strings are compared element by element.
2096 Numbers are compared by value, but integers cannot equal floats.
2097 (Use `=' if you want integers and floats to be able to be equal.)
2098 Symbols must match exactly. */)
2100 register Lisp_Object o1
, o2
;
2102 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2105 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2106 doc
: /* Return t if two Lisp objects have similar structure and contents.
2107 This is like `equal' except that it compares the text properties
2108 of strings. (`equal' ignores text properties.) */)
2110 register Lisp_Object o1
, o2
;
2112 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2115 /* DEPTH is current depth of recursion. Signal an error if it
2117 PROPS, if non-nil, means compare string text properties too. */
2120 internal_equal (o1
, o2
, depth
, props
)
2121 register Lisp_Object o1
, o2
;
2125 error ("Stack overflow in equal");
2131 if (XTYPE (o1
) != XTYPE (o2
))
2140 d1
= extract_float (o1
);
2141 d2
= extract_float (o2
);
2142 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2143 though they are not =. */
2144 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2148 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2155 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2159 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2161 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2164 o1
= XOVERLAY (o1
)->plist
;
2165 o2
= XOVERLAY (o2
)->plist
;
2170 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2171 && (XMARKER (o1
)->buffer
== 0
2172 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2176 case Lisp_Vectorlike
:
2179 EMACS_INT size
= ASIZE (o1
);
2180 /* Pseudovectors have the type encoded in the size field, so this test
2181 actually checks that the objects have the same type as well as the
2183 if (ASIZE (o2
) != size
)
2185 /* Boolvectors are compared much like strings. */
2186 if (BOOL_VECTOR_P (o1
))
2189 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2190 / BOOL_VECTOR_BITS_PER_CHAR
);
2192 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2194 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2199 if (WINDOW_CONFIGURATIONP (o1
))
2200 return compare_window_configurations (o1
, o2
, 0);
2202 /* Aside from them, only true vectors, char-tables, compiled
2203 functions, and fonts (font-spec, font-entity, font-ojbect)
2204 are sensible to compare, so eliminate the others now. */
2205 if (size
& PSEUDOVECTOR_FLAG
)
2207 if (!(size
& (PVEC_COMPILED
2208 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2210 size
&= PSEUDOVECTOR_SIZE_MASK
;
2212 for (i
= 0; i
< size
; i
++)
2217 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2225 if (SCHARS (o1
) != SCHARS (o2
))
2227 if (SBYTES (o1
) != SBYTES (o2
))
2229 if (bcmp (SDATA (o1
), SDATA (o2
),
2232 if (props
&& !compare_string_intervals (o1
, o2
))
2243 extern Lisp_Object
Fmake_char_internal ();
2245 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2246 doc
: /* Store each element of ARRAY with ITEM.
2247 ARRAY is a vector, string, char-table, or bool-vector. */)
2249 Lisp_Object array
, item
;
2251 register int size
, index
, charval
;
2252 if (VECTORP (array
))
2254 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2255 size
= ASIZE (array
);
2256 for (index
= 0; index
< size
; index
++)
2259 else if (CHAR_TABLE_P (array
))
2263 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2264 XCHAR_TABLE (array
)->contents
[i
] = item
;
2265 XCHAR_TABLE (array
)->defalt
= item
;
2267 else if (STRINGP (array
))
2269 register unsigned char *p
= SDATA (array
);
2270 CHECK_NUMBER (item
);
2271 charval
= XINT (item
);
2272 size
= SCHARS (array
);
2273 if (STRING_MULTIBYTE (array
))
2275 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2276 int len
= CHAR_STRING (charval
, str
);
2277 int size_byte
= SBYTES (array
);
2278 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2281 if (size
!= size_byte
)
2284 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2285 if (len
!= this_len
)
2286 error ("Attempt to change byte length of a string");
2289 for (i
= 0; i
< size_byte
; i
++)
2290 *p
++ = str
[i
% len
];
2293 for (index
= 0; index
< size
; index
++)
2296 else if (BOOL_VECTOR_P (array
))
2298 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2300 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2301 / BOOL_VECTOR_BITS_PER_CHAR
);
2303 charval
= (! NILP (item
) ? -1 : 0);
2304 for (index
= 0; index
< size_in_chars
- 1; index
++)
2306 if (index
< size_in_chars
)
2308 /* Mask out bits beyond the vector size. */
2309 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2310 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2315 wrong_type_argument (Qarrayp
, array
);
2319 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2321 doc
: /* Clear the contents of STRING.
2322 This makes STRING unibyte and may change its length. */)
2327 CHECK_STRING (string
);
2328 len
= SBYTES (string
);
2329 bzero (SDATA (string
), len
);
2330 STRING_SET_CHARS (string
, len
);
2331 STRING_SET_UNIBYTE (string
);
2340 Lisp_Object args
[2];
2343 return Fnconc (2, args
);
2346 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2347 doc
: /* Concatenate any number of lists by altering them.
2348 Only the last argument is not altered, and need not be a list.
2349 usage: (nconc &rest LISTS) */)
2354 register int argnum
;
2355 register Lisp_Object tail
, tem
, val
;
2359 for (argnum
= 0; argnum
< nargs
; argnum
++)
2362 if (NILP (tem
)) continue;
2367 if (argnum
+ 1 == nargs
) break;
2369 CHECK_LIST_CONS (tem
, tem
);
2378 tem
= args
[argnum
+ 1];
2379 Fsetcdr (tail
, tem
);
2381 args
[argnum
+ 1] = tail
;
2387 /* This is the guts of all mapping functions.
2388 Apply FN to each element of SEQ, one by one,
2389 storing the results into elements of VALS, a C vector of Lisp_Objects.
2390 LENI is the length of VALS, which should also be the length of SEQ. */
2393 mapcar1 (leni
, vals
, fn
, seq
)
2396 Lisp_Object fn
, seq
;
2398 register Lisp_Object tail
;
2401 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2405 /* Don't let vals contain any garbage when GC happens. */
2406 for (i
= 0; i
< leni
; i
++)
2409 GCPRO3 (dummy
, fn
, seq
);
2411 gcpro1
.nvars
= leni
;
2415 /* We need not explicitly protect `tail' because it is used only on lists, and
2416 1) lists are not relocated and 2) the list is marked via `seq' so will not
2421 for (i
= 0; i
< leni
; i
++)
2423 dummy
= call1 (fn
, AREF (seq
, i
));
2428 else if (BOOL_VECTOR_P (seq
))
2430 for (i
= 0; i
< leni
; i
++)
2433 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2434 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2435 dummy
= call1 (fn
, dummy
);
2440 else if (STRINGP (seq
))
2444 for (i
= 0, i_byte
= 0; i
< leni
;)
2449 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2450 XSETFASTINT (dummy
, c
);
2451 dummy
= call1 (fn
, dummy
);
2453 vals
[i_before
] = dummy
;
2456 else /* Must be a list, since Flength did not get an error */
2459 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2461 dummy
= call1 (fn
, XCAR (tail
));
2471 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2472 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2473 In between each pair of results, stick in SEPARATOR. Thus, " " as
2474 SEPARATOR results in spaces between the values returned by FUNCTION.
2475 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2476 (function
, sequence
, separator
)
2477 Lisp_Object function
, sequence
, separator
;
2482 register Lisp_Object
*args
;
2484 struct gcpro gcpro1
;
2488 len
= Flength (sequence
);
2489 if (CHAR_TABLE_P (sequence
))
2490 wrong_type_argument (Qlistp
, sequence
);
2492 nargs
= leni
+ leni
- 1;
2493 if (nargs
< 0) return empty_unibyte_string
;
2495 SAFE_ALLOCA_LISP (args
, nargs
);
2498 mapcar1 (leni
, args
, function
, sequence
);
2501 for (i
= leni
- 1; i
> 0; i
--)
2502 args
[i
+ i
] = args
[i
];
2504 for (i
= 1; i
< nargs
; i
+= 2)
2505 args
[i
] = separator
;
2507 ret
= Fconcat (nargs
, args
);
2513 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2514 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2515 The result is a list just as long as SEQUENCE.
2516 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2517 (function
, sequence
)
2518 Lisp_Object function
, sequence
;
2520 register Lisp_Object len
;
2522 register Lisp_Object
*args
;
2526 len
= Flength (sequence
);
2527 if (CHAR_TABLE_P (sequence
))
2528 wrong_type_argument (Qlistp
, sequence
);
2529 leni
= XFASTINT (len
);
2531 SAFE_ALLOCA_LISP (args
, leni
);
2533 mapcar1 (leni
, args
, function
, sequence
);
2535 ret
= Flist (leni
, args
);
2541 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2542 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2543 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2544 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2545 (function
, sequence
)
2546 Lisp_Object function
, sequence
;
2550 leni
= XFASTINT (Flength (sequence
));
2551 if (CHAR_TABLE_P (sequence
))
2552 wrong_type_argument (Qlistp
, sequence
);
2553 mapcar1 (leni
, 0, function
, sequence
);
2558 /* Anything that calls this function must protect from GC! */
2560 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2561 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2562 Takes one argument, which is the string to display to ask the question.
2563 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2564 No confirmation of the answer is requested; a single character is enough.
2565 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2566 the bindings in `query-replace-map'; see the documentation of that variable
2567 for more information. In this case, the useful bindings are `act', `skip',
2568 `recenter', and `quit'.\)
2570 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2571 is nil and `use-dialog-box' is non-nil. */)
2575 register Lisp_Object obj
, key
, def
, map
;
2576 register int answer
;
2577 Lisp_Object xprompt
;
2578 Lisp_Object args
[2];
2579 struct gcpro gcpro1
, gcpro2
;
2580 int count
= SPECPDL_INDEX ();
2582 specbind (Qcursor_in_echo_area
, Qt
);
2584 map
= Fsymbol_value (intern ("query-replace-map"));
2586 CHECK_STRING (prompt
);
2588 GCPRO2 (prompt
, xprompt
);
2590 #ifdef HAVE_WINDOW_SYSTEM
2591 if (display_hourglass_p
)
2592 cancel_hourglass ();
2599 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2600 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2604 Lisp_Object pane
, menu
;
2605 redisplay_preserve_echo_area (3);
2606 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2607 Fcons (Fcons (build_string ("No"), Qnil
),
2609 menu
= Fcons (prompt
, pane
);
2610 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2611 answer
= !NILP (obj
);
2614 #endif /* HAVE_MENUS */
2615 cursor_in_echo_area
= 1;
2616 choose_minibuf_frame ();
2619 Lisp_Object pargs
[3];
2621 /* Colorize prompt according to `minibuffer-prompt' face. */
2622 pargs
[0] = build_string ("%s(y or n) ");
2623 pargs
[1] = intern ("face");
2624 pargs
[2] = intern ("minibuffer-prompt");
2625 args
[0] = Fpropertize (3, pargs
);
2630 if (minibuffer_auto_raise
)
2632 Lisp_Object mini_frame
;
2634 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2636 Fraise_frame (mini_frame
);
2639 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2640 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2641 cursor_in_echo_area
= 0;
2642 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2645 key
= Fmake_vector (make_number (1), obj
);
2646 def
= Flookup_key (map
, key
, Qt
);
2648 if (EQ (def
, intern ("skip")))
2653 else if (EQ (def
, intern ("act")))
2658 else if (EQ (def
, intern ("recenter")))
2664 else if (EQ (def
, intern ("quit")))
2666 /* We want to exit this command for exit-prefix,
2667 and this is the only way to do it. */
2668 else if (EQ (def
, intern ("exit-prefix")))
2673 /* If we don't clear this, then the next call to read_char will
2674 return quit_char again, and we'll enter an infinite loop. */
2679 if (EQ (xprompt
, prompt
))
2681 args
[0] = build_string ("Please answer y or n. ");
2683 xprompt
= Fconcat (2, args
);
2688 if (! noninteractive
)
2690 cursor_in_echo_area
= -1;
2691 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2695 unbind_to (count
, Qnil
);
2696 return answer
? Qt
: Qnil
;
2699 /* This is how C code calls `yes-or-no-p' and allows the user
2702 Anything that calls this function must protect from GC! */
2705 do_yes_or_no_p (prompt
)
2708 return call1 (intern ("yes-or-no-p"), prompt
);
2711 /* Anything that calls this function must protect from GC! */
2713 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2714 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2715 Takes one argument, which is the string to display to ask the question.
2716 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2717 The user must confirm the answer with RET,
2718 and can edit it until it has been confirmed.
2720 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2721 is nil, and `use-dialog-box' is non-nil. */)
2725 register Lisp_Object ans
;
2726 Lisp_Object args
[2];
2727 struct gcpro gcpro1
;
2729 CHECK_STRING (prompt
);
2732 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2733 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2737 Lisp_Object pane
, menu
, obj
;
2738 redisplay_preserve_echo_area (4);
2739 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2740 Fcons (Fcons (build_string ("No"), Qnil
),
2743 menu
= Fcons (prompt
, pane
);
2744 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2748 #endif /* HAVE_MENUS */
2751 args
[1] = build_string ("(yes or no) ");
2752 prompt
= Fconcat (2, args
);
2758 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2759 Qyes_or_no_p_history
, Qnil
,
2761 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2766 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2774 message ("Please answer yes or no.");
2775 Fsleep_for (make_number (2), Qnil
);
2779 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2780 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2782 Each of the three load averages is multiplied by 100, then converted
2785 When USE-FLOATS is non-nil, floats will be used instead of integers.
2786 These floats are not multiplied by 100.
2788 If the 5-minute or 15-minute load averages are not available, return a
2789 shortened list, containing only those averages which are available.
2791 An error is thrown if the load average can't be obtained. In some
2792 cases making it work would require Emacs being installed setuid or
2793 setgid so that it can read kernel information, and that usually isn't
2796 Lisp_Object use_floats
;
2799 int loads
= getloadavg (load_ave
, 3);
2800 Lisp_Object ret
= Qnil
;
2803 error ("load-average not implemented for this operating system");
2807 Lisp_Object load
= (NILP (use_floats
) ?
2808 make_number ((int) (100.0 * load_ave
[loads
]))
2809 : make_float (load_ave
[loads
]));
2810 ret
= Fcons (load
, ret
);
2816 Lisp_Object Vfeatures
, Qsubfeatures
;
2817 extern Lisp_Object Vafter_load_alist
;
2819 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2820 doc
: /* Returns t if FEATURE is present in this Emacs.
2822 Use this to conditionalize execution of lisp code based on the
2823 presence or absence of Emacs or environment extensions.
2824 Use `provide' to declare that a feature is available. This function
2825 looks at the value of the variable `features'. The optional argument
2826 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2827 (feature
, subfeature
)
2828 Lisp_Object feature
, subfeature
;
2830 register Lisp_Object tem
;
2831 CHECK_SYMBOL (feature
);
2832 tem
= Fmemq (feature
, Vfeatures
);
2833 if (!NILP (tem
) && !NILP (subfeature
))
2834 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2835 return (NILP (tem
)) ? Qnil
: Qt
;
2838 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2839 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2840 The optional argument SUBFEATURES should be a list of symbols listing
2841 particular subfeatures supported in this version of FEATURE. */)
2842 (feature
, subfeatures
)
2843 Lisp_Object feature
, subfeatures
;
2845 register Lisp_Object tem
;
2846 CHECK_SYMBOL (feature
);
2847 CHECK_LIST (subfeatures
);
2848 if (!NILP (Vautoload_queue
))
2849 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2851 tem
= Fmemq (feature
, Vfeatures
);
2853 Vfeatures
= Fcons (feature
, Vfeatures
);
2854 if (!NILP (subfeatures
))
2855 Fput (feature
, Qsubfeatures
, subfeatures
);
2856 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2858 /* Run any load-hooks for this file. */
2859 tem
= Fassq (feature
, Vafter_load_alist
);
2861 Fprogn (XCDR (tem
));
2866 /* `require' and its subroutines. */
2868 /* List of features currently being require'd, innermost first. */
2870 Lisp_Object require_nesting_list
;
2873 require_unwind (old_value
)
2874 Lisp_Object old_value
;
2876 return require_nesting_list
= old_value
;
2879 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2880 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2881 If FEATURE is not a member of the list `features', then the feature
2882 is not loaded; so load the file FILENAME.
2883 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2884 and `load' will try to load this name appended with the suffix `.elc' or
2885 `.el', in that order. The name without appended suffix will not be used.
2886 If the optional third argument NOERROR is non-nil,
2887 then return nil if the file is not found instead of signaling an error.
2888 Normally the return value is FEATURE.
2889 The normal messages at start and end of loading FILENAME are suppressed. */)
2890 (feature
, filename
, noerror
)
2891 Lisp_Object feature
, filename
, noerror
;
2893 register Lisp_Object tem
;
2894 struct gcpro gcpro1
, gcpro2
;
2895 int from_file
= load_in_progress
;
2897 CHECK_SYMBOL (feature
);
2899 /* Record the presence of `require' in this file
2900 even if the feature specified is already loaded.
2901 But not more than once in any file,
2902 and not when we aren't loading or reading from a file. */
2904 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2905 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2910 tem
= Fcons (Qrequire
, feature
);
2911 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2912 LOADHIST_ATTACH (tem
);
2914 tem
= Fmemq (feature
, Vfeatures
);
2918 int count
= SPECPDL_INDEX ();
2921 /* This is to make sure that loadup.el gives a clear picture
2922 of what files are preloaded and when. */
2923 if (! NILP (Vpurify_flag
))
2924 error ("(require %s) while preparing to dump",
2925 SDATA (SYMBOL_NAME (feature
)));
2927 /* A certain amount of recursive `require' is legitimate,
2928 but if we require the same feature recursively 3 times,
2930 tem
= require_nesting_list
;
2931 while (! NILP (tem
))
2933 if (! NILP (Fequal (feature
, XCAR (tem
))))
2938 error ("Recursive `require' for feature `%s'",
2939 SDATA (SYMBOL_NAME (feature
)));
2941 /* Update the list for any nested `require's that occur. */
2942 record_unwind_protect (require_unwind
, require_nesting_list
);
2943 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2945 /* Value saved here is to be restored into Vautoload_queue */
2946 record_unwind_protect (un_autoload
, Vautoload_queue
);
2947 Vautoload_queue
= Qt
;
2949 /* Load the file. */
2950 GCPRO2 (feature
, filename
);
2951 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2952 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2955 /* If load failed entirely, return nil. */
2957 return unbind_to (count
, Qnil
);
2959 tem
= Fmemq (feature
, Vfeatures
);
2961 error ("Required feature `%s' was not provided",
2962 SDATA (SYMBOL_NAME (feature
)));
2964 /* Once loading finishes, don't undo it. */
2965 Vautoload_queue
= Qt
;
2966 feature
= unbind_to (count
, feature
);
2972 /* Primitives for work of the "widget" library.
2973 In an ideal world, this section would not have been necessary.
2974 However, lisp function calls being as slow as they are, it turns
2975 out that some functions in the widget library (wid-edit.el) are the
2976 bottleneck of Widget operation. Here is their translation to C,
2977 for the sole reason of efficiency. */
2979 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2980 doc
: /* Return non-nil if PLIST has the property PROP.
2981 PLIST is a property list, which is a list of the form
2982 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2983 Unlike `plist-get', this allows you to distinguish between a missing
2984 property and a property with the value nil.
2985 The value is actually the tail of PLIST whose car is PROP. */)
2987 Lisp_Object plist
, prop
;
2989 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2992 plist
= XCDR (plist
);
2993 plist
= CDR (plist
);
2998 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2999 doc
: /* In WIDGET, set PROPERTY to VALUE.
3000 The value can later be retrieved with `widget-get'. */)
3001 (widget
, property
, value
)
3002 Lisp_Object widget
, property
, value
;
3004 CHECK_CONS (widget
);
3005 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3009 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3010 doc
: /* In WIDGET, get the value of PROPERTY.
3011 The value could either be specified when the widget was created, or
3012 later with `widget-put'. */)
3014 Lisp_Object widget
, property
;
3022 CHECK_CONS (widget
);
3023 tmp
= Fplist_member (XCDR (widget
), property
);
3029 tmp
= XCAR (widget
);
3032 widget
= Fget (tmp
, Qwidget_type
);
3036 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3037 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3038 ARGS are passed as extra arguments to the function.
3039 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3044 /* This function can GC. */
3045 Lisp_Object newargs
[3];
3046 struct gcpro gcpro1
, gcpro2
;
3049 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3050 newargs
[1] = args
[0];
3051 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3052 GCPRO2 (newargs
[0], newargs
[2]);
3053 result
= Fapply (3, newargs
);
3058 #ifdef HAVE_LANGINFO_CODESET
3059 #include <langinfo.h>
3062 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3063 doc
: /* Access locale data ITEM for the current C locale, if available.
3064 ITEM should be one of the following:
3066 `codeset', returning the character set as a string (locale item CODESET);
3068 `days', returning a 7-element vector of day names (locale items DAY_n);
3070 `months', returning a 12-element vector of month names (locale items MON_n);
3072 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3073 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3075 If the system can't provide such information through a call to
3076 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3078 See also Info node `(libc)Locales'.
3080 The data read from the system are decoded using `locale-coding-system'. */)
3085 #ifdef HAVE_LANGINFO_CODESET
3087 if (EQ (item
, Qcodeset
))
3089 str
= nl_langinfo (CODESET
);
3090 return build_string (str
);
3093 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3095 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3096 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3098 struct gcpro gcpro1
;
3100 synchronize_system_time_locale ();
3101 for (i
= 0; i
< 7; i
++)
3103 str
= nl_langinfo (days
[i
]);
3104 val
= make_unibyte_string (str
, strlen (str
));
3105 /* Fixme: Is this coding system necessarily right, even if
3106 it is consistent with CODESET? If not, what to do? */
3107 Faset (v
, make_number (i
),
3108 code_convert_string_norecord (val
, Vlocale_coding_system
,
3116 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3118 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3119 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3120 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3122 struct gcpro gcpro1
;
3124 synchronize_system_time_locale ();
3125 for (i
= 0; i
< 12; i
++)
3127 str
= nl_langinfo (months
[i
]);
3128 val
= make_unibyte_string (str
, strlen (str
));
3129 Faset (v
, make_number (i
),
3130 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
3136 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3137 but is in the locale files. This could be used by ps-print. */
3139 else if (EQ (item
, Qpaper
))
3141 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3142 make_number (nl_langinfo (PAPER_HEIGHT
)));
3144 #endif /* PAPER_WIDTH */
3145 #endif /* HAVE_LANGINFO_CODESET*/
3149 /* base64 encode/decode functions (RFC 2045).
3150 Based on code from GNU recode. */
3152 #define MIME_LINE_LENGTH 76
3154 #define IS_ASCII(Character) \
3156 #define IS_BASE64(Character) \
3157 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3158 #define IS_BASE64_IGNORABLE(Character) \
3159 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3160 || (Character) == '\f' || (Character) == '\r')
3162 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3163 character or return retval if there are no characters left to
3165 #define READ_QUADRUPLET_BYTE(retval) \
3170 if (nchars_return) \
3171 *nchars_return = nchars; \
3176 while (IS_BASE64_IGNORABLE (c))
3178 /* Table of characters coding the 64 values. */
3179 static const char base64_value_to_char
[64] =
3181 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3182 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3183 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3184 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3185 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3186 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3187 '8', '9', '+', '/' /* 60-63 */
3190 /* Table of base64 values for first 128 characters. */
3191 static const short base64_char_to_value
[128] =
3193 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3194 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3195 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3196 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3197 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3198 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3199 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3200 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3201 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3202 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3203 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3204 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3205 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3208 /* The following diagram shows the logical steps by which three octets
3209 get transformed into four base64 characters.
3211 .--------. .--------. .--------.
3212 |aaaaaabb| |bbbbcccc| |ccdddddd|
3213 `--------' `--------' `--------'
3215 .--------+--------+--------+--------.
3216 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3217 `--------+--------+--------+--------'
3219 .--------+--------+--------+--------.
3220 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3221 `--------+--------+--------+--------'
3223 The octets are divided into 6 bit chunks, which are then encoded into
3224 base64 characters. */
3227 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3228 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3230 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3232 doc
: /* Base64-encode the region between BEG and END.
3233 Return the length of the encoded text.
3234 Optional third argument NO-LINE-BREAK means do not break long lines
3235 into shorter lines. */)
3236 (beg
, end
, no_line_break
)
3237 Lisp_Object beg
, end
, no_line_break
;
3240 int allength
, length
;
3241 int ibeg
, iend
, encoded_length
;
3245 validate_region (&beg
, &end
);
3247 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3248 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3249 move_gap_both (XFASTINT (beg
), ibeg
);
3251 /* We need to allocate enough room for encoding the text.
3252 We need 33 1/3% more space, plus a newline every 76
3253 characters, and then we round up. */
3254 length
= iend
- ibeg
;
3255 allength
= length
+ length
/3 + 1;
3256 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3258 SAFE_ALLOCA (encoded
, char *, allength
);
3259 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3260 NILP (no_line_break
),
3261 !NILP (current_buffer
->enable_multibyte_characters
));
3262 if (encoded_length
> allength
)
3265 if (encoded_length
< 0)
3267 /* The encoding wasn't possible. */
3269 error ("Multibyte character in data for base64 encoding");
3272 /* Now we have encoded the region, so we insert the new contents
3273 and delete the old. (Insert first in order to preserve markers.) */
3274 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3275 insert (encoded
, encoded_length
);
3277 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3279 /* If point was outside of the region, restore it exactly; else just
3280 move to the beginning of the region. */
3281 if (old_pos
>= XFASTINT (end
))
3282 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3283 else if (old_pos
> XFASTINT (beg
))
3284 old_pos
= XFASTINT (beg
);
3287 /* We return the length of the encoded text. */
3288 return make_number (encoded_length
);
3291 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3293 doc
: /* Base64-encode STRING and return the result.
3294 Optional second argument NO-LINE-BREAK means do not break long lines
3295 into shorter lines. */)
3296 (string
, no_line_break
)
3297 Lisp_Object string
, no_line_break
;
3299 int allength
, length
, encoded_length
;
3301 Lisp_Object encoded_string
;
3304 CHECK_STRING (string
);
3306 /* We need to allocate enough room for encoding the text.
3307 We need 33 1/3% more space, plus a newline every 76
3308 characters, and then we round up. */
3309 length
= SBYTES (string
);
3310 allength
= length
+ length
/3 + 1;
3311 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3313 /* We need to allocate enough room for decoding the text. */
3314 SAFE_ALLOCA (encoded
, char *, allength
);
3316 encoded_length
= base64_encode_1 (SDATA (string
),
3317 encoded
, length
, NILP (no_line_break
),
3318 STRING_MULTIBYTE (string
));
3319 if (encoded_length
> allength
)
3322 if (encoded_length
< 0)
3324 /* The encoding wasn't possible. */
3326 error ("Multibyte character in data for base64 encoding");
3329 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3332 return encoded_string
;
3336 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3343 int counter
= 0, i
= 0;
3353 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3354 if (CHAR_BYTE8_P (c
))
3355 c
= CHAR_TO_BYTE8 (c
);
3363 /* Wrap line every 76 characters. */
3367 if (counter
< MIME_LINE_LENGTH
/ 4)
3376 /* Process first byte of a triplet. */
3378 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3379 value
= (0x03 & c
) << 4;
3381 /* Process second byte of a triplet. */
3385 *e
++ = base64_value_to_char
[value
];
3393 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3394 if (CHAR_BYTE8_P (c
))
3395 c
= CHAR_TO_BYTE8 (c
);
3403 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3404 value
= (0x0f & c
) << 2;
3406 /* Process third byte of a triplet. */
3410 *e
++ = base64_value_to_char
[value
];
3417 c
= STRING_CHAR_AND_LENGTH (from
+ i
, bytes
);
3418 if (CHAR_BYTE8_P (c
))
3419 c
= CHAR_TO_BYTE8 (c
);
3427 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3428 *e
++ = base64_value_to_char
[0x3f & c
];
3435 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3437 doc
: /* Base64-decode the region between BEG and END.
3438 Return the length of the decoded text.
3439 If the region can't be decoded, signal an error and don't modify the buffer. */)
3441 Lisp_Object beg
, end
;
3443 int ibeg
, iend
, length
, allength
;
3448 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3451 validate_region (&beg
, &end
);
3453 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3454 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3456 length
= iend
- ibeg
;
3458 /* We need to allocate enough room for decoding the text. If we are
3459 working on a multibyte buffer, each decoded code may occupy at
3461 allength
= multibyte
? length
* 2 : length
;
3462 SAFE_ALLOCA (decoded
, char *, allength
);
3464 move_gap_both (XFASTINT (beg
), ibeg
);
3465 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3466 multibyte
, &inserted_chars
);
3467 if (decoded_length
> allength
)
3470 if (decoded_length
< 0)
3472 /* The decoding wasn't possible. */
3474 error ("Invalid base64 data");
3477 /* Now we have decoded the region, so we insert the new contents
3478 and delete the old. (Insert first in order to preserve markers.) */
3479 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3480 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3483 /* Delete the original text. */
3484 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3485 iend
+ decoded_length
, 1);
3487 /* If point was outside of the region, restore it exactly; else just
3488 move to the beginning of the region. */
3489 if (old_pos
>= XFASTINT (end
))
3490 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3491 else if (old_pos
> XFASTINT (beg
))
3492 old_pos
= XFASTINT (beg
);
3493 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3495 return make_number (inserted_chars
);
3498 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3500 doc
: /* Base64-decode STRING and return the result. */)
3505 int length
, decoded_length
;
3506 Lisp_Object decoded_string
;
3509 CHECK_STRING (string
);
3511 length
= SBYTES (string
);
3512 /* We need to allocate enough room for decoding the text. */
3513 SAFE_ALLOCA (decoded
, char *, length
);
3515 /* The decoded result should be unibyte. */
3516 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3518 if (decoded_length
> length
)
3520 else if (decoded_length
>= 0)
3521 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3523 decoded_string
= Qnil
;
3526 if (!STRINGP (decoded_string
))
3527 error ("Invalid base64 data");
3529 return decoded_string
;
3532 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3533 MULTIBYTE is nonzero, the decoded result should be in multibyte
3534 form. If NCHARS_RETRUN is not NULL, store the number of produced
3535 characters in *NCHARS_RETURN. */
3538 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3548 unsigned long value
;
3553 /* Process first byte of a quadruplet. */
3555 READ_QUADRUPLET_BYTE (e
-to
);
3559 value
= base64_char_to_value
[c
] << 18;
3561 /* Process second byte of a quadruplet. */
3563 READ_QUADRUPLET_BYTE (-1);
3567 value
|= base64_char_to_value
[c
] << 12;
3569 c
= (unsigned char) (value
>> 16);
3570 if (multibyte
&& c
>= 128)
3571 e
+= BYTE8_STRING (c
, e
);
3576 /* Process third byte of a quadruplet. */
3578 READ_QUADRUPLET_BYTE (-1);
3582 READ_QUADRUPLET_BYTE (-1);
3591 value
|= base64_char_to_value
[c
] << 6;
3593 c
= (unsigned char) (0xff & value
>> 8);
3594 if (multibyte
&& c
>= 128)
3595 e
+= BYTE8_STRING (c
, e
);
3600 /* Process fourth byte of a quadruplet. */
3602 READ_QUADRUPLET_BYTE (-1);
3609 value
|= base64_char_to_value
[c
];
3611 c
= (unsigned char) (0xff & value
);
3612 if (multibyte
&& c
>= 128)
3613 e
+= BYTE8_STRING (c
, e
);
3622 /***********************************************************************
3624 ***** Hash Tables *****
3626 ***********************************************************************/
3628 /* Implemented by gerd@gnu.org. This hash table implementation was
3629 inspired by CMUCL hash tables. */
3633 1. For small tables, association lists are probably faster than
3634 hash tables because they have lower overhead.
3636 For uses of hash tables where the O(1) behavior of table
3637 operations is not a requirement, it might therefore be a good idea
3638 not to hash. Instead, we could just do a linear search in the
3639 key_and_value vector of the hash table. This could be done
3640 if a `:linear-search t' argument is given to make-hash-table. */
3643 /* The list of all weak hash tables. Don't staticpro this one. */
3645 struct Lisp_Hash_Table
*weak_hash_tables
;
3647 /* Various symbols. */
3649 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3650 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3651 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3653 /* Function prototypes. */
3655 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3656 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3657 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3658 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3659 Lisp_Object
, unsigned));
3660 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3661 Lisp_Object
, unsigned));
3662 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3663 unsigned, Lisp_Object
, unsigned));
3664 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3665 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3666 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3667 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3669 static unsigned sxhash_string
P_ ((unsigned char *, int));
3670 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3671 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3672 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3673 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3677 /***********************************************************************
3679 ***********************************************************************/
3681 /* If OBJ is a Lisp hash table, return a pointer to its struct
3682 Lisp_Hash_Table. Otherwise, signal an error. */
3684 static struct Lisp_Hash_Table
*
3685 check_hash_table (obj
)
3688 CHECK_HASH_TABLE (obj
);
3689 return XHASH_TABLE (obj
);
3693 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3697 next_almost_prime (n
)
3710 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3711 which USED[I] is non-zero. If found at index I in ARGS, set
3712 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3713 -1. This function is used to extract a keyword/argument pair from
3714 a DEFUN parameter list. */
3717 get_key_arg (key
, nargs
, args
, used
)
3725 for (i
= 0; i
< nargs
- 1; ++i
)
3726 if (!used
[i
] && EQ (args
[i
], key
))
3741 /* Return a Lisp vector which has the same contents as VEC but has
3742 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3743 vector that are not copied from VEC are set to INIT. */
3746 larger_vector (vec
, new_size
, init
)
3751 struct Lisp_Vector
*v
;
3754 xassert (VECTORP (vec
));
3755 old_size
= ASIZE (vec
);
3756 xassert (new_size
>= old_size
);
3758 v
= allocate_vector (new_size
);
3759 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3760 old_size
* sizeof *v
->contents
);
3761 for (i
= old_size
; i
< new_size
; ++i
)
3762 v
->contents
[i
] = init
;
3763 XSETVECTOR (vec
, v
);
3768 /***********************************************************************
3770 ***********************************************************************/
3772 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3773 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3774 KEY2 are the same. */
3777 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3778 struct Lisp_Hash_Table
*h
;
3779 Lisp_Object key1
, key2
;
3780 unsigned hash1
, hash2
;
3782 return (FLOATP (key1
)
3784 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3788 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3789 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3790 KEY2 are the same. */
3793 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3794 struct Lisp_Hash_Table
*h
;
3795 Lisp_Object key1
, key2
;
3796 unsigned hash1
, hash2
;
3798 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3802 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3803 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3804 if KEY1 and KEY2 are the same. */
3807 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3808 struct Lisp_Hash_Table
*h
;
3809 Lisp_Object key1
, key2
;
3810 unsigned hash1
, hash2
;
3814 Lisp_Object args
[3];
3816 args
[0] = h
->user_cmp_function
;
3819 return !NILP (Ffuncall (3, args
));
3826 /* Value is a hash code for KEY for use in hash table H which uses
3827 `eq' to compare keys. The hash code returned is guaranteed to fit
3828 in a Lisp integer. */
3832 struct Lisp_Hash_Table
*h
;
3835 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3836 xassert ((hash
& ~INTMASK
) == 0);
3841 /* Value is a hash code for KEY for use in hash table H which uses
3842 `eql' to compare keys. The hash code returned is guaranteed to fit
3843 in a Lisp integer. */
3847 struct Lisp_Hash_Table
*h
;
3852 hash
= sxhash (key
, 0);
3854 hash
= XUINT (key
) ^ XTYPE (key
);
3855 xassert ((hash
& ~INTMASK
) == 0);
3860 /* Value is a hash code for KEY for use in hash table H which uses
3861 `equal' to compare keys. The hash code returned is guaranteed to fit
3862 in a Lisp integer. */
3865 hashfn_equal (h
, key
)
3866 struct Lisp_Hash_Table
*h
;
3869 unsigned hash
= sxhash (key
, 0);
3870 xassert ((hash
& ~INTMASK
) == 0);
3875 /* Value is a hash code for KEY for use in hash table H which uses as
3876 user-defined function to compare keys. The hash code returned is
3877 guaranteed to fit in a Lisp integer. */
3880 hashfn_user_defined (h
, key
)
3881 struct Lisp_Hash_Table
*h
;
3884 Lisp_Object args
[2], hash
;
3886 args
[0] = h
->user_hash_function
;
3888 hash
= Ffuncall (2, args
);
3889 if (!INTEGERP (hash
))
3890 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3891 return XUINT (hash
);
3895 /* Create and initialize a new hash table.
3897 TEST specifies the test the hash table will use to compare keys.
3898 It must be either one of the predefined tests `eq', `eql' or
3899 `equal' or a symbol denoting a user-defined test named TEST with
3900 test and hash functions USER_TEST and USER_HASH.
3902 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3904 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3905 new size when it becomes full is computed by adding REHASH_SIZE to
3906 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3907 table's new size is computed by multiplying its old size with
3910 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3911 be resized when the ratio of (number of entries in the table) /
3912 (table size) is >= REHASH_THRESHOLD.
3914 WEAK specifies the weakness of the table. If non-nil, it must be
3915 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3918 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3919 user_test
, user_hash
)
3920 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3921 Lisp_Object user_test
, user_hash
;
3923 struct Lisp_Hash_Table
*h
;
3925 int index_size
, i
, sz
;
3927 /* Preconditions. */
3928 xassert (SYMBOLP (test
));
3929 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3930 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3931 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3932 xassert (FLOATP (rehash_threshold
)
3933 && XFLOATINT (rehash_threshold
) > 0
3934 && XFLOATINT (rehash_threshold
) <= 1.0);
3936 if (XFASTINT (size
) == 0)
3937 size
= make_number (1);
3939 /* Allocate a table and initialize it. */
3940 h
= allocate_hash_table ();
3942 /* Initialize hash table slots. */
3943 sz
= XFASTINT (size
);
3946 if (EQ (test
, Qeql
))
3948 h
->cmpfn
= cmpfn_eql
;
3949 h
->hashfn
= hashfn_eql
;
3951 else if (EQ (test
, Qeq
))
3954 h
->hashfn
= hashfn_eq
;
3956 else if (EQ (test
, Qequal
))
3958 h
->cmpfn
= cmpfn_equal
;
3959 h
->hashfn
= hashfn_equal
;
3963 h
->user_cmp_function
= user_test
;
3964 h
->user_hash_function
= user_hash
;
3965 h
->cmpfn
= cmpfn_user_defined
;
3966 h
->hashfn
= hashfn_user_defined
;
3970 h
->rehash_threshold
= rehash_threshold
;
3971 h
->rehash_size
= rehash_size
;
3973 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3974 h
->hash
= Fmake_vector (size
, Qnil
);
3975 h
->next
= Fmake_vector (size
, Qnil
);
3976 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3977 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3978 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3980 /* Set up the free list. */
3981 for (i
= 0; i
< sz
- 1; ++i
)
3982 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3983 h
->next_free
= make_number (0);
3985 XSET_HASH_TABLE (table
, h
);
3986 xassert (HASH_TABLE_P (table
));
3987 xassert (XHASH_TABLE (table
) == h
);
3989 /* Maybe add this hash table to the list of all weak hash tables. */
3991 h
->next_weak
= NULL
;
3994 h
->next_weak
= weak_hash_tables
;
3995 weak_hash_tables
= h
;
4002 /* Return a copy of hash table H1. Keys and values are not copied,
4003 only the table itself is. */
4006 copy_hash_table (h1
)
4007 struct Lisp_Hash_Table
*h1
;
4010 struct Lisp_Hash_Table
*h2
;
4011 struct Lisp_Vector
*next
;
4013 h2
= allocate_hash_table ();
4014 next
= h2
->vec_next
;
4015 bcopy (h1
, h2
, sizeof *h2
);
4016 h2
->vec_next
= next
;
4017 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4018 h2
->hash
= Fcopy_sequence (h1
->hash
);
4019 h2
->next
= Fcopy_sequence (h1
->next
);
4020 h2
->index
= Fcopy_sequence (h1
->index
);
4021 XSET_HASH_TABLE (table
, h2
);
4023 /* Maybe add this hash table to the list of all weak hash tables. */
4024 if (!NILP (h2
->weak
))
4026 h2
->next_weak
= weak_hash_tables
;
4027 weak_hash_tables
= h2
;
4034 /* Resize hash table H if it's too full. If H cannot be resized
4035 because it's already too large, throw an error. */
4038 maybe_resize_hash_table (h
)
4039 struct Lisp_Hash_Table
*h
;
4041 if (NILP (h
->next_free
))
4043 int old_size
= HASH_TABLE_SIZE (h
);
4044 int i
, new_size
, index_size
;
4047 if (INTEGERP (h
->rehash_size
))
4048 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4050 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4051 new_size
= max (old_size
+ 1, new_size
);
4052 index_size
= next_almost_prime ((int)
4054 / XFLOATINT (h
->rehash_threshold
)));
4055 /* Assignment to EMACS_INT stops GCC whining about limited range
4057 nsize
= max (index_size
, 2 * new_size
);
4058 if (nsize
> MOST_POSITIVE_FIXNUM
)
4059 error ("Hash table too large to resize");
4061 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4062 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4063 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4064 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4066 /* Update the free list. Do it so that new entries are added at
4067 the end of the free list. This makes some operations like
4069 for (i
= old_size
; i
< new_size
- 1; ++i
)
4070 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4072 if (!NILP (h
->next_free
))
4074 Lisp_Object last
, next
;
4076 last
= h
->next_free
;
4077 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4081 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4084 XSETFASTINT (h
->next_free
, old_size
);
4087 for (i
= 0; i
< old_size
; ++i
)
4088 if (!NILP (HASH_HASH (h
, i
)))
4090 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4091 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4092 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4093 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4099 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4100 the hash code of KEY. Value is the index of the entry in H
4101 matching KEY, or -1 if not found. */
4104 hash_lookup (h
, key
, hash
)
4105 struct Lisp_Hash_Table
*h
;
4110 int start_of_bucket
;
4113 hash_code
= h
->hashfn (h
, key
);
4117 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4118 idx
= HASH_INDEX (h
, start_of_bucket
);
4120 /* We need not gcpro idx since it's either an integer or nil. */
4123 int i
= XFASTINT (idx
);
4124 if (EQ (key
, HASH_KEY (h
, i
))
4126 && h
->cmpfn (h
, key
, hash_code
,
4127 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4129 idx
= HASH_NEXT (h
, i
);
4132 return NILP (idx
) ? -1 : XFASTINT (idx
);
4136 /* Put an entry into hash table H that associates KEY with VALUE.
4137 HASH is a previously computed hash code of KEY.
4138 Value is the index of the entry in H matching KEY. */
4141 hash_put (h
, key
, value
, hash
)
4142 struct Lisp_Hash_Table
*h
;
4143 Lisp_Object key
, value
;
4146 int start_of_bucket
, i
;
4148 xassert ((hash
& ~INTMASK
) == 0);
4150 /* Increment count after resizing because resizing may fail. */
4151 maybe_resize_hash_table (h
);
4154 /* Store key/value in the key_and_value vector. */
4155 i
= XFASTINT (h
->next_free
);
4156 h
->next_free
= HASH_NEXT (h
, i
);
4157 HASH_KEY (h
, i
) = key
;
4158 HASH_VALUE (h
, i
) = value
;
4160 /* Remember its hash code. */
4161 HASH_HASH (h
, i
) = make_number (hash
);
4163 /* Add new entry to its collision chain. */
4164 start_of_bucket
= hash
% ASIZE (h
->index
);
4165 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4166 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4171 /* Remove the entry matching KEY from hash table H, if there is one. */
4174 hash_remove_from_table (h
, key
)
4175 struct Lisp_Hash_Table
*h
;
4179 int start_of_bucket
;
4180 Lisp_Object idx
, prev
;
4182 hash_code
= h
->hashfn (h
, key
);
4183 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4184 idx
= HASH_INDEX (h
, start_of_bucket
);
4187 /* We need not gcpro idx, prev since they're either integers or nil. */
4190 int i
= XFASTINT (idx
);
4192 if (EQ (key
, HASH_KEY (h
, i
))
4194 && h
->cmpfn (h
, key
, hash_code
,
4195 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4197 /* Take entry out of collision chain. */
4199 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4201 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4203 /* Clear slots in key_and_value and add the slots to
4205 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4206 HASH_NEXT (h
, i
) = h
->next_free
;
4207 h
->next_free
= make_number (i
);
4209 xassert (h
->count
>= 0);
4215 idx
= HASH_NEXT (h
, i
);
4221 /* Clear hash table H. */
4225 struct Lisp_Hash_Table
*h
;
4229 int i
, size
= HASH_TABLE_SIZE (h
);
4231 for (i
= 0; i
< size
; ++i
)
4233 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4234 HASH_KEY (h
, i
) = Qnil
;
4235 HASH_VALUE (h
, i
) = Qnil
;
4236 HASH_HASH (h
, i
) = Qnil
;
4239 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4240 ASET (h
->index
, i
, Qnil
);
4242 h
->next_free
= make_number (0);
4249 /************************************************************************
4251 ************************************************************************/
4254 init_weak_hash_tables ()
4256 weak_hash_tables
= NULL
;
4259 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4260 entries from the table that don't survive the current GC.
4261 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4262 non-zero if anything was marked. */
4265 sweep_weak_table (h
, remove_entries_p
)
4266 struct Lisp_Hash_Table
*h
;
4267 int remove_entries_p
;
4269 int bucket
, n
, marked
;
4271 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4274 for (bucket
= 0; bucket
< n
; ++bucket
)
4276 Lisp_Object idx
, next
, prev
;
4278 /* Follow collision chain, removing entries that
4279 don't survive this garbage collection. */
4281 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4283 int i
= XFASTINT (idx
);
4284 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4285 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4288 if (EQ (h
->weak
, Qkey
))
4289 remove_p
= !key_known_to_survive_p
;
4290 else if (EQ (h
->weak
, Qvalue
))
4291 remove_p
= !value_known_to_survive_p
;
4292 else if (EQ (h
->weak
, Qkey_or_value
))
4293 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4294 else if (EQ (h
->weak
, Qkey_and_value
))
4295 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4299 next
= HASH_NEXT (h
, i
);
4301 if (remove_entries_p
)
4305 /* Take out of collision chain. */
4307 HASH_INDEX (h
, bucket
) = next
;
4309 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4311 /* Add to free list. */
4312 HASH_NEXT (h
, i
) = h
->next_free
;
4315 /* Clear key, value, and hash. */
4316 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4317 HASH_HASH (h
, i
) = Qnil
;
4330 /* Make sure key and value survive. */
4331 if (!key_known_to_survive_p
)
4333 mark_object (HASH_KEY (h
, i
));
4337 if (!value_known_to_survive_p
)
4339 mark_object (HASH_VALUE (h
, i
));
4350 /* Remove elements from weak hash tables that don't survive the
4351 current garbage collection. Remove weak tables that don't survive
4352 from Vweak_hash_tables. Called from gc_sweep. */
4355 sweep_weak_hash_tables ()
4357 struct Lisp_Hash_Table
*h
, *used
, *next
;
4360 /* Mark all keys and values that are in use. Keep on marking until
4361 there is no more change. This is necessary for cases like
4362 value-weak table A containing an entry X -> Y, where Y is used in a
4363 key-weak table B, Z -> Y. If B comes after A in the list of weak
4364 tables, X -> Y might be removed from A, although when looking at B
4365 one finds that it shouldn't. */
4369 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4371 if (h
->size
& ARRAY_MARK_FLAG
)
4372 marked
|= sweep_weak_table (h
, 0);
4377 /* Remove tables and entries that aren't used. */
4378 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4380 next
= h
->next_weak
;
4382 if (h
->size
& ARRAY_MARK_FLAG
)
4384 /* TABLE is marked as used. Sweep its contents. */
4386 sweep_weak_table (h
, 1);
4388 /* Add table to the list of used weak hash tables. */
4389 h
->next_weak
= used
;
4394 weak_hash_tables
= used
;
4399 /***********************************************************************
4400 Hash Code Computation
4401 ***********************************************************************/
4403 /* Maximum depth up to which to dive into Lisp structures. */
4405 #define SXHASH_MAX_DEPTH 3
4407 /* Maximum length up to which to take list and vector elements into
4410 #define SXHASH_MAX_LEN 7
4412 /* Combine two integers X and Y for hashing. */
4414 #define SXHASH_COMBINE(X, Y) \
4415 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4419 /* Return a hash for string PTR which has length LEN. The hash
4420 code returned is guaranteed to fit in a Lisp integer. */
4423 sxhash_string (ptr
, len
)
4427 unsigned char *p
= ptr
;
4428 unsigned char *end
= p
+ len
;
4437 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4440 return hash
& INTMASK
;
4444 /* Return a hash for list LIST. DEPTH is the current depth in the
4445 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4448 sxhash_list (list
, depth
)
4455 if (depth
< SXHASH_MAX_DEPTH
)
4457 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4458 list
= XCDR (list
), ++i
)
4460 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4461 hash
= SXHASH_COMBINE (hash
, hash2
);
4466 unsigned hash2
= sxhash (list
, depth
+ 1);
4467 hash
= SXHASH_COMBINE (hash
, hash2
);
4474 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4475 the Lisp structure. */
4478 sxhash_vector (vec
, depth
)
4482 unsigned hash
= ASIZE (vec
);
4485 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4486 for (i
= 0; i
< n
; ++i
)
4488 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4489 hash
= SXHASH_COMBINE (hash
, hash2
);
4496 /* Return a hash for bool-vector VECTOR. */
4499 sxhash_bool_vector (vec
)
4502 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4505 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4506 for (i
= 0; i
< n
; ++i
)
4507 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4513 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4514 structure. Value is an unsigned integer clipped to INTMASK. */
4523 if (depth
> SXHASH_MAX_DEPTH
)
4526 switch (XTYPE (obj
))
4537 obj
= SYMBOL_NAME (obj
);
4541 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4544 /* This can be everything from a vector to an overlay. */
4545 case Lisp_Vectorlike
:
4547 /* According to the CL HyperSpec, two arrays are equal only if
4548 they are `eq', except for strings and bit-vectors. In
4549 Emacs, this works differently. We have to compare element
4551 hash
= sxhash_vector (obj
, depth
);
4552 else if (BOOL_VECTOR_P (obj
))
4553 hash
= sxhash_bool_vector (obj
);
4555 /* Others are `equal' if they are `eq', so let's take their
4561 hash
= sxhash_list (obj
, depth
);
4566 double val
= XFLOAT_DATA (obj
);
4567 unsigned char *p
= (unsigned char *) &val
;
4568 unsigned char *e
= p
+ sizeof val
;
4569 for (hash
= 0; p
< e
; ++p
)
4570 hash
= SXHASH_COMBINE (hash
, *p
);
4578 return hash
& INTMASK
;
4583 /***********************************************************************
4585 ***********************************************************************/
4588 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4589 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4593 unsigned hash
= sxhash (obj
, 0);
4594 return make_number (hash
);
4598 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4599 doc
: /* Create and return a new hash table.
4601 Arguments are specified as keyword/argument pairs. The following
4602 arguments are defined:
4604 :test TEST -- TEST must be a symbol that specifies how to compare
4605 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4606 `equal'. User-supplied test and hash functions can be specified via
4607 `define-hash-table-test'.
4609 :size SIZE -- A hint as to how many elements will be put in the table.
4612 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4613 fills up. If REHASH-SIZE is an integer, add that many space. If it
4614 is a float, it must be > 1.0, and the new size is computed by
4615 multiplying the old size with that factor. Default is 1.5.
4617 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4618 Resize the hash table when ratio of the number of entries in the
4619 table. Default is 0.8.
4621 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4622 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4623 returned is a weak table. Key/value pairs are removed from a weak
4624 hash table when there are no non-weak references pointing to their
4625 key, value, one of key or value, or both key and value, depending on
4626 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4629 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4634 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4635 Lisp_Object user_test
, user_hash
;
4639 /* The vector `used' is used to keep track of arguments that
4640 have been consumed. */
4641 used
= (char *) alloca (nargs
* sizeof *used
);
4642 bzero (used
, nargs
* sizeof *used
);
4644 /* See if there's a `:test TEST' among the arguments. */
4645 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4646 test
= i
< 0 ? Qeql
: args
[i
];
4647 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4649 /* See if it is a user-defined test. */
4652 prop
= Fget (test
, Qhash_table_test
);
4653 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4654 signal_error ("Invalid hash table test", test
);
4655 user_test
= XCAR (prop
);
4656 user_hash
= XCAR (XCDR (prop
));
4659 user_test
= user_hash
= Qnil
;
4661 /* See if there's a `:size SIZE' argument. */
4662 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4663 size
= i
< 0 ? Qnil
: args
[i
];
4665 size
= make_number (DEFAULT_HASH_SIZE
);
4666 else if (!INTEGERP (size
) || XINT (size
) < 0)
4667 signal_error ("Invalid hash table size", size
);
4669 /* Look for `:rehash-size SIZE'. */
4670 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4671 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4672 if (!NUMBERP (rehash_size
)
4673 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4674 || XFLOATINT (rehash_size
) <= 1.0)
4675 signal_error ("Invalid hash table rehash size", rehash_size
);
4677 /* Look for `:rehash-threshold THRESHOLD'. */
4678 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4679 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4680 if (!FLOATP (rehash_threshold
)
4681 || XFLOATINT (rehash_threshold
) <= 0.0
4682 || XFLOATINT (rehash_threshold
) > 1.0)
4683 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4685 /* Look for `:weakness WEAK'. */
4686 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4687 weak
= i
< 0 ? Qnil
: args
[i
];
4689 weak
= Qkey_and_value
;
4692 && !EQ (weak
, Qvalue
)
4693 && !EQ (weak
, Qkey_or_value
)
4694 && !EQ (weak
, Qkey_and_value
))
4695 signal_error ("Invalid hash table weakness", weak
);
4697 /* Now, all args should have been used up, or there's a problem. */
4698 for (i
= 0; i
< nargs
; ++i
)
4700 signal_error ("Invalid argument list", args
[i
]);
4702 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4703 user_test
, user_hash
);
4707 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4708 doc
: /* Return a copy of hash table TABLE. */)
4712 return copy_hash_table (check_hash_table (table
));
4716 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4717 doc
: /* Return the number of elements in TABLE. */)
4721 return make_number (check_hash_table (table
)->count
);
4725 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4726 Shash_table_rehash_size
, 1, 1, 0,
4727 doc
: /* Return the current rehash size of TABLE. */)
4731 return check_hash_table (table
)->rehash_size
;
4735 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4736 Shash_table_rehash_threshold
, 1, 1, 0,
4737 doc
: /* Return the current rehash threshold of TABLE. */)
4741 return check_hash_table (table
)->rehash_threshold
;
4745 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4746 doc
: /* Return the size of TABLE.
4747 The size can be used as an argument to `make-hash-table' to create
4748 a hash table than can hold as many elements of TABLE holds
4749 without need for resizing. */)
4753 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4754 return make_number (HASH_TABLE_SIZE (h
));
4758 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4759 doc
: /* Return the test TABLE uses. */)
4763 return check_hash_table (table
)->test
;
4767 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4769 doc
: /* Return the weakness of TABLE. */)
4773 return check_hash_table (table
)->weak
;
4777 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4778 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4782 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4786 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4787 doc
: /* Clear hash table TABLE and return it. */)
4791 hash_clear (check_hash_table (table
));
4792 /* Be compatible with XEmacs. */
4797 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4798 doc
: /* Look up KEY in TABLE and return its associated value.
4799 If KEY is not found, return DFLT which defaults to nil. */)
4801 Lisp_Object key
, table
, dflt
;
4803 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4804 int i
= hash_lookup (h
, key
, NULL
);
4805 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4809 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4810 doc
: /* Associate KEY with VALUE in hash table TABLE.
4811 If KEY is already present in table, replace its current value with
4814 Lisp_Object key
, value
, table
;
4816 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4820 i
= hash_lookup (h
, key
, &hash
);
4822 HASH_VALUE (h
, i
) = value
;
4824 hash_put (h
, key
, value
, hash
);
4830 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4831 doc
: /* Remove KEY from TABLE. */)
4833 Lisp_Object key
, table
;
4835 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4836 hash_remove_from_table (h
, key
);
4841 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4842 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4843 FUNCTION is called with two arguments, KEY and VALUE. */)
4845 Lisp_Object function
, table
;
4847 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4848 Lisp_Object args
[3];
4851 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4852 if (!NILP (HASH_HASH (h
, i
)))
4855 args
[1] = HASH_KEY (h
, i
);
4856 args
[2] = HASH_VALUE (h
, i
);
4864 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4865 Sdefine_hash_table_test
, 3, 3, 0,
4866 doc
: /* Define a new hash table test with name NAME, a symbol.
4868 In hash tables created with NAME specified as test, use TEST to
4869 compare keys, and HASH for computing hash codes of keys.
4871 TEST must be a function taking two arguments and returning non-nil if
4872 both arguments are the same. HASH must be a function taking one
4873 argument and return an integer that is the hash code of the argument.
4874 Hash code computation should use the whole value range of integers,
4875 including negative integers. */)
4877 Lisp_Object name
, test
, hash
;
4879 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4884 /************************************************************************
4886 ************************************************************************/
4890 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4891 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4893 A message digest is a cryptographic checksum of a document, and the
4894 algorithm to calculate it is defined in RFC 1321.
4896 The two optional arguments START and END are character positions
4897 specifying for which part of OBJECT the message digest should be
4898 computed. If nil or omitted, the digest is computed for the whole
4901 The MD5 message digest is computed from the result of encoding the
4902 text in a coding system, not directly from the internal Emacs form of
4903 the text. The optional fourth argument CODING-SYSTEM specifies which
4904 coding system to encode the text with. It should be the same coding
4905 system that you used or will use when actually writing the text into a
4908 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4909 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4910 system would be chosen by default for writing this text into a file.
4912 If OBJECT is a string, the most preferred coding system (see the
4913 command `prefer-coding-system') is used.
4915 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4916 guesswork fails. Normally, an error is signaled in such case. */)
4917 (object
, start
, end
, coding_system
, noerror
)
4918 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4920 unsigned char digest
[16];
4921 unsigned char value
[33];
4925 int start_char
= 0, end_char
= 0;
4926 int start_byte
= 0, end_byte
= 0;
4928 register struct buffer
*bp
;
4931 if (STRINGP (object
))
4933 if (NILP (coding_system
))
4935 /* Decide the coding-system to encode the data with. */
4937 if (STRING_MULTIBYTE (object
))
4938 /* use default, we can't guess correct value */
4939 coding_system
= preferred_coding_system ();
4941 coding_system
= Qraw_text
;
4944 if (NILP (Fcoding_system_p (coding_system
)))
4946 /* Invalid coding system. */
4948 if (!NILP (noerror
))
4949 coding_system
= Qraw_text
;
4951 xsignal1 (Qcoding_system_error
, coding_system
);
4954 if (STRING_MULTIBYTE (object
))
4955 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4957 size
= SCHARS (object
);
4958 size_byte
= SBYTES (object
);
4962 CHECK_NUMBER (start
);
4964 start_char
= XINT (start
);
4969 start_byte
= string_char_to_byte (object
, start_char
);
4975 end_byte
= size_byte
;
4981 end_char
= XINT (end
);
4986 end_byte
= string_char_to_byte (object
, end_char
);
4989 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4990 args_out_of_range_3 (object
, make_number (start_char
),
4991 make_number (end_char
));
4995 struct buffer
*prev
= current_buffer
;
4997 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4999 CHECK_BUFFER (object
);
5001 bp
= XBUFFER (object
);
5002 if (bp
!= current_buffer
)
5003 set_buffer_internal (bp
);
5009 CHECK_NUMBER_COERCE_MARKER (start
);
5017 CHECK_NUMBER_COERCE_MARKER (end
);
5022 temp
= b
, b
= e
, e
= temp
;
5024 if (!(BEGV
<= b
&& e
<= ZV
))
5025 args_out_of_range (start
, end
);
5027 if (NILP (coding_system
))
5029 /* Decide the coding-system to encode the data with.
5030 See fileio.c:Fwrite-region */
5032 if (!NILP (Vcoding_system_for_write
))
5033 coding_system
= Vcoding_system_for_write
;
5036 int force_raw_text
= 0;
5038 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5039 if (NILP (coding_system
)
5040 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5042 coding_system
= Qnil
;
5043 if (NILP (current_buffer
->enable_multibyte_characters
))
5047 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5049 /* Check file-coding-system-alist. */
5050 Lisp_Object args
[4], val
;
5052 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5053 args
[3] = Fbuffer_file_name(object
);
5054 val
= Ffind_operation_coding_system (4, args
);
5055 if (CONSP (val
) && !NILP (XCDR (val
)))
5056 coding_system
= XCDR (val
);
5059 if (NILP (coding_system
)
5060 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5062 /* If we still have not decided a coding system, use the
5063 default value of buffer-file-coding-system. */
5064 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5068 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5069 /* Confirm that VAL can surely encode the current region. */
5070 coding_system
= call4 (Vselect_safe_coding_system_function
,
5071 make_number (b
), make_number (e
),
5072 coding_system
, Qnil
);
5075 coding_system
= Qraw_text
;
5078 if (NILP (Fcoding_system_p (coding_system
)))
5080 /* Invalid coding system. */
5082 if (!NILP (noerror
))
5083 coding_system
= Qraw_text
;
5085 xsignal1 (Qcoding_system_error
, coding_system
);
5089 object
= make_buffer_string (b
, e
, 0);
5090 if (prev
!= current_buffer
)
5091 set_buffer_internal (prev
);
5092 /* Discard the unwind protect for recovering the current
5096 if (STRING_MULTIBYTE (object
))
5097 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5100 md5_buffer (SDATA (object
) + start_byte
,
5101 SBYTES (object
) - (size_byte
- end_byte
),
5104 for (i
= 0; i
< 16; i
++)
5105 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5108 return make_string (value
, 32);
5115 /* Hash table stuff. */
5116 Qhash_table_p
= intern_c_string ("hash-table-p");
5117 staticpro (&Qhash_table_p
);
5118 Qeq
= intern_c_string ("eq");
5120 Qeql
= intern_c_string ("eql");
5122 Qequal
= intern_c_string ("equal");
5123 staticpro (&Qequal
);
5124 QCtest
= intern_c_string (":test");
5125 staticpro (&QCtest
);
5126 QCsize
= intern_c_string (":size");
5127 staticpro (&QCsize
);
5128 QCrehash_size
= intern_c_string (":rehash-size");
5129 staticpro (&QCrehash_size
);
5130 QCrehash_threshold
= intern_c_string (":rehash-threshold");
5131 staticpro (&QCrehash_threshold
);
5132 QCweakness
= intern_c_string (":weakness");
5133 staticpro (&QCweakness
);
5134 Qkey
= intern_c_string ("key");
5136 Qvalue
= intern_c_string ("value");
5137 staticpro (&Qvalue
);
5138 Qhash_table_test
= intern_c_string ("hash-table-test");
5139 staticpro (&Qhash_table_test
);
5140 Qkey_or_value
= intern_c_string ("key-or-value");
5141 staticpro (&Qkey_or_value
);
5142 Qkey_and_value
= intern_c_string ("key-and-value");
5143 staticpro (&Qkey_and_value
);
5146 defsubr (&Smake_hash_table
);
5147 defsubr (&Scopy_hash_table
);
5148 defsubr (&Shash_table_count
);
5149 defsubr (&Shash_table_rehash_size
);
5150 defsubr (&Shash_table_rehash_threshold
);
5151 defsubr (&Shash_table_size
);
5152 defsubr (&Shash_table_test
);
5153 defsubr (&Shash_table_weakness
);
5154 defsubr (&Shash_table_p
);
5155 defsubr (&Sclrhash
);
5156 defsubr (&Sgethash
);
5157 defsubr (&Sputhash
);
5158 defsubr (&Sremhash
);
5159 defsubr (&Smaphash
);
5160 defsubr (&Sdefine_hash_table_test
);
5162 Qstring_lessp
= intern_c_string ("string-lessp");
5163 staticpro (&Qstring_lessp
);
5164 Qprovide
= intern_c_string ("provide");
5165 staticpro (&Qprovide
);
5166 Qrequire
= intern_c_string ("require");
5167 staticpro (&Qrequire
);
5168 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
5169 staticpro (&Qyes_or_no_p_history
);
5170 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
5171 staticpro (&Qcursor_in_echo_area
);
5172 Qwidget_type
= intern_c_string ("widget-type");
5173 staticpro (&Qwidget_type
);
5175 staticpro (&string_char_byte_cache_string
);
5176 string_char_byte_cache_string
= Qnil
;
5178 require_nesting_list
= Qnil
;
5179 staticpro (&require_nesting_list
);
5181 Fset (Qyes_or_no_p_history
, Qnil
);
5183 DEFVAR_LISP ("features", &Vfeatures
,
5184 doc
: /* A list of symbols which are the features of the executing Emacs.
5185 Used by `featurep' and `require', and altered by `provide'. */);
5186 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
5187 Qsubfeatures
= intern_c_string ("subfeatures");
5188 staticpro (&Qsubfeatures
);
5190 #ifdef HAVE_LANGINFO_CODESET
5191 Qcodeset
= intern_c_string ("codeset");
5192 staticpro (&Qcodeset
);
5193 Qdays
= intern_c_string ("days");
5195 Qmonths
= intern_c_string ("months");
5196 staticpro (&Qmonths
);
5197 Qpaper
= intern_c_string ("paper");
5198 staticpro (&Qpaper
);
5199 #endif /* HAVE_LANGINFO_CODESET */
5201 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5202 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5203 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5204 invoked by mouse clicks and mouse menu items.
5206 On some platforms, file selection dialogs are also enabled if this is
5210 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5211 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5212 This applies to commands from menus and tool bar buttons even when
5213 they are initiated from the keyboard. If `use-dialog-box' is nil,
5214 that disables the use of a file dialog, regardless of the value of
5216 use_file_dialog
= 1;
5218 defsubr (&Sidentity
);
5221 defsubr (&Ssafe_length
);
5222 defsubr (&Sstring_bytes
);
5223 defsubr (&Sstring_equal
);
5224 defsubr (&Scompare_strings
);
5225 defsubr (&Sstring_lessp
);
5228 defsubr (&Svconcat
);
5229 defsubr (&Scopy_sequence
);
5230 defsubr (&Sstring_make_multibyte
);
5231 defsubr (&Sstring_make_unibyte
);
5232 defsubr (&Sstring_as_multibyte
);
5233 defsubr (&Sstring_as_unibyte
);
5234 defsubr (&Sstring_to_multibyte
);
5235 defsubr (&Sstring_to_unibyte
);
5236 defsubr (&Scopy_alist
);
5237 defsubr (&Ssubstring
);
5238 defsubr (&Ssubstring_no_properties
);
5251 defsubr (&Snreverse
);
5252 defsubr (&Sreverse
);
5254 defsubr (&Splist_get
);
5256 defsubr (&Splist_put
);
5258 defsubr (&Slax_plist_get
);
5259 defsubr (&Slax_plist_put
);
5262 defsubr (&Sequal_including_properties
);
5263 defsubr (&Sfillarray
);
5264 defsubr (&Sclear_string
);
5268 defsubr (&Smapconcat
);
5269 defsubr (&Sy_or_n_p
);
5270 defsubr (&Syes_or_no_p
);
5271 defsubr (&Sload_average
);
5272 defsubr (&Sfeaturep
);
5273 defsubr (&Srequire
);
5274 defsubr (&Sprovide
);
5275 defsubr (&Splist_member
);
5276 defsubr (&Swidget_put
);
5277 defsubr (&Swidget_get
);
5278 defsubr (&Swidget_apply
);
5279 defsubr (&Sbase64_encode_region
);
5280 defsubr (&Sbase64_decode_region
);
5281 defsubr (&Sbase64_encode_string
);
5282 defsubr (&Sbase64_decode_string
);
5284 defsubr (&Slocale_info
);
5293 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5294 (do not change this comment) */