1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
31 /* On Mac OS, defining this conflicts with precompiled headers. */
33 /* Note on some machines this defines `vector' as a typedef,
34 so make sure we don't use that name in this file. */
38 #endif /* ! MAC_OSX */
42 #include "character.h"
47 #include "intervals.h"
50 #include "blockinput.h"
52 #if defined (HAVE_X_WINDOWS)
54 #elif defined (MAC_OS)
60 #define NULL ((POINTER_TYPE *)0)
63 /* Nonzero enables use of dialog boxes for questions
64 asked by mouse commands. */
67 /* Nonzero enables use of a file dialog for file name
68 questions asked by mouse commands. */
71 extern int minibuffer_auto_raise
;
72 extern Lisp_Object minibuf_window
;
73 extern Lisp_Object Vlocale_coding_system
;
74 extern int load_in_progress
;
76 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
77 Lisp_Object Qyes_or_no_p_history
;
78 Lisp_Object Qcursor_in_echo_area
;
79 Lisp_Object Qwidget_type
;
80 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
82 extern Lisp_Object Qinput_method_function
;
84 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
86 extern long get_random ();
87 extern void seed_random
P_ ((long));
93 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
94 doc
: /* Return the argument unchanged. */)
101 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
102 doc
: /* Return a pseudo-random number.
103 All integers representable in Lisp are equally likely.
104 On most systems, this is 29 bits' worth.
105 With positive integer argument N, return random number in interval [0,N).
106 With argument t, set the random number seed from the current time and pid. */)
111 Lisp_Object lispy_val
;
112 unsigned long denominator
;
115 seed_random (getpid () + time (NULL
));
116 if (NATNUMP (n
) && XFASTINT (n
) != 0)
118 /* Try to take our random number from the higher bits of VAL,
119 not the lower, since (says Gentzel) the low bits of `random'
120 are less random than the higher ones. We do this by using the
121 quotient rather than the remainder. At the high end of the RNG
122 it's possible to get a quotient larger than n; discarding
123 these values eliminates the bias that would otherwise appear
124 when using a large n. */
125 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
127 val
= get_random () / denominator
;
128 while (val
>= XFASTINT (n
));
132 XSETINT (lispy_val
, val
);
136 /* Random data-structure functions */
138 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
139 doc
: /* Return the length of vector, list or string SEQUENCE.
140 A byte-code function object is also allowed.
141 If the string contains multibyte characters, this is not necessarily
142 the number of bytes in the string; it is the number of characters.
143 To get the number of bytes, use `string-bytes'. */)
145 register Lisp_Object sequence
;
147 register Lisp_Object val
;
150 if (STRINGP (sequence
))
151 XSETFASTINT (val
, SCHARS (sequence
));
152 else if (VECTORP (sequence
))
153 XSETFASTINT (val
, ASIZE (sequence
));
154 else if (CHAR_TABLE_P (sequence
))
155 XSETFASTINT (val
, MAX_CHAR
);
156 else if (BOOL_VECTOR_P (sequence
))
157 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
158 else if (COMPILEDP (sequence
))
159 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
160 else if (CONSP (sequence
))
163 while (CONSP (sequence
))
165 sequence
= XCDR (sequence
);
168 if (!CONSP (sequence
))
171 sequence
= XCDR (sequence
);
176 CHECK_LIST_END (sequence
, sequence
);
178 val
= make_number (i
);
180 else if (NILP (sequence
))
181 XSETFASTINT (val
, 0);
183 wrong_type_argument (Qsequencep
, sequence
);
188 /* This does not check for quits. That is safe since it must terminate. */
190 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
191 doc
: /* Return the length of a list, but avoid error or infinite loop.
192 This function never gets an error. If LIST is not really a list,
193 it returns 0. If LIST is circular, it returns a finite value
194 which is at least the number of distinct elements. */)
198 Lisp_Object tail
, halftail
, length
;
201 /* halftail is used to detect circular lists. */
203 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
205 if (EQ (tail
, halftail
) && len
!= 0)
209 halftail
= XCDR (halftail
);
212 XSETINT (length
, len
);
216 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
217 doc
: /* Return the number of bytes in STRING.
218 If STRING is multibyte, this may be greater than the length of STRING. */)
222 CHECK_STRING (string
);
223 return make_number (SBYTES (string
));
226 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
227 doc
: /* Return t if two strings have identical contents.
228 Case is significant, but text properties are ignored.
229 Symbols are also allowed; their print names are used instead. */)
231 register Lisp_Object s1
, s2
;
234 s1
= SYMBOL_NAME (s1
);
236 s2
= SYMBOL_NAME (s2
);
240 if (SCHARS (s1
) != SCHARS (s2
)
241 || SBYTES (s1
) != SBYTES (s2
)
242 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
247 DEFUN ("compare-strings", Fcompare_strings
,
248 Scompare_strings
, 6, 7, 0,
249 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
250 In string STR1, skip the first START1 characters and stop at END1.
251 In string STR2, skip the first START2 characters and stop at END2.
252 END1 and END2 default to the full lengths of the respective strings.
254 Case is significant in this comparison if IGNORE-CASE is nil.
255 Unibyte strings are converted to multibyte for comparison.
257 The value is t if the strings (or specified portions) match.
258 If string STR1 is less, the value is a negative number N;
259 - 1 - N is the number of characters that match at the beginning.
260 If string STR1 is greater, the value is a positive number N;
261 N - 1 is the number of characters that match at the beginning. */)
262 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
263 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
265 register int end1_char
, end2_char
;
266 register int i1
, i1_byte
, i2
, i2_byte
;
271 start1
= make_number (0);
273 start2
= make_number (0);
274 CHECK_NATNUM (start1
);
275 CHECK_NATNUM (start2
);
284 i1_byte
= string_char_to_byte (str1
, i1
);
285 i2_byte
= string_char_to_byte (str2
, i2
);
287 end1_char
= SCHARS (str1
);
288 if (! NILP (end1
) && end1_char
> XINT (end1
))
289 end1_char
= XINT (end1
);
291 end2_char
= SCHARS (str2
);
292 if (! NILP (end2
) && end2_char
> XINT (end2
))
293 end2_char
= XINT (end2
);
295 while (i1
< end1_char
&& i2
< end2_char
)
297 /* When we find a mismatch, we must compare the
298 characters, not just the bytes. */
301 if (STRING_MULTIBYTE (str1
))
302 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
305 c1
= SREF (str1
, i1
++);
306 c1
= unibyte_char_to_multibyte (c1
);
309 if (STRING_MULTIBYTE (str2
))
310 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
313 c2
= SREF (str2
, i2
++);
314 c2
= unibyte_char_to_multibyte (c2
);
320 if (! NILP (ignore_case
))
324 tem
= Fupcase (make_number (c1
));
326 tem
= Fupcase (make_number (c2
));
333 /* Note that I1 has already been incremented
334 past the character that we are comparing;
335 hence we don't add or subtract 1 here. */
337 return make_number (- i1
+ XINT (start1
));
339 return make_number (i1
- XINT (start1
));
343 return make_number (i1
- XINT (start1
) + 1);
345 return make_number (- i1
+ XINT (start1
) - 1);
350 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
351 doc
: /* Return t if first arg string is less than second in lexicographic order.
353 Symbols are also allowed; their print names are used instead. */)
355 register Lisp_Object s1
, s2
;
358 register int i1
, i1_byte
, i2
, i2_byte
;
361 s1
= SYMBOL_NAME (s1
);
363 s2
= SYMBOL_NAME (s2
);
367 i1
= i1_byte
= i2
= i2_byte
= 0;
370 if (end
> SCHARS (s2
))
375 /* When we find a mismatch, we must compare the
376 characters, not just the bytes. */
379 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
380 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
383 return c1
< c2
? Qt
: Qnil
;
385 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
389 /* "gcc -O3" enables automatic function inlining, which optimizes out
390 the arguments for the invocations of this function, whereas it
391 expects these values on the stack. */
392 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)) __attribute__((noinline
));
393 #else /* !__GNUC__ */
394 static Lisp_Object concat
P_ ((int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
));
406 return concat (2, args
, Lisp_String
, 0);
408 return concat (2, &s1
, Lisp_String
, 0);
409 #endif /* NO_ARG_ARRAY */
415 Lisp_Object s1
, s2
, s3
;
422 return concat (3, args
, Lisp_String
, 0);
424 return concat (3, &s1
, Lisp_String
, 0);
425 #endif /* NO_ARG_ARRAY */
428 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
429 doc
: /* Concatenate all the arguments and make the result a list.
430 The result is a list whose elements are the elements of all the arguments.
431 Each argument may be a list, vector or string.
432 The last argument is not copied, just used as the tail of the new list.
433 usage: (append &rest SEQUENCES) */)
438 return concat (nargs
, args
, Lisp_Cons
, 1);
441 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
442 doc
: /* Concatenate all the arguments and make the result a string.
443 The result is a string whose elements are the elements of all the arguments.
444 Each argument may be a string or a list or vector of characters (integers).
445 usage: (concat &rest SEQUENCES) */)
450 return concat (nargs
, args
, Lisp_String
, 0);
453 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
454 doc
: /* Concatenate all the arguments and make the result a vector.
455 The result is a vector whose elements are the elements of all the arguments.
456 Each argument may be a list, vector or string.
457 usage: (vconcat &rest SEQUENCES) */)
462 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
466 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
467 doc
: /* Return a copy of a list, vector, string or char-table.
468 The elements of a list or vector are not copied; they are shared
469 with the original. */)
473 if (NILP (arg
)) return arg
;
475 if (CHAR_TABLE_P (arg
))
477 return copy_char_table (arg
);
480 if (BOOL_VECTOR_P (arg
))
484 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
485 / BOOL_VECTOR_BITS_PER_CHAR
);
487 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
488 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
493 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
494 wrong_type_argument (Qsequencep
, arg
);
496 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
499 /* This structure holds information of an argument of `concat' that is
500 a string and has text properties to be copied. */
503 int argnum
; /* refer to ARGS (arguments of `concat') */
504 int from
; /* refer to ARGS[argnum] (argument string) */
505 int to
; /* refer to VAL (the target string) */
509 concat (nargs
, args
, target_type
, last_special
)
512 enum Lisp_Type target_type
;
516 register Lisp_Object tail
;
517 register Lisp_Object
this;
519 int toindex_byte
= 0;
520 register int result_len
;
521 register int result_len_byte
;
523 Lisp_Object last_tail
;
526 /* When we make a multibyte string, we can't copy text properties
527 while concatinating each string because the length of resulting
528 string can't be decided until we finish the whole concatination.
529 So, we record strings that have text properties to be copied
530 here, and copy the text properties after the concatination. */
531 struct textprop_rec
*textprops
= NULL
;
532 /* Number of elments in textprops. */
533 int num_textprops
= 0;
538 /* In append, the last arg isn't treated like the others */
539 if (last_special
&& nargs
> 0)
542 last_tail
= args
[nargs
];
547 /* Check each argument. */
548 for (argnum
= 0; argnum
< nargs
; argnum
++)
551 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
552 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
553 wrong_type_argument (Qsequencep
, this);
556 /* Compute total length in chars of arguments in RESULT_LEN.
557 If desired output is a string, also compute length in bytes
558 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
559 whether the result should be a multibyte string. */
563 for (argnum
= 0; argnum
< nargs
; argnum
++)
567 len
= XFASTINT (Flength (this));
568 if (target_type
== Lisp_String
)
570 /* We must count the number of bytes needed in the string
571 as well as the number of characters. */
577 for (i
= 0; i
< len
; i
++)
580 CHECK_CHARACTER (ch
);
581 this_len_byte
= CHAR_BYTES (XINT (ch
));
582 result_len_byte
+= this_len_byte
;
583 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
586 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
587 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
588 else if (CONSP (this))
589 for (; CONSP (this); this = XCDR (this))
592 CHECK_CHARACTER (ch
);
593 this_len_byte
= CHAR_BYTES (XINT (ch
));
594 result_len_byte
+= this_len_byte
;
595 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
598 else if (STRINGP (this))
600 if (STRING_MULTIBYTE (this))
603 result_len_byte
+= SBYTES (this);
606 result_len_byte
+= count_size_as_multibyte (SDATA (this),
614 if (! some_multibyte
)
615 result_len_byte
= result_len
;
617 /* Create the output object. */
618 if (target_type
== Lisp_Cons
)
619 val
= Fmake_list (make_number (result_len
), Qnil
);
620 else if (target_type
== Lisp_Vectorlike
)
621 val
= Fmake_vector (make_number (result_len
), Qnil
);
622 else if (some_multibyte
)
623 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
625 val
= make_uninit_string (result_len
);
627 /* In `append', if all but last arg are nil, return last arg. */
628 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
631 /* Copy the contents of the args into the result. */
633 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
635 toindex
= 0, toindex_byte
= 0;
639 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
641 for (argnum
= 0; argnum
< nargs
; argnum
++)
645 register unsigned int thisindex
= 0;
646 register unsigned int thisindex_byte
= 0;
650 thislen
= Flength (this), thisleni
= XINT (thislen
);
652 /* Between strings of the same kind, copy fast. */
653 if (STRINGP (this) && STRINGP (val
)
654 && STRING_MULTIBYTE (this) == some_multibyte
)
656 int thislen_byte
= SBYTES (this);
658 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
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
+= thislen_byte
;
668 STRING_SET_CHARS (val
, SCHARS (val
));
670 /* Copy a single-byte string to a multibyte string. */
671 else if (STRINGP (this) && STRINGP (val
))
673 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
675 textprops
[num_textprops
].argnum
= argnum
;
676 textprops
[num_textprops
].from
= 0;
677 textprops
[num_textprops
++].to
= toindex
;
679 toindex_byte
+= copy_text (SDATA (this),
680 SDATA (val
) + toindex_byte
,
681 SCHARS (this), 0, 1);
685 /* Copy element by element. */
688 register Lisp_Object elt
;
690 /* Fetch next element of `this' arg into `elt', or break if
691 `this' is exhausted. */
692 if (NILP (this)) break;
694 elt
= XCAR (this), this = XCDR (this);
695 else if (thisindex
>= thisleni
)
697 else if (STRINGP (this))
700 if (STRING_MULTIBYTE (this))
702 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
705 XSETFASTINT (elt
, c
);
709 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
711 && XINT (elt
) >= 0200
712 && XINT (elt
) < 0400)
714 c
= unibyte_char_to_multibyte (XINT (elt
));
719 else if (BOOL_VECTOR_P (this))
722 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
723 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
730 elt
= AREF (this, thisindex
++);
732 /* Store this element into the result. */
739 else if (VECTORP (val
))
740 AREF (val
, toindex
++) = elt
;
745 toindex_byte
+= CHAR_STRING (XINT (elt
),
746 SDATA (val
) + toindex_byte
);
748 SSET (val
, toindex_byte
++, XINT (elt
));
754 XSETCDR (prev
, last_tail
);
756 if (num_textprops
> 0)
759 int last_to_end
= -1;
761 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
763 this = args
[textprops
[argnum
].argnum
];
764 props
= text_property_list (this,
766 make_number (SCHARS (this)),
768 /* If successive arguments have properites, be sure that the
769 value of `composition' property be the copy. */
770 if (last_to_end
== textprops
[argnum
].to
)
771 make_composition_value_copy (props
);
772 add_text_properties_from_list (val
, props
,
773 make_number (textprops
[argnum
].to
));
774 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
782 static Lisp_Object string_char_byte_cache_string
;
783 static int string_char_byte_cache_charpos
;
784 static int string_char_byte_cache_bytepos
;
787 clear_string_char_byte_cache ()
789 string_char_byte_cache_string
= Qnil
;
792 /* Return the character index corresponding to CHAR_INDEX in STRING. */
795 string_char_to_byte (string
, char_index
)
800 int best_below
, best_below_byte
;
801 int best_above
, best_above_byte
;
803 best_below
= best_below_byte
= 0;
804 best_above
= SCHARS (string
);
805 best_above_byte
= SBYTES (string
);
806 if (best_above
== best_above_byte
)
809 if (EQ (string
, string_char_byte_cache_string
))
811 if (string_char_byte_cache_charpos
< char_index
)
813 best_below
= string_char_byte_cache_charpos
;
814 best_below_byte
= string_char_byte_cache_bytepos
;
818 best_above
= string_char_byte_cache_charpos
;
819 best_above_byte
= string_char_byte_cache_bytepos
;
823 if (char_index
- best_below
< best_above
- char_index
)
825 unsigned char *p
= SDATA (string
) + best_below_byte
;
827 while (best_below
< char_index
)
829 p
+= BYTES_BY_CHAR_HEAD (*p
);
832 i_byte
= p
- SDATA (string
);
836 unsigned char *p
= SDATA (string
) + best_above_byte
;
838 while (best_above
> char_index
)
841 while (!CHAR_HEAD_P (*p
)) p
--;
844 i_byte
= p
- SDATA (string
);
847 string_char_byte_cache_bytepos
= i_byte
;
848 string_char_byte_cache_charpos
= char_index
;
849 string_char_byte_cache_string
= string
;
854 /* Return the character index corresponding to BYTE_INDEX in STRING. */
857 string_byte_to_char (string
, byte_index
)
862 int best_below
, best_below_byte
;
863 int best_above
, best_above_byte
;
865 best_below
= best_below_byte
= 0;
866 best_above
= SCHARS (string
);
867 best_above_byte
= SBYTES (string
);
868 if (best_above
== best_above_byte
)
871 if (EQ (string
, string_char_byte_cache_string
))
873 if (string_char_byte_cache_bytepos
< byte_index
)
875 best_below
= string_char_byte_cache_charpos
;
876 best_below_byte
= string_char_byte_cache_bytepos
;
880 best_above
= string_char_byte_cache_charpos
;
881 best_above_byte
= string_char_byte_cache_bytepos
;
885 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
887 unsigned char *p
= SDATA (string
) + best_below_byte
;
888 unsigned char *pend
= SDATA (string
) + byte_index
;
892 p
+= BYTES_BY_CHAR_HEAD (*p
);
896 i_byte
= p
- SDATA (string
);
900 unsigned char *p
= SDATA (string
) + best_above_byte
;
901 unsigned char *pbeg
= SDATA (string
) + byte_index
;
906 while (!CHAR_HEAD_P (*p
)) p
--;
910 i_byte
= p
- SDATA (string
);
913 string_char_byte_cache_bytepos
= i_byte
;
914 string_char_byte_cache_charpos
= i
;
915 string_char_byte_cache_string
= string
;
920 /* Convert STRING to a multibyte string. */
923 string_make_multibyte (string
)
931 if (STRING_MULTIBYTE (string
))
934 nbytes
= count_size_as_multibyte (SDATA (string
),
936 /* If all the chars are ASCII, they won't need any more bytes
937 once converted. In that case, we can return STRING itself. */
938 if (nbytes
== SBYTES (string
))
941 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
942 copy_text (SDATA (string
), buf
, SBYTES (string
),
945 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
952 /* Convert STRING (if unibyte) to a multibyte string without changing
953 the number of characters. Characters 0200 trough 0237 are
954 converted to eight-bit characters. */
957 string_to_multibyte (string
)
965 if (STRING_MULTIBYTE (string
))
968 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
969 /* If all the chars are ASCII, they won't need any more bytes once
971 if (nbytes
== SBYTES (string
))
972 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
974 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
975 bcopy (SDATA (string
), buf
, SBYTES (string
));
976 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
978 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
985 /* Convert STRING to a single-byte string. */
988 string_make_unibyte (string
)
996 if (! STRING_MULTIBYTE (string
))
999 nchars
= SCHARS (string
);
1001 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1002 copy_text (SDATA (string
), buf
, SBYTES (string
),
1005 ret
= make_unibyte_string (buf
, nchars
);
1011 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1013 doc
: /* Return the multibyte equivalent of STRING.
1014 If STRING is unibyte and contains non-ASCII characters, the function
1015 `unibyte-char-to-multibyte' is used to convert each unibyte character
1016 to a multibyte character. In this case, the returned string is a
1017 newly created string with no text properties. If STRING is multibyte
1018 or entirely ASCII, it is returned unchanged. In particular, when
1019 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1020 \(When the characters are all ASCII, Emacs primitives will treat the
1021 string the same way whether it is unibyte or multibyte.) */)
1025 CHECK_STRING (string
);
1027 return string_make_multibyte (string
);
1030 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1032 doc
: /* Return the unibyte equivalent of STRING.
1033 Multibyte character codes are converted to unibyte according to
1034 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1035 If the lookup in the translation table fails, this function takes just
1036 the low 8 bits of each character. */)
1040 CHECK_STRING (string
);
1042 return string_make_unibyte (string
);
1045 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1047 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1048 If STRING is unibyte, the result is STRING itself.
1049 Otherwise it is a newly created string, with no text properties.
1050 If STRING is multibyte and contains a character of charset
1051 `eight-bit', it is converted to the corresponding single byte. */)
1055 CHECK_STRING (string
);
1057 if (STRING_MULTIBYTE (string
))
1059 int bytes
= SBYTES (string
);
1060 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1062 bcopy (SDATA (string
), str
, bytes
);
1063 bytes
= str_as_unibyte (str
, bytes
);
1064 string
= make_unibyte_string (str
, bytes
);
1070 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1072 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1073 If STRING is multibyte, the result is STRING itself.
1074 Otherwise it is a newly created string, with no text properties.
1076 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1077 part of a correct utf-8 sequence), it is converted to the corresponding
1078 multibyte character of charset `eight-bit'.
1079 See also `string-to-multibyte'.
1081 Beware, this often doesn't really do what you think it does.
1082 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1083 If you're not sure, whether to use `string-as-multibyte' or
1084 `string-to-multibyte', use `string-to-multibyte'. */)
1088 CHECK_STRING (string
);
1090 if (! STRING_MULTIBYTE (string
))
1092 Lisp_Object new_string
;
1095 parse_str_as_multibyte (SDATA (string
),
1098 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1099 bcopy (SDATA (string
), SDATA (new_string
),
1101 if (nbytes
!= SBYTES (string
))
1102 str_as_multibyte (SDATA (new_string
), nbytes
,
1103 SBYTES (string
), NULL
);
1104 string
= new_string
;
1105 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1110 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1112 doc
: /* Return a multibyte string with the same individual chars as STRING.
1113 If STRING is multibyte, the result is STRING itself.
1114 Otherwise it is a newly created string, with no text properties.
1116 If STRING is unibyte and contains an 8-bit byte, it is converted to
1117 the corresponding multibyte character of charset `eight-bit'.
1119 This differs from `string-as-multibyte' by converting each byte of a correct
1120 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1121 correct sequence. */)
1125 CHECK_STRING (string
);
1127 return string_to_multibyte (string
);
1131 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1132 doc
: /* Return a copy of ALIST.
1133 This is an alist which represents the same mapping from objects to objects,
1134 but does not share the alist structure with ALIST.
1135 The objects mapped (cars and cdrs of elements of the alist)
1136 are shared, however.
1137 Elements of ALIST that are not conses are also shared. */)
1141 register Lisp_Object tem
;
1146 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1147 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1149 register Lisp_Object car
;
1153 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1158 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1159 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1160 TO may be nil or omitted; then the substring runs to the end of STRING.
1161 FROM and TO start at 0. If either is negative, it counts from the end.
1163 This function allows vectors as well as strings. */)
1166 register Lisp_Object from
, to
;
1171 int from_char
, to_char
;
1172 int from_byte
= 0, to_byte
= 0;
1174 CHECK_VECTOR_OR_STRING (string
);
1175 CHECK_NUMBER (from
);
1177 if (STRINGP (string
))
1179 size
= SCHARS (string
);
1180 size_byte
= SBYTES (string
);
1183 size
= ASIZE (string
);
1188 to_byte
= size_byte
;
1194 to_char
= XINT (to
);
1198 if (STRINGP (string
))
1199 to_byte
= string_char_to_byte (string
, to_char
);
1202 from_char
= XINT (from
);
1205 if (STRINGP (string
))
1206 from_byte
= string_char_to_byte (string
, from_char
);
1208 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1209 args_out_of_range_3 (string
, make_number (from_char
),
1210 make_number (to_char
));
1212 if (STRINGP (string
))
1214 res
= make_specified_string (SDATA (string
) + from_byte
,
1215 to_char
- from_char
, to_byte
- from_byte
,
1216 STRING_MULTIBYTE (string
));
1217 copy_text_properties (make_number (from_char
), make_number (to_char
),
1218 string
, make_number (0), res
, Qnil
);
1221 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1227 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1228 doc
: /* Return a substring of STRING, without text properties.
1229 It starts at index FROM and ending before TO.
1230 TO may be nil or omitted; then the substring runs to the end of STRING.
1231 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1232 If FROM or TO is negative, it counts from the end.
1234 With one argument, just copy STRING without its properties. */)
1237 register Lisp_Object from
, to
;
1239 int size
, size_byte
;
1240 int from_char
, to_char
;
1241 int from_byte
, to_byte
;
1243 CHECK_STRING (string
);
1245 size
= SCHARS (string
);
1246 size_byte
= SBYTES (string
);
1249 from_char
= from_byte
= 0;
1252 CHECK_NUMBER (from
);
1253 from_char
= XINT (from
);
1257 from_byte
= string_char_to_byte (string
, from_char
);
1263 to_byte
= size_byte
;
1269 to_char
= XINT (to
);
1273 to_byte
= string_char_to_byte (string
, to_char
);
1276 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1277 args_out_of_range_3 (string
, make_number (from_char
),
1278 make_number (to_char
));
1280 return make_specified_string (SDATA (string
) + from_byte
,
1281 to_char
- from_char
, to_byte
- from_byte
,
1282 STRING_MULTIBYTE (string
));
1285 /* Extract a substring of STRING, giving start and end positions
1286 both in characters and in bytes. */
1289 substring_both (string
, from
, from_byte
, to
, to_byte
)
1291 int from
, from_byte
, to
, to_byte
;
1297 CHECK_VECTOR_OR_STRING (string
);
1299 if (STRINGP (string
))
1301 size
= SCHARS (string
);
1302 size_byte
= SBYTES (string
);
1305 size
= ASIZE (string
);
1307 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1308 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1310 if (STRINGP (string
))
1312 res
= make_specified_string (SDATA (string
) + from_byte
,
1313 to
- from
, to_byte
- from_byte
,
1314 STRING_MULTIBYTE (string
));
1315 copy_text_properties (make_number (from
), make_number (to
),
1316 string
, make_number (0), res
, Qnil
);
1319 res
= Fvector (to
- from
, &AREF (string
, from
));
1324 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1325 doc
: /* Take cdr N times on LIST, returns the result. */)
1328 register Lisp_Object list
;
1330 register int i
, num
;
1333 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1336 CHECK_LIST_CONS (list
, list
);
1342 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1343 doc
: /* Return the Nth element of LIST.
1344 N counts from zero. If LIST is not that long, nil is returned. */)
1346 Lisp_Object n
, list
;
1348 return Fcar (Fnthcdr (n
, list
));
1351 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1352 doc
: /* Return element of SEQUENCE at index N. */)
1354 register Lisp_Object sequence
, n
;
1357 if (CONSP (sequence
) || NILP (sequence
))
1358 return Fcar (Fnthcdr (n
, sequence
));
1360 /* Faref signals a "not array" error, so check here. */
1361 CHECK_ARRAY (sequence
, Qsequencep
);
1362 return Faref (sequence
, n
);
1365 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1366 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1367 The value is actually the tail of LIST whose car is ELT. */)
1369 register Lisp_Object elt
;
1372 register Lisp_Object tail
;
1373 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1375 register Lisp_Object tem
;
1376 CHECK_LIST_CONS (tail
, list
);
1378 if (! NILP (Fequal (elt
, tem
)))
1385 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1386 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1387 The value is actually the tail of LIST whose car is ELT. */)
1389 register Lisp_Object elt
, list
;
1393 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1397 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1401 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1412 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1413 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1414 The value is actually the tail of LIST whose car is ELT. */)
1416 register Lisp_Object elt
;
1419 register Lisp_Object tail
;
1422 return Fmemq (elt
, list
);
1424 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1426 register Lisp_Object tem
;
1427 CHECK_LIST_CONS (tail
, list
);
1429 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1436 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1437 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1438 The value is actually the first element of LIST whose car is KEY.
1439 Elements of LIST that are not conses are ignored. */)
1441 Lisp_Object key
, list
;
1446 || (CONSP (XCAR (list
))
1447 && EQ (XCAR (XCAR (list
)), key
)))
1452 || (CONSP (XCAR (list
))
1453 && EQ (XCAR (XCAR (list
)), key
)))
1458 || (CONSP (XCAR (list
))
1459 && EQ (XCAR (XCAR (list
)), key
)))
1469 /* Like Fassq but never report an error and do not allow quits.
1470 Use only on lists known never to be circular. */
1473 assq_no_quit (key
, list
)
1474 Lisp_Object key
, list
;
1477 && (!CONSP (XCAR (list
))
1478 || !EQ (XCAR (XCAR (list
)), key
)))
1481 return CAR_SAFE (list
);
1484 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1485 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1486 The value is actually the first element of LIST whose car equals KEY. */)
1488 Lisp_Object key
, list
;
1495 || (CONSP (XCAR (list
))
1496 && (car
= XCAR (XCAR (list
)),
1497 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1502 || (CONSP (XCAR (list
))
1503 && (car
= XCAR (XCAR (list
)),
1504 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1509 || (CONSP (XCAR (list
))
1510 && (car
= XCAR (XCAR (list
)),
1511 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1521 /* Like Fassoc but never report an error and do not allow quits.
1522 Use only on lists known never to be circular. */
1525 assoc_no_quit (key
, list
)
1526 Lisp_Object key
, list
;
1529 && (!CONSP (XCAR (list
))
1530 || (!EQ (XCAR (XCAR (list
)), key
)
1531 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1534 return CONSP (list
) ? XCAR (list
) : Qnil
;
1537 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1538 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1539 The value is actually the first element of LIST whose cdr is KEY. */)
1541 register Lisp_Object key
;
1547 || (CONSP (XCAR (list
))
1548 && EQ (XCDR (XCAR (list
)), key
)))
1553 || (CONSP (XCAR (list
))
1554 && EQ (XCDR (XCAR (list
)), key
)))
1559 || (CONSP (XCAR (list
))
1560 && EQ (XCDR (XCAR (list
)), key
)))
1570 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1571 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1572 The value is actually the first element of LIST whose cdr equals KEY. */)
1574 Lisp_Object key
, list
;
1581 || (CONSP (XCAR (list
))
1582 && (cdr
= XCDR (XCAR (list
)),
1583 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1588 || (CONSP (XCAR (list
))
1589 && (cdr
= XCDR (XCAR (list
)),
1590 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1595 || (CONSP (XCAR (list
))
1596 && (cdr
= XCDR (XCAR (list
)),
1597 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1607 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1608 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1609 The modified LIST is returned. Comparison is done with `eq'.
1610 If the first member of LIST is ELT, there is no way to remove it by side effect;
1611 therefore, write `(setq foo (delq element foo))'
1612 to be sure of changing the value of `foo'. */)
1614 register Lisp_Object elt
;
1617 register Lisp_Object tail
, prev
;
1618 register Lisp_Object tem
;
1622 while (!NILP (tail
))
1624 CHECK_LIST_CONS (tail
, list
);
1631 Fsetcdr (prev
, XCDR (tail
));
1641 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1642 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1643 SEQ must be a list, a vector, or a string.
1644 The modified SEQ is returned. Comparison is done with `equal'.
1645 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1646 is not a side effect; it is simply using a different sequence.
1647 Therefore, write `(setq foo (delete element foo))'
1648 to be sure of changing the value of `foo'. */)
1650 Lisp_Object elt
, seq
;
1656 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1657 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1660 if (n
!= ASIZE (seq
))
1662 struct Lisp_Vector
*p
= allocate_vector (n
);
1664 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1665 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1666 p
->contents
[n
++] = AREF (seq
, i
);
1668 XSETVECTOR (seq
, p
);
1671 else if (STRINGP (seq
))
1673 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1676 for (i
= nchars
= nbytes
= ibyte
= 0;
1678 ++i
, ibyte
+= cbytes
)
1680 if (STRING_MULTIBYTE (seq
))
1682 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1683 SBYTES (seq
) - ibyte
);
1684 cbytes
= CHAR_BYTES (c
);
1692 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1699 if (nchars
!= SCHARS (seq
))
1703 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1704 if (!STRING_MULTIBYTE (seq
))
1705 STRING_SET_UNIBYTE (tem
);
1707 for (i
= nchars
= nbytes
= ibyte
= 0;
1709 ++i
, ibyte
+= cbytes
)
1711 if (STRING_MULTIBYTE (seq
))
1713 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1714 SBYTES (seq
) - ibyte
);
1715 cbytes
= CHAR_BYTES (c
);
1723 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1725 unsigned char *from
= SDATA (seq
) + ibyte
;
1726 unsigned char *to
= SDATA (tem
) + nbytes
;
1732 for (n
= cbytes
; n
--; )
1742 Lisp_Object tail
, prev
;
1744 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1746 CHECK_LIST_CONS (tail
, seq
);
1748 if (!NILP (Fequal (elt
, XCAR (tail
))))
1753 Fsetcdr (prev
, XCDR (tail
));
1764 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1765 doc
: /* Reverse LIST by modifying cdr pointers.
1766 Return the reversed list. */)
1770 register Lisp_Object prev
, tail
, next
;
1772 if (NILP (list
)) return list
;
1775 while (!NILP (tail
))
1778 CHECK_LIST_CONS (tail
, list
);
1780 Fsetcdr (tail
, prev
);
1787 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1788 doc
: /* Reverse LIST, copying. Return the reversed list.
1789 See also the function `nreverse', which is used more often. */)
1795 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1798 new = Fcons (XCAR (list
), new);
1800 CHECK_LIST_END (list
, list
);
1804 Lisp_Object
merge ();
1806 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1807 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1808 Returns the sorted list. LIST is modified by side effects.
1809 PREDICATE is called with two elements of LIST, and should return non-nil
1810 if the first element should sort before the second. */)
1812 Lisp_Object list
, predicate
;
1814 Lisp_Object front
, back
;
1815 register Lisp_Object len
, tem
;
1816 struct gcpro gcpro1
, gcpro2
;
1817 register int length
;
1820 len
= Flength (list
);
1821 length
= XINT (len
);
1825 XSETINT (len
, (length
/ 2) - 1);
1826 tem
= Fnthcdr (len
, list
);
1828 Fsetcdr (tem
, Qnil
);
1830 GCPRO2 (front
, back
);
1831 front
= Fsort (front
, predicate
);
1832 back
= Fsort (back
, predicate
);
1834 return merge (front
, back
, predicate
);
1838 merge (org_l1
, org_l2
, pred
)
1839 Lisp_Object org_l1
, org_l2
;
1843 register Lisp_Object tail
;
1845 register Lisp_Object l1
, l2
;
1846 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1853 /* It is sufficient to protect org_l1 and org_l2.
1854 When l1 and l2 are updated, we copy the new values
1855 back into the org_ vars. */
1856 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1876 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1892 Fsetcdr (tail
, tem
);
1898 #if 0 /* Unsafe version. */
1899 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1900 doc
: /* Extract a value from a property list.
1901 PLIST is a property list, which is a list of the form
1902 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1903 corresponding to the given PROP, or nil if PROP is not
1904 one of the properties on the list. */)
1912 CONSP (tail
) && CONSP (XCDR (tail
));
1913 tail
= XCDR (XCDR (tail
)))
1915 if (EQ (prop
, XCAR (tail
)))
1916 return XCAR (XCDR (tail
));
1918 /* This function can be called asynchronously
1919 (setup_coding_system). Don't QUIT in that case. */
1920 if (!interrupt_input_blocked
)
1924 CHECK_LIST_END (tail
, prop
);
1930 /* This does not check for quits. That is safe since it must terminate. */
1932 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1933 doc
: /* Extract a value from a property list.
1934 PLIST is a property list, which is a list of the form
1935 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1936 corresponding to the given PROP, or nil if PROP is not one of the
1937 properties on the list. This function never signals an error. */)
1942 Lisp_Object tail
, halftail
;
1944 /* halftail is used to detect circular lists. */
1945 tail
= halftail
= plist
;
1946 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1948 if (EQ (prop
, XCAR (tail
)))
1949 return XCAR (XCDR (tail
));
1951 tail
= XCDR (XCDR (tail
));
1952 halftail
= XCDR (halftail
);
1953 if (EQ (tail
, halftail
))
1960 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1961 doc
: /* Return the value of SYMBOL's PROPNAME property.
1962 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1964 Lisp_Object symbol
, propname
;
1966 CHECK_SYMBOL (symbol
);
1967 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1970 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1971 doc
: /* Change value in PLIST of PROP to VAL.
1972 PLIST is a property list, which is a list of the form
1973 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1974 If PROP is already a property on the list, its value is set to VAL,
1975 otherwise the new PROP VAL pair is added. The new plist is returned;
1976 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1977 The PLIST is modified by side effects. */)
1980 register Lisp_Object prop
;
1983 register Lisp_Object tail
, prev
;
1984 Lisp_Object newcell
;
1986 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1987 tail
= XCDR (XCDR (tail
)))
1989 if (EQ (prop
, XCAR (tail
)))
1991 Fsetcar (XCDR (tail
), val
);
1998 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2002 Fsetcdr (XCDR (prev
), newcell
);
2006 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2007 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2008 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2009 (symbol
, propname
, value
)
2010 Lisp_Object symbol
, propname
, value
;
2012 CHECK_SYMBOL (symbol
);
2013 XSYMBOL (symbol
)->plist
2014 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2018 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2019 doc
: /* Extract a value from a property list, comparing with `equal'.
2020 PLIST is a property list, which is a list of the form
2021 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2022 corresponding to the given PROP, or nil if PROP is not
2023 one of the properties on the list. */)
2031 CONSP (tail
) && CONSP (XCDR (tail
));
2032 tail
= XCDR (XCDR (tail
)))
2034 if (! NILP (Fequal (prop
, XCAR (tail
))))
2035 return XCAR (XCDR (tail
));
2040 CHECK_LIST_END (tail
, prop
);
2045 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2046 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2047 PLIST is a property list, which is a list of the form
2048 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2049 If PROP is already a property on the list, its value is set to VAL,
2050 otherwise the new PROP VAL pair is added. The new plist is returned;
2051 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2052 The PLIST is modified by side effects. */)
2055 register Lisp_Object prop
;
2058 register Lisp_Object tail
, prev
;
2059 Lisp_Object newcell
;
2061 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2062 tail
= XCDR (XCDR (tail
)))
2064 if (! NILP (Fequal (prop
, XCAR (tail
))))
2066 Fsetcar (XCDR (tail
), val
);
2073 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2077 Fsetcdr (XCDR (prev
), newcell
);
2081 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2082 doc
: /* Return t if the two args are the same Lisp object.
2083 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2085 Lisp_Object obj1
, obj2
;
2088 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2090 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2093 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2094 doc
: /* Return t if two Lisp objects have similar structure and contents.
2095 They must have the same data type.
2096 Conses are compared by comparing the cars and the cdrs.
2097 Vectors and strings are compared element by element.
2098 Numbers are compared by value, but integers cannot equal floats.
2099 (Use `=' if you want integers and floats to be able to be equal.)
2100 Symbols must match exactly. */)
2102 register Lisp_Object o1
, o2
;
2104 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2107 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2108 doc
: /* Return t if two Lisp objects have similar structure and contents.
2109 This is like `equal' except that it compares the text properties
2110 of strings. (`equal' ignores text properties.) */)
2112 register Lisp_Object o1
, o2
;
2114 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2117 /* DEPTH is current depth of recursion. Signal an error if it
2119 PROPS, if non-nil, means compare string text properties too. */
2122 internal_equal (o1
, o2
, depth
, props
)
2123 register Lisp_Object o1
, o2
;
2127 error ("Stack overflow in equal");
2133 if (XTYPE (o1
) != XTYPE (o2
))
2142 d1
= extract_float (o1
);
2143 d2
= extract_float (o2
);
2144 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2145 though they are not =. */
2146 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2150 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2157 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2161 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2163 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2166 o1
= XOVERLAY (o1
)->plist
;
2167 o2
= XOVERLAY (o2
)->plist
;
2172 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2173 && (XMARKER (o1
)->buffer
== 0
2174 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2178 case Lisp_Vectorlike
:
2181 EMACS_INT size
= ASIZE (o1
);
2182 /* Pseudovectors have the type encoded in the size field, so this test
2183 actually checks that the objects have the same type as well as the
2185 if (ASIZE (o2
) != size
)
2187 /* Boolvectors are compared much like strings. */
2188 if (BOOL_VECTOR_P (o1
))
2191 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2192 / BOOL_VECTOR_BITS_PER_CHAR
);
2194 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2196 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2201 if (WINDOW_CONFIGURATIONP (o1
))
2202 return compare_window_configurations (o1
, o2
, 0);
2204 /* Aside from them, only true vectors, char-tables, and compiled
2205 functions are sensible to compare, so eliminate the others now. */
2206 if (size
& PSEUDOVECTOR_FLAG
)
2208 if (!(size
& (PVEC_COMPILED
2209 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
)))
2211 size
&= PSEUDOVECTOR_SIZE_MASK
;
2213 for (i
= 0; i
< size
; i
++)
2218 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2226 if (SCHARS (o1
) != SCHARS (o2
))
2228 if (SBYTES (o1
) != SBYTES (o2
))
2230 if (bcmp (SDATA (o1
), SDATA (o2
),
2233 if (props
&& !compare_string_intervals (o1
, o2
))
2239 case Lisp_Type_Limit
:
2246 extern Lisp_Object
Fmake_char_internal ();
2248 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2249 doc
: /* Store each element of ARRAY with ITEM.
2250 ARRAY is a vector, string, char-table, or bool-vector. */)
2252 Lisp_Object array
, item
;
2254 register int size
, index
, charval
;
2255 if (VECTORP (array
))
2257 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2258 size
= ASIZE (array
);
2259 for (index
= 0; index
< size
; index
++)
2262 else if (CHAR_TABLE_P (array
))
2266 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2267 XCHAR_TABLE (array
)->contents
[i
] = item
;
2268 XCHAR_TABLE (array
)->defalt
= item
;
2270 else if (STRINGP (array
))
2272 register unsigned char *p
= SDATA (array
);
2273 CHECK_NUMBER (item
);
2274 charval
= XINT (item
);
2275 size
= SCHARS (array
);
2276 if (STRING_MULTIBYTE (array
))
2278 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2279 int len
= CHAR_STRING (charval
, str
);
2280 int size_byte
= SBYTES (array
);
2281 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2284 if (size
!= size_byte
)
2287 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2288 if (len
!= this_len
)
2289 error ("Attempt to change byte length of a string");
2292 for (i
= 0; i
< size_byte
; i
++)
2293 *p
++ = str
[i
% len
];
2296 for (index
= 0; index
< size
; index
++)
2299 else if (BOOL_VECTOR_P (array
))
2301 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2303 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2304 / BOOL_VECTOR_BITS_PER_CHAR
);
2306 charval
= (! NILP (item
) ? -1 : 0);
2307 for (index
= 0; index
< size_in_chars
- 1; index
++)
2309 if (index
< size_in_chars
)
2311 /* Mask out bits beyond the vector size. */
2312 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2313 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2318 wrong_type_argument (Qarrayp
, array
);
2322 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2324 doc
: /* Clear the contents of STRING.
2325 This makes STRING unibyte and may change its length. */)
2330 CHECK_STRING (string
);
2331 len
= SBYTES (string
);
2332 bzero (SDATA (string
), len
);
2333 STRING_SET_CHARS (string
, len
);
2334 STRING_SET_UNIBYTE (string
);
2344 Lisp_Object args
[2];
2347 return Fnconc (2, args
);
2349 return Fnconc (2, &s1
);
2350 #endif /* NO_ARG_ARRAY */
2353 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2354 doc
: /* Concatenate any number of lists by altering them.
2355 Only the last argument is not altered, and need not be a list.
2356 usage: (nconc &rest LISTS) */)
2361 register int argnum
;
2362 register Lisp_Object tail
, tem
, val
;
2366 for (argnum
= 0; argnum
< nargs
; argnum
++)
2369 if (NILP (tem
)) continue;
2374 if (argnum
+ 1 == nargs
) break;
2376 CHECK_LIST_CONS (tem
, tem
);
2385 tem
= args
[argnum
+ 1];
2386 Fsetcdr (tail
, tem
);
2388 args
[argnum
+ 1] = tail
;
2394 /* This is the guts of all mapping functions.
2395 Apply FN to each element of SEQ, one by one,
2396 storing the results into elements of VALS, a C vector of Lisp_Objects.
2397 LENI is the length of VALS, which should also be the length of SEQ. */
2400 mapcar1 (leni
, vals
, fn
, seq
)
2403 Lisp_Object fn
, seq
;
2405 register Lisp_Object tail
;
2408 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2412 /* Don't let vals contain any garbage when GC happens. */
2413 for (i
= 0; i
< leni
; i
++)
2416 GCPRO3 (dummy
, fn
, seq
);
2418 gcpro1
.nvars
= leni
;
2422 /* We need not explicitly protect `tail' because it is used only on lists, and
2423 1) lists are not relocated and 2) the list is marked via `seq' so will not
2428 for (i
= 0; i
< leni
; i
++)
2430 dummy
= call1 (fn
, AREF (seq
, i
));
2435 else if (BOOL_VECTOR_P (seq
))
2437 for (i
= 0; i
< leni
; i
++)
2440 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2441 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2442 dummy
= call1 (fn
, dummy
);
2447 else if (STRINGP (seq
))
2451 for (i
= 0, i_byte
= 0; i
< leni
;)
2456 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2457 XSETFASTINT (dummy
, c
);
2458 dummy
= call1 (fn
, dummy
);
2460 vals
[i_before
] = dummy
;
2463 else /* Must be a list, since Flength did not get an error */
2466 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2468 dummy
= call1 (fn
, XCAR (tail
));
2478 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2479 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2480 In between each pair of results, stick in SEPARATOR. Thus, " " as
2481 SEPARATOR results in spaces between the values returned by FUNCTION.
2482 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2483 (function
, sequence
, separator
)
2484 Lisp_Object function
, sequence
, separator
;
2489 register Lisp_Object
*args
;
2491 struct gcpro gcpro1
;
2495 len
= Flength (sequence
);
2496 if (CHAR_TABLE_P (sequence
))
2497 wrong_type_argument (Qlistp
, sequence
);
2499 nargs
= leni
+ leni
- 1;
2500 if (nargs
< 0) return empty_unibyte_string
;
2502 SAFE_ALLOCA_LISP (args
, nargs
);
2505 mapcar1 (leni
, args
, function
, sequence
);
2508 for (i
= leni
- 1; i
> 0; i
--)
2509 args
[i
+ i
] = args
[i
];
2511 for (i
= 1; i
< nargs
; i
+= 2)
2512 args
[i
] = separator
;
2514 ret
= Fconcat (nargs
, args
);
2520 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2521 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2522 The result is a list just as long as SEQUENCE.
2523 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2524 (function
, sequence
)
2525 Lisp_Object function
, sequence
;
2527 register Lisp_Object len
;
2529 register Lisp_Object
*args
;
2533 len
= Flength (sequence
);
2534 if (CHAR_TABLE_P (sequence
))
2535 wrong_type_argument (Qlistp
, sequence
);
2536 leni
= XFASTINT (len
);
2538 SAFE_ALLOCA_LISP (args
, leni
);
2540 mapcar1 (leni
, args
, function
, sequence
);
2542 ret
= Flist (leni
, args
);
2548 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2549 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2550 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2551 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2552 (function
, sequence
)
2553 Lisp_Object function
, sequence
;
2557 leni
= XFASTINT (Flength (sequence
));
2558 if (CHAR_TABLE_P (sequence
))
2559 wrong_type_argument (Qlistp
, sequence
);
2560 mapcar1 (leni
, 0, function
, sequence
);
2565 /* Anything that calls this function must protect from GC! */
2567 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2568 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2569 Takes one argument, which is the string to display to ask the question.
2570 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2571 No confirmation of the answer is requested; a single character is enough.
2572 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2573 the bindings in `query-replace-map'; see the documentation of that variable
2574 for more information. In this case, the useful bindings are `act', `skip',
2575 `recenter', and `quit'.\)
2577 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2578 is nil and `use-dialog-box' is non-nil. */)
2582 register Lisp_Object obj
, key
, def
, map
;
2583 register int answer
;
2584 Lisp_Object xprompt
;
2585 Lisp_Object args
[2];
2586 struct gcpro gcpro1
, gcpro2
;
2587 int count
= SPECPDL_INDEX ();
2589 specbind (Qcursor_in_echo_area
, Qt
);
2591 map
= Fsymbol_value (intern ("query-replace-map"));
2593 CHECK_STRING (prompt
);
2595 GCPRO2 (prompt
, xprompt
);
2597 #ifdef HAVE_X_WINDOWS
2598 if (display_hourglass_p
)
2599 cancel_hourglass ();
2606 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2607 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2611 Lisp_Object pane
, menu
;
2612 redisplay_preserve_echo_area (3);
2613 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2614 Fcons (Fcons (build_string ("No"), Qnil
),
2616 menu
= Fcons (prompt
, pane
);
2617 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2618 answer
= !NILP (obj
);
2621 #endif /* HAVE_MENUS */
2622 cursor_in_echo_area
= 1;
2623 choose_minibuf_frame ();
2626 Lisp_Object pargs
[3];
2628 /* Colorize prompt according to `minibuffer-prompt' face. */
2629 pargs
[0] = build_string ("%s(y or n) ");
2630 pargs
[1] = intern ("face");
2631 pargs
[2] = intern ("minibuffer-prompt");
2632 args
[0] = Fpropertize (3, pargs
);
2637 if (minibuffer_auto_raise
)
2639 Lisp_Object mini_frame
;
2641 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2643 Fraise_frame (mini_frame
);
2646 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2647 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2648 cursor_in_echo_area
= 0;
2649 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2652 key
= Fmake_vector (make_number (1), obj
);
2653 def
= Flookup_key (map
, key
, Qt
);
2655 if (EQ (def
, intern ("skip")))
2660 else if (EQ (def
, intern ("act")))
2665 else if (EQ (def
, intern ("recenter")))
2671 else if (EQ (def
, intern ("quit")))
2673 /* We want to exit this command for exit-prefix,
2674 and this is the only way to do it. */
2675 else if (EQ (def
, intern ("exit-prefix")))
2680 /* If we don't clear this, then the next call to read_char will
2681 return quit_char again, and we'll enter an infinite loop. */
2686 if (EQ (xprompt
, prompt
))
2688 args
[0] = build_string ("Please answer y or n. ");
2690 xprompt
= Fconcat (2, args
);
2695 if (! noninteractive
)
2697 cursor_in_echo_area
= -1;
2698 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2702 unbind_to (count
, Qnil
);
2703 return answer
? Qt
: Qnil
;
2706 /* This is how C code calls `yes-or-no-p' and allows the user
2709 Anything that calls this function must protect from GC! */
2712 do_yes_or_no_p (prompt
)
2715 return call1 (intern ("yes-or-no-p"), prompt
);
2718 /* Anything that calls this function must protect from GC! */
2720 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2721 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2722 Takes one argument, which is the string to display to ask the question.
2723 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2724 The user must confirm the answer with RET,
2725 and can edit it until it has been confirmed.
2727 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2728 is nil, and `use-dialog-box' is non-nil. */)
2732 register Lisp_Object ans
;
2733 Lisp_Object args
[2];
2734 struct gcpro gcpro1
;
2736 CHECK_STRING (prompt
);
2739 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2740 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2744 Lisp_Object pane
, menu
, obj
;
2745 redisplay_preserve_echo_area (4);
2746 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2747 Fcons (Fcons (build_string ("No"), Qnil
),
2750 menu
= Fcons (prompt
, pane
);
2751 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2755 #endif /* HAVE_MENUS */
2758 args
[1] = build_string ("(yes or no) ");
2759 prompt
= Fconcat (2, args
);
2765 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2766 Qyes_or_no_p_history
, Qnil
,
2768 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2773 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2781 message ("Please answer yes or no.");
2782 Fsleep_for (make_number (2), Qnil
);
2786 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2787 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2789 Each of the three load averages is multiplied by 100, then converted
2792 When USE-FLOATS is non-nil, floats will be used instead of integers.
2793 These floats are not multiplied by 100.
2795 If the 5-minute or 15-minute load averages are not available, return a
2796 shortened list, containing only those averages which are available.
2798 An error is thrown if the load average can't be obtained. In some
2799 cases making it work would require Emacs being installed setuid or
2800 setgid so that it can read kernel information, and that usually isn't
2803 Lisp_Object use_floats
;
2806 int loads
= getloadavg (load_ave
, 3);
2807 Lisp_Object ret
= Qnil
;
2810 error ("load-average not implemented for this operating system");
2814 Lisp_Object load
= (NILP (use_floats
) ?
2815 make_number ((int) (100.0 * load_ave
[loads
]))
2816 : make_float (load_ave
[loads
]));
2817 ret
= Fcons (load
, ret
);
2823 Lisp_Object Vfeatures
, Qsubfeatures
;
2824 extern Lisp_Object Vafter_load_alist
;
2826 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2827 doc
: /* Returns t if FEATURE is present in this Emacs.
2829 Use this to conditionalize execution of lisp code based on the
2830 presence or absence of Emacs or environment extensions.
2831 Use `provide' to declare that a feature is available. This function
2832 looks at the value of the variable `features'. The optional argument
2833 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2834 (feature
, subfeature
)
2835 Lisp_Object feature
, subfeature
;
2837 register Lisp_Object tem
;
2838 CHECK_SYMBOL (feature
);
2839 tem
= Fmemq (feature
, Vfeatures
);
2840 if (!NILP (tem
) && !NILP (subfeature
))
2841 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2842 return (NILP (tem
)) ? Qnil
: Qt
;
2845 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2846 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2847 The optional argument SUBFEATURES should be a list of symbols listing
2848 particular subfeatures supported in this version of FEATURE. */)
2849 (feature
, subfeatures
)
2850 Lisp_Object feature
, subfeatures
;
2852 register Lisp_Object tem
;
2853 CHECK_SYMBOL (feature
);
2854 CHECK_LIST (subfeatures
);
2855 if (!NILP (Vautoload_queue
))
2856 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2858 tem
= Fmemq (feature
, Vfeatures
);
2860 Vfeatures
= Fcons (feature
, Vfeatures
);
2861 if (!NILP (subfeatures
))
2862 Fput (feature
, Qsubfeatures
, subfeatures
);
2863 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2865 /* Run any load-hooks for this file. */
2866 tem
= Fassq (feature
, Vafter_load_alist
);
2868 Fprogn (XCDR (tem
));
2873 /* `require' and its subroutines. */
2875 /* List of features currently being require'd, innermost first. */
2877 Lisp_Object require_nesting_list
;
2880 require_unwind (old_value
)
2881 Lisp_Object old_value
;
2883 return require_nesting_list
= old_value
;
2886 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2887 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2888 If FEATURE is not a member of the list `features', then the feature
2889 is not loaded; so load the file FILENAME.
2890 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2891 and `load' will try to load this name appended with the suffix `.elc' or
2892 `.el', in that order. The name without appended suffix will not be used.
2893 If the optional third argument NOERROR is non-nil,
2894 then return nil if the file is not found instead of signaling an error.
2895 Normally the return value is FEATURE.
2896 The normal messages at start and end of loading FILENAME are suppressed. */)
2897 (feature
, filename
, noerror
)
2898 Lisp_Object feature
, filename
, noerror
;
2900 register Lisp_Object tem
;
2901 struct gcpro gcpro1
, gcpro2
;
2902 int from_file
= load_in_progress
;
2904 CHECK_SYMBOL (feature
);
2906 /* Record the presence of `require' in this file
2907 even if the feature specified is already loaded.
2908 But not more than once in any file,
2909 and not when we aren't loading or reading from a file. */
2911 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2912 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2917 tem
= Fcons (Qrequire
, feature
);
2918 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2919 LOADHIST_ATTACH (tem
);
2921 tem
= Fmemq (feature
, Vfeatures
);
2925 int count
= SPECPDL_INDEX ();
2928 /* This is to make sure that loadup.el gives a clear picture
2929 of what files are preloaded and when. */
2930 if (! NILP (Vpurify_flag
))
2931 error ("(require %s) while preparing to dump",
2932 SDATA (SYMBOL_NAME (feature
)));
2934 /* A certain amount of recursive `require' is legitimate,
2935 but if we require the same feature recursively 3 times,
2937 tem
= require_nesting_list
;
2938 while (! NILP (tem
))
2940 if (! NILP (Fequal (feature
, XCAR (tem
))))
2945 error ("Recursive `require' for feature `%s'",
2946 SDATA (SYMBOL_NAME (feature
)));
2948 /* Update the list for any nested `require's that occur. */
2949 record_unwind_protect (require_unwind
, require_nesting_list
);
2950 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2952 /* Value saved here is to be restored into Vautoload_queue */
2953 record_unwind_protect (un_autoload
, Vautoload_queue
);
2954 Vautoload_queue
= Qt
;
2956 /* Load the file. */
2957 GCPRO2 (feature
, filename
);
2958 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2959 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2962 /* If load failed entirely, return nil. */
2964 return unbind_to (count
, Qnil
);
2966 tem
= Fmemq (feature
, Vfeatures
);
2968 error ("Required feature `%s' was not provided",
2969 SDATA (SYMBOL_NAME (feature
)));
2971 /* Once loading finishes, don't undo it. */
2972 Vautoload_queue
= Qt
;
2973 feature
= unbind_to (count
, feature
);
2979 /* Primitives for work of the "widget" library.
2980 In an ideal world, this section would not have been necessary.
2981 However, lisp function calls being as slow as they are, it turns
2982 out that some functions in the widget library (wid-edit.el) are the
2983 bottleneck of Widget operation. Here is their translation to C,
2984 for the sole reason of efficiency. */
2986 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2987 doc
: /* Return non-nil if PLIST has the property PROP.
2988 PLIST is a property list, which is a list of the form
2989 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2990 Unlike `plist-get', this allows you to distinguish between a missing
2991 property and a property with the value nil.
2992 The value is actually the tail of PLIST whose car is PROP. */)
2994 Lisp_Object plist
, prop
;
2996 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2999 plist
= XCDR (plist
);
3000 plist
= CDR (plist
);
3005 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3006 doc
: /* In WIDGET, set PROPERTY to VALUE.
3007 The value can later be retrieved with `widget-get'. */)
3008 (widget
, property
, value
)
3009 Lisp_Object widget
, property
, value
;
3011 CHECK_CONS (widget
);
3012 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3016 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3017 doc
: /* In WIDGET, get the value of PROPERTY.
3018 The value could either be specified when the widget was created, or
3019 later with `widget-put'. */)
3021 Lisp_Object widget
, property
;
3029 CHECK_CONS (widget
);
3030 tmp
= Fplist_member (XCDR (widget
), property
);
3036 tmp
= XCAR (widget
);
3039 widget
= Fget (tmp
, Qwidget_type
);
3043 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3044 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3045 ARGS are passed as extra arguments to the function.
3046 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3051 /* This function can GC. */
3052 Lisp_Object newargs
[3];
3053 struct gcpro gcpro1
, gcpro2
;
3056 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3057 newargs
[1] = args
[0];
3058 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3059 GCPRO2 (newargs
[0], newargs
[2]);
3060 result
= Fapply (3, newargs
);
3065 #ifdef HAVE_LANGINFO_CODESET
3066 #include <langinfo.h>
3069 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3070 doc
: /* Access locale data ITEM for the current C locale, if available.
3071 ITEM should be one of the following:
3073 `codeset', returning the character set as a string (locale item CODESET);
3075 `days', returning a 7-element vector of day names (locale items DAY_n);
3077 `months', returning a 12-element vector of month names (locale items MON_n);
3079 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3080 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3082 If the system can't provide such information through a call to
3083 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3085 See also Info node `(libc)Locales'.
3087 The data read from the system are decoded using `locale-coding-system'. */)
3092 #ifdef HAVE_LANGINFO_CODESET
3094 if (EQ (item
, Qcodeset
))
3096 str
= nl_langinfo (CODESET
);
3097 return build_string (str
);
3100 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3102 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3103 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3105 synchronize_system_time_locale ();
3106 for (i
= 0; i
< 7; i
++)
3108 str
= nl_langinfo (days
[i
]);
3109 val
= make_unibyte_string (str
, strlen (str
));
3110 /* Fixme: Is this coding system necessarily right, even if
3111 it is consistent with CODESET? If not, what to do? */
3112 Faset (v
, make_number (i
),
3113 code_convert_string_norecord (val
, Vlocale_coding_system
,
3120 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3122 struct Lisp_Vector
*p
= allocate_vector (12);
3123 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3124 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3126 synchronize_system_time_locale ();
3127 for (i
= 0; i
< 12; i
++)
3129 str
= nl_langinfo (months
[i
]);
3130 val
= make_unibyte_string (str
, strlen (str
));
3132 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3134 XSETVECTOR (val
, p
);
3138 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3139 but is in the locale files. This could be used by ps-print. */
3141 else if (EQ (item
, Qpaper
))
3143 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3144 make_number (nl_langinfo (PAPER_HEIGHT
)));
3146 #endif /* PAPER_WIDTH */
3147 #endif /* HAVE_LANGINFO_CODESET*/
3151 /* base64 encode/decode functions (RFC 2045).
3152 Based on code from GNU recode. */
3154 #define MIME_LINE_LENGTH 76
3156 #define IS_ASCII(Character) \
3158 #define IS_BASE64(Character) \
3159 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3160 #define IS_BASE64_IGNORABLE(Character) \
3161 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3162 || (Character) == '\f' || (Character) == '\r')
3164 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3165 character or return retval if there are no characters left to
3167 #define READ_QUADRUPLET_BYTE(retval) \
3172 if (nchars_return) \
3173 *nchars_return = nchars; \
3178 while (IS_BASE64_IGNORABLE (c))
3180 /* Table of characters coding the 64 values. */
3181 static char base64_value_to_char
[64] =
3183 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3184 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3185 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3186 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3187 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3188 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3189 '8', '9', '+', '/' /* 60-63 */
3192 /* Table of base64 values for first 128 characters. */
3193 static short base64_char_to_value
[128] =
3195 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3196 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3197 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3198 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3199 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3200 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3201 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3202 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3203 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3204 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3205 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3206 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3207 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3210 /* The following diagram shows the logical steps by which three octets
3211 get transformed into four base64 characters.
3213 .--------. .--------. .--------.
3214 |aaaaaabb| |bbbbcccc| |ccdddddd|
3215 `--------' `--------' `--------'
3217 .--------+--------+--------+--------.
3218 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3219 `--------+--------+--------+--------'
3221 .--------+--------+--------+--------.
3222 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3223 `--------+--------+--------+--------'
3225 The octets are divided into 6 bit chunks, which are then encoded into
3226 base64 characters. */
3229 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3230 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3232 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3234 doc
: /* Base64-encode the region between BEG and END.
3235 Return the length of the encoded text.
3236 Optional third argument NO-LINE-BREAK means do not break long lines
3237 into shorter lines. */)
3238 (beg
, end
, no_line_break
)
3239 Lisp_Object beg
, end
, no_line_break
;
3242 int allength
, length
;
3243 int ibeg
, iend
, encoded_length
;
3247 validate_region (&beg
, &end
);
3249 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3250 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3251 move_gap_both (XFASTINT (beg
), ibeg
);
3253 /* We need to allocate enough room for encoding the text.
3254 We need 33 1/3% more space, plus a newline every 76
3255 characters, and then we round up. */
3256 length
= iend
- ibeg
;
3257 allength
= length
+ length
/3 + 1;
3258 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3260 SAFE_ALLOCA (encoded
, char *, allength
);
3261 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3262 NILP (no_line_break
),
3263 !NILP (current_buffer
->enable_multibyte_characters
));
3264 if (encoded_length
> allength
)
3267 if (encoded_length
< 0)
3269 /* The encoding wasn't possible. */
3271 error ("Multibyte character in data for base64 encoding");
3274 /* Now we have encoded the region, so we insert the new contents
3275 and delete the old. (Insert first in order to preserve markers.) */
3276 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3277 insert (encoded
, encoded_length
);
3279 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3281 /* If point was outside of the region, restore it exactly; else just
3282 move to the beginning of the region. */
3283 if (old_pos
>= XFASTINT (end
))
3284 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3285 else if (old_pos
> XFASTINT (beg
))
3286 old_pos
= XFASTINT (beg
);
3289 /* We return the length of the encoded text. */
3290 return make_number (encoded_length
);
3293 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3295 doc
: /* Base64-encode STRING and return the result.
3296 Optional second argument NO-LINE-BREAK means do not break long lines
3297 into shorter lines. */)
3298 (string
, no_line_break
)
3299 Lisp_Object string
, no_line_break
;
3301 int allength
, length
, encoded_length
;
3303 Lisp_Object encoded_string
;
3306 CHECK_STRING (string
);
3308 /* We need to allocate enough room for encoding the text.
3309 We need 33 1/3% more space, plus a newline every 76
3310 characters, and then we round up. */
3311 length
= SBYTES (string
);
3312 allength
= length
+ length
/3 + 1;
3313 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3315 /* We need to allocate enough room for decoding the text. */
3316 SAFE_ALLOCA (encoded
, char *, allength
);
3318 encoded_length
= base64_encode_1 (SDATA (string
),
3319 encoded
, length
, NILP (no_line_break
),
3320 STRING_MULTIBYTE (string
));
3321 if (encoded_length
> allength
)
3324 if (encoded_length
< 0)
3326 /* The encoding wasn't possible. */
3328 error ("Multibyte character in data for base64 encoding");
3331 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3334 return encoded_string
;
3338 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3345 int counter
= 0, i
= 0;
3355 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3356 if (CHAR_BYTE8_P (c
))
3357 c
= CHAR_TO_BYTE8 (c
);
3365 /* Wrap line every 76 characters. */
3369 if (counter
< MIME_LINE_LENGTH
/ 4)
3378 /* Process first byte of a triplet. */
3380 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3381 value
= (0x03 & c
) << 4;
3383 /* Process second byte of a triplet. */
3387 *e
++ = base64_value_to_char
[value
];
3395 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3396 if (CHAR_BYTE8_P (c
))
3397 c
= CHAR_TO_BYTE8 (c
);
3405 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3406 value
= (0x0f & c
) << 2;
3408 /* Process third byte of a triplet. */
3412 *e
++ = base64_value_to_char
[value
];
3419 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3420 if (CHAR_BYTE8_P (c
))
3421 c
= CHAR_TO_BYTE8 (c
);
3429 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3430 *e
++ = base64_value_to_char
[0x3f & c
];
3437 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3439 doc
: /* Base64-decode the region between BEG and END.
3440 Return the length of the decoded text.
3441 If the region can't be decoded, signal an error and don't modify the buffer. */)
3443 Lisp_Object beg
, end
;
3445 int ibeg
, iend
, length
, allength
;
3450 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3453 validate_region (&beg
, &end
);
3455 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3456 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3458 length
= iend
- ibeg
;
3460 /* We need to allocate enough room for decoding the text. If we are
3461 working on a multibyte buffer, each decoded code may occupy at
3463 allength
= multibyte
? length
* 2 : length
;
3464 SAFE_ALLOCA (decoded
, char *, allength
);
3466 move_gap_both (XFASTINT (beg
), ibeg
);
3467 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3468 multibyte
, &inserted_chars
);
3469 if (decoded_length
> allength
)
3472 if (decoded_length
< 0)
3474 /* The decoding wasn't possible. */
3476 error ("Invalid base64 data");
3479 /* Now we have decoded the region, so we insert the new contents
3480 and delete the old. (Insert first in order to preserve markers.) */
3481 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3482 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3485 /* Delete the original text. */
3486 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3487 iend
+ decoded_length
, 1);
3489 /* If point was outside of the region, restore it exactly; else just
3490 move to the beginning of the region. */
3491 if (old_pos
>= XFASTINT (end
))
3492 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3493 else if (old_pos
> XFASTINT (beg
))
3494 old_pos
= XFASTINT (beg
);
3495 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3497 return make_number (inserted_chars
);
3500 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3502 doc
: /* Base64-decode STRING and return the result. */)
3507 int length
, decoded_length
;
3508 Lisp_Object decoded_string
;
3511 CHECK_STRING (string
);
3513 length
= SBYTES (string
);
3514 /* We need to allocate enough room for decoding the text. */
3515 SAFE_ALLOCA (decoded
, char *, length
);
3517 /* The decoded result should be unibyte. */
3518 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3520 if (decoded_length
> length
)
3522 else if (decoded_length
>= 0)
3523 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3525 decoded_string
= Qnil
;
3528 if (!STRINGP (decoded_string
))
3529 error ("Invalid base64 data");
3531 return decoded_string
;
3534 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3535 MULTIBYTE is nonzero, the decoded result should be in multibyte
3536 form. If NCHARS_RETRUN is not NULL, store the number of produced
3537 characters in *NCHARS_RETURN. */
3540 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3550 unsigned long value
;
3555 /* Process first byte of a quadruplet. */
3557 READ_QUADRUPLET_BYTE (e
-to
);
3561 value
= base64_char_to_value
[c
] << 18;
3563 /* Process second byte of a quadruplet. */
3565 READ_QUADRUPLET_BYTE (-1);
3569 value
|= base64_char_to_value
[c
] << 12;
3571 c
= (unsigned char) (value
>> 16);
3572 if (multibyte
&& c
>= 128)
3573 e
+= BYTE8_STRING (c
, e
);
3578 /* Process third byte of a quadruplet. */
3580 READ_QUADRUPLET_BYTE (-1);
3584 READ_QUADRUPLET_BYTE (-1);
3593 value
|= base64_char_to_value
[c
] << 6;
3595 c
= (unsigned char) (0xff & value
>> 8);
3596 if (multibyte
&& c
>= 128)
3597 e
+= BYTE8_STRING (c
, e
);
3602 /* Process fourth byte of a quadruplet. */
3604 READ_QUADRUPLET_BYTE (-1);
3611 value
|= base64_char_to_value
[c
];
3613 c
= (unsigned char) (0xff & value
);
3614 if (multibyte
&& c
>= 128)
3615 e
+= BYTE8_STRING (c
, e
);
3624 /***********************************************************************
3626 ***** Hash Tables *****
3628 ***********************************************************************/
3630 /* Implemented by gerd@gnu.org. This hash table implementation was
3631 inspired by CMUCL hash tables. */
3635 1. For small tables, association lists are probably faster than
3636 hash tables because they have lower overhead.
3638 For uses of hash tables where the O(1) behavior of table
3639 operations is not a requirement, it might therefore be a good idea
3640 not to hash. Instead, we could just do a linear search in the
3641 key_and_value vector of the hash table. This could be done
3642 if a `:linear-search t' argument is given to make-hash-table. */
3645 /* The list of all weak hash tables. Don't staticpro this one. */
3647 struct Lisp_Hash_Table
*weak_hash_tables
;
3649 /* Various symbols. */
3651 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3652 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3653 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3655 /* Function prototypes. */
3657 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3658 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3659 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3660 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3661 Lisp_Object
, unsigned));
3662 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3663 Lisp_Object
, unsigned));
3664 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3665 unsigned, Lisp_Object
, unsigned));
3666 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3667 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3668 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3669 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3671 static unsigned sxhash_string
P_ ((unsigned char *, int));
3672 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3673 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3674 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3675 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3679 /***********************************************************************
3681 ***********************************************************************/
3683 /* If OBJ is a Lisp hash table, return a pointer to its struct
3684 Lisp_Hash_Table. Otherwise, signal an error. */
3686 static struct Lisp_Hash_Table
*
3687 check_hash_table (obj
)
3690 CHECK_HASH_TABLE (obj
);
3691 return XHASH_TABLE (obj
);
3695 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3699 next_almost_prime (n
)
3712 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3713 which USED[I] is non-zero. If found at index I in ARGS, set
3714 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3715 -1. This function is used to extract a keyword/argument pair from
3716 a DEFUN parameter list. */
3719 get_key_arg (key
, nargs
, args
, used
)
3727 for (i
= 0; i
< nargs
- 1; ++i
)
3728 if (!used
[i
] && EQ (args
[i
], key
))
3743 /* Return a Lisp vector which has the same contents as VEC but has
3744 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3745 vector that are not copied from VEC are set to INIT. */
3748 larger_vector (vec
, new_size
, init
)
3753 struct Lisp_Vector
*v
;
3756 xassert (VECTORP (vec
));
3757 old_size
= ASIZE (vec
);
3758 xassert (new_size
>= old_size
);
3760 v
= allocate_vector (new_size
);
3761 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3762 old_size
* sizeof *v
->contents
);
3763 for (i
= old_size
; i
< new_size
; ++i
)
3764 v
->contents
[i
] = init
;
3765 XSETVECTOR (vec
, v
);
3770 /***********************************************************************
3772 ***********************************************************************/
3774 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3775 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3776 KEY2 are the same. */
3779 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3780 struct Lisp_Hash_Table
*h
;
3781 Lisp_Object key1
, key2
;
3782 unsigned hash1
, hash2
;
3784 return (FLOATP (key1
)
3786 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3790 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3791 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3792 KEY2 are the same. */
3795 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3796 struct Lisp_Hash_Table
*h
;
3797 Lisp_Object key1
, key2
;
3798 unsigned hash1
, hash2
;
3800 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3804 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3805 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3806 if KEY1 and KEY2 are the same. */
3809 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3810 struct Lisp_Hash_Table
*h
;
3811 Lisp_Object key1
, key2
;
3812 unsigned hash1
, hash2
;
3816 Lisp_Object args
[3];
3818 args
[0] = h
->user_cmp_function
;
3821 return !NILP (Ffuncall (3, args
));
3828 /* Value is a hash code for KEY for use in hash table H which uses
3829 `eq' to compare keys. The hash code returned is guaranteed to fit
3830 in a Lisp integer. */
3834 struct Lisp_Hash_Table
*h
;
3837 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3838 xassert ((hash
& ~INTMASK
) == 0);
3843 /* Value is a hash code for KEY for use in hash table H which uses
3844 `eql' to compare keys. The hash code returned is guaranteed to fit
3845 in a Lisp integer. */
3849 struct Lisp_Hash_Table
*h
;
3854 hash
= sxhash (key
, 0);
3856 hash
= XUINT (key
) ^ XTYPE (key
);
3857 xassert ((hash
& ~INTMASK
) == 0);
3862 /* Value is a hash code for KEY for use in hash table H which uses
3863 `equal' to compare keys. The hash code returned is guaranteed to fit
3864 in a Lisp integer. */
3867 hashfn_equal (h
, key
)
3868 struct Lisp_Hash_Table
*h
;
3871 unsigned hash
= sxhash (key
, 0);
3872 xassert ((hash
& ~INTMASK
) == 0);
3877 /* Value is a hash code for KEY for use in hash table H which uses as
3878 user-defined function to compare keys. The hash code returned is
3879 guaranteed to fit in a Lisp integer. */
3882 hashfn_user_defined (h
, key
)
3883 struct Lisp_Hash_Table
*h
;
3886 Lisp_Object args
[2], hash
;
3888 args
[0] = h
->user_hash_function
;
3890 hash
= Ffuncall (2, args
);
3891 if (!INTEGERP (hash
))
3892 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3893 return XUINT (hash
);
3897 /* Create and initialize a new hash table.
3899 TEST specifies the test the hash table will use to compare keys.
3900 It must be either one of the predefined tests `eq', `eql' or
3901 `equal' or a symbol denoting a user-defined test named TEST with
3902 test and hash functions USER_TEST and USER_HASH.
3904 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3906 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3907 new size when it becomes full is computed by adding REHASH_SIZE to
3908 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3909 table's new size is computed by multiplying its old size with
3912 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3913 be resized when the ratio of (number of entries in the table) /
3914 (table size) is >= REHASH_THRESHOLD.
3916 WEAK specifies the weakness of the table. If non-nil, it must be
3917 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3920 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3921 user_test
, user_hash
)
3922 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3923 Lisp_Object user_test
, user_hash
;
3925 struct Lisp_Hash_Table
*h
;
3927 int index_size
, i
, sz
;
3929 /* Preconditions. */
3930 xassert (SYMBOLP (test
));
3931 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3932 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3933 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3934 xassert (FLOATP (rehash_threshold
)
3935 && XFLOATINT (rehash_threshold
) > 0
3936 && XFLOATINT (rehash_threshold
) <= 1.0);
3938 if (XFASTINT (size
) == 0)
3939 size
= make_number (1);
3941 /* Allocate a table and initialize it. */
3942 h
= allocate_hash_table ();
3944 /* Initialize hash table slots. */
3945 sz
= XFASTINT (size
);
3948 if (EQ (test
, Qeql
))
3950 h
->cmpfn
= cmpfn_eql
;
3951 h
->hashfn
= hashfn_eql
;
3953 else if (EQ (test
, Qeq
))
3956 h
->hashfn
= hashfn_eq
;
3958 else if (EQ (test
, Qequal
))
3960 h
->cmpfn
= cmpfn_equal
;
3961 h
->hashfn
= hashfn_equal
;
3965 h
->user_cmp_function
= user_test
;
3966 h
->user_hash_function
= user_hash
;
3967 h
->cmpfn
= cmpfn_user_defined
;
3968 h
->hashfn
= hashfn_user_defined
;
3972 h
->rehash_threshold
= rehash_threshold
;
3973 h
->rehash_size
= rehash_size
;
3975 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3976 h
->hash
= Fmake_vector (size
, Qnil
);
3977 h
->next
= Fmake_vector (size
, Qnil
);
3978 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3979 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3980 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3982 /* Set up the free list. */
3983 for (i
= 0; i
< sz
- 1; ++i
)
3984 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3985 h
->next_free
= make_number (0);
3987 XSET_HASH_TABLE (table
, h
);
3988 xassert (HASH_TABLE_P (table
));
3989 xassert (XHASH_TABLE (table
) == h
);
3991 /* Maybe add this hash table to the list of all weak hash tables. */
3993 h
->next_weak
= NULL
;
3996 h
->next_weak
= weak_hash_tables
;
3997 weak_hash_tables
= h
;
4004 /* Return a copy of hash table H1. Keys and values are not copied,
4005 only the table itself is. */
4008 copy_hash_table (h1
)
4009 struct Lisp_Hash_Table
*h1
;
4012 struct Lisp_Hash_Table
*h2
;
4013 struct Lisp_Vector
*next
;
4015 h2
= allocate_hash_table ();
4016 next
= h2
->vec_next
;
4017 bcopy (h1
, h2
, sizeof *h2
);
4018 h2
->vec_next
= next
;
4019 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4020 h2
->hash
= Fcopy_sequence (h1
->hash
);
4021 h2
->next
= Fcopy_sequence (h1
->next
);
4022 h2
->index
= Fcopy_sequence (h1
->index
);
4023 XSET_HASH_TABLE (table
, h2
);
4025 /* Maybe add this hash table to the list of all weak hash tables. */
4026 if (!NILP (h2
->weak
))
4028 h2
->next_weak
= weak_hash_tables
;
4029 weak_hash_tables
= h2
;
4036 /* Resize hash table H if it's too full. If H cannot be resized
4037 because it's already too large, throw an error. */
4040 maybe_resize_hash_table (h
)
4041 struct Lisp_Hash_Table
*h
;
4043 if (NILP (h
->next_free
))
4045 int old_size
= HASH_TABLE_SIZE (h
);
4046 int i
, new_size
, index_size
;
4049 if (INTEGERP (h
->rehash_size
))
4050 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4052 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4053 new_size
= max (old_size
+ 1, new_size
);
4054 index_size
= next_almost_prime ((int)
4056 / XFLOATINT (h
->rehash_threshold
)));
4057 /* Assignment to EMACS_INT stops GCC whining about limited range
4059 nsize
= max (index_size
, 2 * new_size
);
4060 if (nsize
> MOST_POSITIVE_FIXNUM
)
4061 error ("Hash table too large to resize");
4063 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4064 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4065 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4066 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4068 /* Update the free list. Do it so that new entries are added at
4069 the end of the free list. This makes some operations like
4071 for (i
= old_size
; i
< new_size
- 1; ++i
)
4072 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4074 if (!NILP (h
->next_free
))
4076 Lisp_Object last
, next
;
4078 last
= h
->next_free
;
4079 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4083 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4086 XSETFASTINT (h
->next_free
, old_size
);
4089 for (i
= 0; i
< old_size
; ++i
)
4090 if (!NILP (HASH_HASH (h
, i
)))
4092 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4093 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4094 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4095 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4101 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4102 the hash code of KEY. Value is the index of the entry in H
4103 matching KEY, or -1 if not found. */
4106 hash_lookup (h
, key
, hash
)
4107 struct Lisp_Hash_Table
*h
;
4112 int start_of_bucket
;
4115 hash_code
= h
->hashfn (h
, key
);
4119 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4120 idx
= HASH_INDEX (h
, start_of_bucket
);
4122 /* We need not gcpro idx since it's either an integer or nil. */
4125 int i
= XFASTINT (idx
);
4126 if (EQ (key
, HASH_KEY (h
, i
))
4128 && h
->cmpfn (h
, key
, hash_code
,
4129 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4131 idx
= HASH_NEXT (h
, i
);
4134 return NILP (idx
) ? -1 : XFASTINT (idx
);
4138 /* Put an entry into hash table H that associates KEY with VALUE.
4139 HASH is a previously computed hash code of KEY.
4140 Value is the index of the entry in H matching KEY. */
4143 hash_put (h
, key
, value
, hash
)
4144 struct Lisp_Hash_Table
*h
;
4145 Lisp_Object key
, value
;
4148 int start_of_bucket
, i
;
4150 xassert ((hash
& ~INTMASK
) == 0);
4152 /* Increment count after resizing because resizing may fail. */
4153 maybe_resize_hash_table (h
);
4156 /* Store key/value in the key_and_value vector. */
4157 i
= XFASTINT (h
->next_free
);
4158 h
->next_free
= HASH_NEXT (h
, i
);
4159 HASH_KEY (h
, i
) = key
;
4160 HASH_VALUE (h
, i
) = value
;
4162 /* Remember its hash code. */
4163 HASH_HASH (h
, i
) = make_number (hash
);
4165 /* Add new entry to its collision chain. */
4166 start_of_bucket
= hash
% ASIZE (h
->index
);
4167 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4168 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4173 /* Remove the entry matching KEY from hash table H, if there is one. */
4176 hash_remove (h
, key
)
4177 struct Lisp_Hash_Table
*h
;
4181 int start_of_bucket
;
4182 Lisp_Object idx
, prev
;
4184 hash_code
= h
->hashfn (h
, key
);
4185 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4186 idx
= HASH_INDEX (h
, start_of_bucket
);
4189 /* We need not gcpro idx, prev since they're either integers or nil. */
4192 int i
= XFASTINT (idx
);
4194 if (EQ (key
, HASH_KEY (h
, i
))
4196 && h
->cmpfn (h
, key
, hash_code
,
4197 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4199 /* Take entry out of collision chain. */
4201 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4203 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4205 /* Clear slots in key_and_value and add the slots to
4207 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4208 HASH_NEXT (h
, i
) = h
->next_free
;
4209 h
->next_free
= make_number (i
);
4211 xassert (h
->count
>= 0);
4217 idx
= HASH_NEXT (h
, i
);
4223 /* Clear hash table H. */
4227 struct Lisp_Hash_Table
*h
;
4231 int i
, size
= HASH_TABLE_SIZE (h
);
4233 for (i
= 0; i
< size
; ++i
)
4235 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4236 HASH_KEY (h
, i
) = Qnil
;
4237 HASH_VALUE (h
, i
) = Qnil
;
4238 HASH_HASH (h
, i
) = Qnil
;
4241 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4242 AREF (h
->index
, i
) = Qnil
;
4244 h
->next_free
= make_number (0);
4251 /************************************************************************
4253 ************************************************************************/
4255 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4256 entries from the table that don't survive the current GC.
4257 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4258 non-zero if anything was marked. */
4261 sweep_weak_table (h
, remove_entries_p
)
4262 struct Lisp_Hash_Table
*h
;
4263 int remove_entries_p
;
4265 int bucket
, n
, marked
;
4267 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4270 for (bucket
= 0; bucket
< n
; ++bucket
)
4272 Lisp_Object idx
, next
, prev
;
4274 /* Follow collision chain, removing entries that
4275 don't survive this garbage collection. */
4277 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4279 int i
= XFASTINT (idx
);
4280 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4281 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4284 if (EQ (h
->weak
, Qkey
))
4285 remove_p
= !key_known_to_survive_p
;
4286 else if (EQ (h
->weak
, Qvalue
))
4287 remove_p
= !value_known_to_survive_p
;
4288 else if (EQ (h
->weak
, Qkey_or_value
))
4289 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4290 else if (EQ (h
->weak
, Qkey_and_value
))
4291 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4295 next
= HASH_NEXT (h
, i
);
4297 if (remove_entries_p
)
4301 /* Take out of collision chain. */
4303 HASH_INDEX (h
, bucket
) = next
;
4305 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4307 /* Add to free list. */
4308 HASH_NEXT (h
, i
) = h
->next_free
;
4311 /* Clear key, value, and hash. */
4312 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4313 HASH_HASH (h
, i
) = Qnil
;
4326 /* Make sure key and value survive. */
4327 if (!key_known_to_survive_p
)
4329 mark_object (HASH_KEY (h
, i
));
4333 if (!value_known_to_survive_p
)
4335 mark_object (HASH_VALUE (h
, i
));
4346 /* Remove elements from weak hash tables that don't survive the
4347 current garbage collection. Remove weak tables that don't survive
4348 from Vweak_hash_tables. Called from gc_sweep. */
4351 sweep_weak_hash_tables ()
4353 struct Lisp_Hash_Table
*h
, *used
, *next
;
4356 /* Mark all keys and values that are in use. Keep on marking until
4357 there is no more change. This is necessary for cases like
4358 value-weak table A containing an entry X -> Y, where Y is used in a
4359 key-weak table B, Z -> Y. If B comes after A in the list of weak
4360 tables, X -> Y might be removed from A, although when looking at B
4361 one finds that it shouldn't. */
4365 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4367 if (h
->size
& ARRAY_MARK_FLAG
)
4368 marked
|= sweep_weak_table (h
, 0);
4373 /* Remove tables and entries that aren't used. */
4374 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4376 next
= h
->next_weak
;
4378 if (h
->size
& ARRAY_MARK_FLAG
)
4380 /* TABLE is marked as used. Sweep its contents. */
4382 sweep_weak_table (h
, 1);
4384 /* Add table to the list of used weak hash tables. */
4385 h
->next_weak
= used
;
4390 weak_hash_tables
= used
;
4395 /***********************************************************************
4396 Hash Code Computation
4397 ***********************************************************************/
4399 /* Maximum depth up to which to dive into Lisp structures. */
4401 #define SXHASH_MAX_DEPTH 3
4403 /* Maximum length up to which to take list and vector elements into
4406 #define SXHASH_MAX_LEN 7
4408 /* Combine two integers X and Y for hashing. */
4410 #define SXHASH_COMBINE(X, Y) \
4411 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4415 /* Return a hash for string PTR which has length LEN. The hash
4416 code returned is guaranteed to fit in a Lisp integer. */
4419 sxhash_string (ptr
, len
)
4423 unsigned char *p
= ptr
;
4424 unsigned char *end
= p
+ len
;
4433 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4436 return hash
& INTMASK
;
4440 /* Return a hash for list LIST. DEPTH is the current depth in the
4441 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4444 sxhash_list (list
, depth
)
4451 if (depth
< SXHASH_MAX_DEPTH
)
4453 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4454 list
= XCDR (list
), ++i
)
4456 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4457 hash
= SXHASH_COMBINE (hash
, hash2
);
4462 unsigned hash2
= sxhash (list
, depth
+ 1);
4463 hash
= SXHASH_COMBINE (hash
, hash2
);
4470 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4471 the Lisp structure. */
4474 sxhash_vector (vec
, depth
)
4478 unsigned hash
= ASIZE (vec
);
4481 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4482 for (i
= 0; i
< n
; ++i
)
4484 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4485 hash
= SXHASH_COMBINE (hash
, hash2
);
4492 /* Return a hash for bool-vector VECTOR. */
4495 sxhash_bool_vector (vec
)
4498 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4501 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4502 for (i
= 0; i
< n
; ++i
)
4503 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4509 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4510 structure. Value is an unsigned integer clipped to INTMASK. */
4519 if (depth
> SXHASH_MAX_DEPTH
)
4522 switch (XTYPE (obj
))
4533 obj
= SYMBOL_NAME (obj
);
4537 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4540 /* This can be everything from a vector to an overlay. */
4541 case Lisp_Vectorlike
:
4543 /* According to the CL HyperSpec, two arrays are equal only if
4544 they are `eq', except for strings and bit-vectors. In
4545 Emacs, this works differently. We have to compare element
4547 hash
= sxhash_vector (obj
, depth
);
4548 else if (BOOL_VECTOR_P (obj
))
4549 hash
= sxhash_bool_vector (obj
);
4551 /* Others are `equal' if they are `eq', so let's take their
4557 hash
= sxhash_list (obj
, depth
);
4562 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4563 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4564 for (hash
= 0; p
< e
; ++p
)
4565 hash
= SXHASH_COMBINE (hash
, *p
);
4573 return hash
& INTMASK
;
4578 /***********************************************************************
4580 ***********************************************************************/
4583 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4584 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4588 unsigned hash
= sxhash (obj
, 0);
4589 return make_number (hash
);
4593 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4594 doc
: /* Create and return a new hash table.
4596 Arguments are specified as keyword/argument pairs. The following
4597 arguments are defined:
4599 :test TEST -- TEST must be a symbol that specifies how to compare
4600 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4601 `equal'. User-supplied test and hash functions can be specified via
4602 `define-hash-table-test'.
4604 :size SIZE -- A hint as to how many elements will be put in the table.
4607 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4608 fills up. If REHASH-SIZE is an integer, add that many space. If it
4609 is a float, it must be > 1.0, and the new size is computed by
4610 multiplying the old size with that factor. Default is 1.5.
4612 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4613 Resize the hash table when ratio of the number of entries in the
4614 table. Default is 0.8.
4616 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4617 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4618 returned is a weak table. Key/value pairs are removed from a weak
4619 hash table when there are no non-weak references pointing to their
4620 key, value, one of key or value, or both key and value, depending on
4621 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4624 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4629 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4630 Lisp_Object user_test
, user_hash
;
4634 /* The vector `used' is used to keep track of arguments that
4635 have been consumed. */
4636 used
= (char *) alloca (nargs
* sizeof *used
);
4637 bzero (used
, nargs
* sizeof *used
);
4639 /* See if there's a `:test TEST' among the arguments. */
4640 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4641 test
= i
< 0 ? Qeql
: args
[i
];
4642 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4644 /* See if it is a user-defined test. */
4647 prop
= Fget (test
, Qhash_table_test
);
4648 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4649 signal_error ("Invalid hash table test", test
);
4650 user_test
= XCAR (prop
);
4651 user_hash
= XCAR (XCDR (prop
));
4654 user_test
= user_hash
= Qnil
;
4656 /* See if there's a `:size SIZE' argument. */
4657 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4658 size
= i
< 0 ? Qnil
: args
[i
];
4660 size
= make_number (DEFAULT_HASH_SIZE
);
4661 else if (!INTEGERP (size
) || XINT (size
) < 0)
4662 signal_error ("Invalid hash table size", size
);
4664 /* Look for `:rehash-size SIZE'. */
4665 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4666 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4667 if (!NUMBERP (rehash_size
)
4668 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4669 || XFLOATINT (rehash_size
) <= 1.0)
4670 signal_error ("Invalid hash table rehash size", rehash_size
);
4672 /* Look for `:rehash-threshold THRESHOLD'. */
4673 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4674 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4675 if (!FLOATP (rehash_threshold
)
4676 || XFLOATINT (rehash_threshold
) <= 0.0
4677 || XFLOATINT (rehash_threshold
) > 1.0)
4678 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4680 /* Look for `:weakness WEAK'. */
4681 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4682 weak
= i
< 0 ? Qnil
: args
[i
];
4684 weak
= Qkey_and_value
;
4687 && !EQ (weak
, Qvalue
)
4688 && !EQ (weak
, Qkey_or_value
)
4689 && !EQ (weak
, Qkey_and_value
))
4690 signal_error ("Invalid hash table weakness", weak
);
4692 /* Now, all args should have been used up, or there's a problem. */
4693 for (i
= 0; i
< nargs
; ++i
)
4695 signal_error ("Invalid argument list", args
[i
]);
4697 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4698 user_test
, user_hash
);
4702 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4703 doc
: /* Return a copy of hash table TABLE. */)
4707 return copy_hash_table (check_hash_table (table
));
4711 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4712 doc
: /* Return the number of elements in TABLE. */)
4716 return make_number (check_hash_table (table
)->count
);
4720 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4721 Shash_table_rehash_size
, 1, 1, 0,
4722 doc
: /* Return the current rehash size of TABLE. */)
4726 return check_hash_table (table
)->rehash_size
;
4730 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4731 Shash_table_rehash_threshold
, 1, 1, 0,
4732 doc
: /* Return the current rehash threshold of TABLE. */)
4736 return check_hash_table (table
)->rehash_threshold
;
4740 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4741 doc
: /* Return the size of TABLE.
4742 The size can be used as an argument to `make-hash-table' to create
4743 a hash table than can hold as many elements of TABLE holds
4744 without need for resizing. */)
4748 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4749 return make_number (HASH_TABLE_SIZE (h
));
4753 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4754 doc
: /* Return the test TABLE uses. */)
4758 return check_hash_table (table
)->test
;
4762 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4764 doc
: /* Return the weakness of TABLE. */)
4768 return check_hash_table (table
)->weak
;
4772 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4773 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4777 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4781 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4782 doc
: /* Clear hash table TABLE and return it. */)
4786 hash_clear (check_hash_table (table
));
4787 /* Be compatible with XEmacs. */
4792 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4793 doc
: /* Look up KEY in TABLE and return its associated value.
4794 If KEY is not found, return DFLT which defaults to nil. */)
4796 Lisp_Object key
, table
, dflt
;
4798 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4799 int i
= hash_lookup (h
, key
, NULL
);
4800 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4804 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4805 doc
: /* Associate KEY with VALUE in hash table TABLE.
4806 If KEY is already present in table, replace its current value with
4809 Lisp_Object key
, value
, table
;
4811 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4815 i
= hash_lookup (h
, key
, &hash
);
4817 HASH_VALUE (h
, i
) = value
;
4819 hash_put (h
, key
, value
, hash
);
4825 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4826 doc
: /* Remove KEY from TABLE. */)
4828 Lisp_Object key
, table
;
4830 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4831 hash_remove (h
, key
);
4836 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4837 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4838 FUNCTION is called with two arguments, KEY and VALUE. */)
4840 Lisp_Object function
, table
;
4842 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4843 Lisp_Object args
[3];
4846 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4847 if (!NILP (HASH_HASH (h
, i
)))
4850 args
[1] = HASH_KEY (h
, i
);
4851 args
[2] = HASH_VALUE (h
, i
);
4859 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4860 Sdefine_hash_table_test
, 3, 3, 0,
4861 doc
: /* Define a new hash table test with name NAME, a symbol.
4863 In hash tables created with NAME specified as test, use TEST to
4864 compare keys, and HASH for computing hash codes of keys.
4866 TEST must be a function taking two arguments and returning non-nil if
4867 both arguments are the same. HASH must be a function taking one
4868 argument and return an integer that is the hash code of the argument.
4869 Hash code computation should use the whole value range of integers,
4870 including negative integers. */)
4872 Lisp_Object name
, test
, hash
;
4874 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4879 /************************************************************************
4881 ************************************************************************/
4885 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4886 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4888 A message digest is a cryptographic checksum of a document, and the
4889 algorithm to calculate it is defined in RFC 1321.
4891 The two optional arguments START and END are character positions
4892 specifying for which part of OBJECT the message digest should be
4893 computed. If nil or omitted, the digest is computed for the whole
4896 The MD5 message digest is computed from the result of encoding the
4897 text in a coding system, not directly from the internal Emacs form of
4898 the text. The optional fourth argument CODING-SYSTEM specifies which
4899 coding system to encode the text with. It should be the same coding
4900 system that you used or will use when actually writing the text into a
4903 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4904 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4905 system would be chosen by default for writing this text into a file.
4907 If OBJECT is a string, the most preferred coding system (see the
4908 command `prefer-coding-system') is used.
4910 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4911 guesswork fails. Normally, an error is signaled in such case. */)
4912 (object
, start
, end
, coding_system
, noerror
)
4913 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4915 unsigned char digest
[16];
4916 unsigned char value
[33];
4920 int start_char
= 0, end_char
= 0;
4921 int start_byte
= 0, end_byte
= 0;
4923 register struct buffer
*bp
;
4926 if (STRINGP (object
))
4928 if (NILP (coding_system
))
4930 /* Decide the coding-system to encode the data with. */
4932 if (STRING_MULTIBYTE (object
))
4933 /* use default, we can't guess correct value */
4934 coding_system
= preferred_coding_system ();
4936 coding_system
= Qraw_text
;
4939 if (NILP (Fcoding_system_p (coding_system
)))
4941 /* Invalid coding system. */
4943 if (!NILP (noerror
))
4944 coding_system
= Qraw_text
;
4946 xsignal1 (Qcoding_system_error
, coding_system
);
4949 if (STRING_MULTIBYTE (object
))
4950 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4952 size
= SCHARS (object
);
4953 size_byte
= SBYTES (object
);
4957 CHECK_NUMBER (start
);
4959 start_char
= XINT (start
);
4964 start_byte
= string_char_to_byte (object
, start_char
);
4970 end_byte
= size_byte
;
4976 end_char
= XINT (end
);
4981 end_byte
= string_char_to_byte (object
, end_char
);
4984 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4985 args_out_of_range_3 (object
, make_number (start_char
),
4986 make_number (end_char
));
4990 struct buffer
*prev
= current_buffer
;
4992 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4994 CHECK_BUFFER (object
);
4996 bp
= XBUFFER (object
);
4997 if (bp
!= current_buffer
)
4998 set_buffer_internal (bp
);
5004 CHECK_NUMBER_COERCE_MARKER (start
);
5012 CHECK_NUMBER_COERCE_MARKER (end
);
5017 temp
= b
, b
= e
, e
= temp
;
5019 if (!(BEGV
<= b
&& e
<= ZV
))
5020 args_out_of_range (start
, end
);
5022 if (NILP (coding_system
))
5024 /* Decide the coding-system to encode the data with.
5025 See fileio.c:Fwrite-region */
5027 if (!NILP (Vcoding_system_for_write
))
5028 coding_system
= Vcoding_system_for_write
;
5031 int force_raw_text
= 0;
5033 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5034 if (NILP (coding_system
)
5035 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5037 coding_system
= Qnil
;
5038 if (NILP (current_buffer
->enable_multibyte_characters
))
5042 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5044 /* Check file-coding-system-alist. */
5045 Lisp_Object args
[4], val
;
5047 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5048 args
[3] = Fbuffer_file_name(object
);
5049 val
= Ffind_operation_coding_system (4, args
);
5050 if (CONSP (val
) && !NILP (XCDR (val
)))
5051 coding_system
= XCDR (val
);
5054 if (NILP (coding_system
)
5055 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5057 /* If we still have not decided a coding system, use the
5058 default value of buffer-file-coding-system. */
5059 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5063 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5064 /* Confirm that VAL can surely encode the current region. */
5065 coding_system
= call4 (Vselect_safe_coding_system_function
,
5066 make_number (b
), make_number (e
),
5067 coding_system
, Qnil
);
5070 coding_system
= Qraw_text
;
5073 if (NILP (Fcoding_system_p (coding_system
)))
5075 /* Invalid coding system. */
5077 if (!NILP (noerror
))
5078 coding_system
= Qraw_text
;
5080 xsignal1 (Qcoding_system_error
, coding_system
);
5084 object
= make_buffer_string (b
, e
, 0);
5085 if (prev
!= current_buffer
)
5086 set_buffer_internal (prev
);
5087 /* Discard the unwind protect for recovering the current
5091 if (STRING_MULTIBYTE (object
))
5092 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5095 md5_buffer (SDATA (object
) + start_byte
,
5096 SBYTES (object
) - (size_byte
- end_byte
),
5099 for (i
= 0; i
< 16; i
++)
5100 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5103 return make_string (value
, 32);
5110 /* Hash table stuff. */
5111 Qhash_table_p
= intern ("hash-table-p");
5112 staticpro (&Qhash_table_p
);
5113 Qeq
= intern ("eq");
5115 Qeql
= intern ("eql");
5117 Qequal
= intern ("equal");
5118 staticpro (&Qequal
);
5119 QCtest
= intern (":test");
5120 staticpro (&QCtest
);
5121 QCsize
= intern (":size");
5122 staticpro (&QCsize
);
5123 QCrehash_size
= intern (":rehash-size");
5124 staticpro (&QCrehash_size
);
5125 QCrehash_threshold
= intern (":rehash-threshold");
5126 staticpro (&QCrehash_threshold
);
5127 QCweakness
= intern (":weakness");
5128 staticpro (&QCweakness
);
5129 Qkey
= intern ("key");
5131 Qvalue
= intern ("value");
5132 staticpro (&Qvalue
);
5133 Qhash_table_test
= intern ("hash-table-test");
5134 staticpro (&Qhash_table_test
);
5135 Qkey_or_value
= intern ("key-or-value");
5136 staticpro (&Qkey_or_value
);
5137 Qkey_and_value
= intern ("key-and-value");
5138 staticpro (&Qkey_and_value
);
5141 defsubr (&Smake_hash_table
);
5142 defsubr (&Scopy_hash_table
);
5143 defsubr (&Shash_table_count
);
5144 defsubr (&Shash_table_rehash_size
);
5145 defsubr (&Shash_table_rehash_threshold
);
5146 defsubr (&Shash_table_size
);
5147 defsubr (&Shash_table_test
);
5148 defsubr (&Shash_table_weakness
);
5149 defsubr (&Shash_table_p
);
5150 defsubr (&Sclrhash
);
5151 defsubr (&Sgethash
);
5152 defsubr (&Sputhash
);
5153 defsubr (&Sremhash
);
5154 defsubr (&Smaphash
);
5155 defsubr (&Sdefine_hash_table_test
);
5157 Qstring_lessp
= intern ("string-lessp");
5158 staticpro (&Qstring_lessp
);
5159 Qprovide
= intern ("provide");
5160 staticpro (&Qprovide
);
5161 Qrequire
= intern ("require");
5162 staticpro (&Qrequire
);
5163 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5164 staticpro (&Qyes_or_no_p_history
);
5165 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5166 staticpro (&Qcursor_in_echo_area
);
5167 Qwidget_type
= intern ("widget-type");
5168 staticpro (&Qwidget_type
);
5170 staticpro (&string_char_byte_cache_string
);
5171 string_char_byte_cache_string
= Qnil
;
5173 require_nesting_list
= Qnil
;
5174 staticpro (&require_nesting_list
);
5176 Fset (Qyes_or_no_p_history
, Qnil
);
5178 DEFVAR_LISP ("features", &Vfeatures
,
5179 doc
: /* A list of symbols which are the features of the executing Emacs.
5180 Used by `featurep' and `require', and altered by `provide'. */);
5181 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5182 Qsubfeatures
= intern ("subfeatures");
5183 staticpro (&Qsubfeatures
);
5185 #ifdef HAVE_LANGINFO_CODESET
5186 Qcodeset
= intern ("codeset");
5187 staticpro (&Qcodeset
);
5188 Qdays
= intern ("days");
5190 Qmonths
= intern ("months");
5191 staticpro (&Qmonths
);
5192 Qpaper
= intern ("paper");
5193 staticpro (&Qpaper
);
5194 #endif /* HAVE_LANGINFO_CODESET */
5196 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5197 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5198 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5199 invoked by mouse clicks and mouse menu items. */);
5202 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5203 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5204 This applies to commands from menus and tool bar buttons even when
5205 they are initiated from the keyboard. The value of `use-dialog-box'
5206 takes precedence over this variable, so a file dialog is only used if
5207 both `use-dialog-box' and this variable are non-nil. */);
5208 use_file_dialog
= 1;
5210 defsubr (&Sidentity
);
5213 defsubr (&Ssafe_length
);
5214 defsubr (&Sstring_bytes
);
5215 defsubr (&Sstring_equal
);
5216 defsubr (&Scompare_strings
);
5217 defsubr (&Sstring_lessp
);
5220 defsubr (&Svconcat
);
5221 defsubr (&Scopy_sequence
);
5222 defsubr (&Sstring_make_multibyte
);
5223 defsubr (&Sstring_make_unibyte
);
5224 defsubr (&Sstring_as_multibyte
);
5225 defsubr (&Sstring_as_unibyte
);
5226 defsubr (&Sstring_to_multibyte
);
5227 defsubr (&Scopy_alist
);
5228 defsubr (&Ssubstring
);
5229 defsubr (&Ssubstring_no_properties
);
5242 defsubr (&Snreverse
);
5243 defsubr (&Sreverse
);
5245 defsubr (&Splist_get
);
5247 defsubr (&Splist_put
);
5249 defsubr (&Slax_plist_get
);
5250 defsubr (&Slax_plist_put
);
5253 defsubr (&Sequal_including_properties
);
5254 defsubr (&Sfillarray
);
5255 defsubr (&Sclear_string
);
5259 defsubr (&Smapconcat
);
5260 defsubr (&Sy_or_n_p
);
5261 defsubr (&Syes_or_no_p
);
5262 defsubr (&Sload_average
);
5263 defsubr (&Sfeaturep
);
5264 defsubr (&Srequire
);
5265 defsubr (&Sprovide
);
5266 defsubr (&Splist_member
);
5267 defsubr (&Swidget_put
);
5268 defsubr (&Swidget_get
);
5269 defsubr (&Swidget_apply
);
5270 defsubr (&Sbase64_encode_region
);
5271 defsubr (&Sbase64_decode_region
);
5272 defsubr (&Sbase64_encode_string
);
5273 defsubr (&Sbase64_decode_string
);
5275 defsubr (&Slocale_info
);
5282 weak_hash_tables
= NULL
;
5285 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5286 (do not change this comment) */