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 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 2, 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
; !NILP (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
; !NILP (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
; !NILP (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
, Qnil
));
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 ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2610 Lisp_Object pane
, menu
;
2611 redisplay_preserve_echo_area (3);
2612 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2613 Fcons (Fcons (build_string ("No"), Qnil
),
2615 menu
= Fcons (prompt
, pane
);
2616 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2617 answer
= !NILP (obj
);
2620 #endif /* HAVE_MENUS */
2621 cursor_in_echo_area
= 1;
2622 choose_minibuf_frame ();
2625 Lisp_Object pargs
[3];
2627 /* Colorize prompt according to `minibuffer-prompt' face. */
2628 pargs
[0] = build_string ("%s(y or n) ");
2629 pargs
[1] = intern ("face");
2630 pargs
[2] = intern ("minibuffer-prompt");
2631 args
[0] = Fpropertize (3, pargs
);
2636 if (minibuffer_auto_raise
)
2638 Lisp_Object mini_frame
;
2640 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2642 Fraise_frame (mini_frame
);
2645 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
2646 cursor_in_echo_area
= 0;
2647 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2650 key
= Fmake_vector (make_number (1), obj
);
2651 def
= Flookup_key (map
, key
, Qt
);
2653 if (EQ (def
, intern ("skip")))
2658 else if (EQ (def
, intern ("act")))
2663 else if (EQ (def
, intern ("recenter")))
2669 else if (EQ (def
, intern ("quit")))
2671 /* We want to exit this command for exit-prefix,
2672 and this is the only way to do it. */
2673 else if (EQ (def
, intern ("exit-prefix")))
2678 /* If we don't clear this, then the next call to read_char will
2679 return quit_char again, and we'll enter an infinite loop. */
2684 if (EQ (xprompt
, prompt
))
2686 args
[0] = build_string ("Please answer y or n. ");
2688 xprompt
= Fconcat (2, args
);
2693 if (! noninteractive
)
2695 cursor_in_echo_area
= -1;
2696 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2700 unbind_to (count
, Qnil
);
2701 return answer
? Qt
: Qnil
;
2704 /* This is how C code calls `yes-or-no-p' and allows the user
2707 Anything that calls this function must protect from GC! */
2710 do_yes_or_no_p (prompt
)
2713 return call1 (intern ("yes-or-no-p"), prompt
);
2716 /* Anything that calls this function must protect from GC! */
2718 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2719 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2720 Takes one argument, which is the string to display to ask the question.
2721 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2722 The user must confirm the answer with RET,
2723 and can edit it until it has been confirmed.
2725 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2726 is nil, and `use-dialog-box' is non-nil. */)
2730 register Lisp_Object ans
;
2731 Lisp_Object args
[2];
2732 struct gcpro gcpro1
;
2734 CHECK_STRING (prompt
);
2737 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2741 Lisp_Object pane
, menu
, obj
;
2742 redisplay_preserve_echo_area (4);
2743 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2744 Fcons (Fcons (build_string ("No"), Qnil
),
2747 menu
= Fcons (prompt
, pane
);
2748 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2752 #endif /* HAVE_MENUS */
2755 args
[1] = build_string ("(yes or no) ");
2756 prompt
= Fconcat (2, args
);
2762 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2763 Qyes_or_no_p_history
, Qnil
,
2765 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2770 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2778 message ("Please answer yes or no.");
2779 Fsleep_for (make_number (2), Qnil
);
2783 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2784 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2786 Each of the three load averages is multiplied by 100, then converted
2789 When USE-FLOATS is non-nil, floats will be used instead of integers.
2790 These floats are not multiplied by 100.
2792 If the 5-minute or 15-minute load averages are not available, return a
2793 shortened list, containing only those averages which are available.
2795 An error is thrown if the load average can't be obtained. In some
2796 cases making it work would require Emacs being installed setuid or
2797 setgid so that it can read kernel information, and that usually isn't
2800 Lisp_Object use_floats
;
2803 int loads
= getloadavg (load_ave
, 3);
2804 Lisp_Object ret
= Qnil
;
2807 error ("load-average not implemented for this operating system");
2811 Lisp_Object load
= (NILP (use_floats
) ?
2812 make_number ((int) (100.0 * load_ave
[loads
]))
2813 : make_float (load_ave
[loads
]));
2814 ret
= Fcons (load
, ret
);
2820 Lisp_Object Vfeatures
, Qsubfeatures
;
2821 extern Lisp_Object Vafter_load_alist
;
2823 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2824 doc
: /* Returns t if FEATURE is present in this Emacs.
2826 Use this to conditionalize execution of lisp code based on the
2827 presence or absence of Emacs or environment extensions.
2828 Use `provide' to declare that a feature is available. This function
2829 looks at the value of the variable `features'. The optional argument
2830 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2831 (feature
, subfeature
)
2832 Lisp_Object feature
, subfeature
;
2834 register Lisp_Object tem
;
2835 CHECK_SYMBOL (feature
);
2836 tem
= Fmemq (feature
, Vfeatures
);
2837 if (!NILP (tem
) && !NILP (subfeature
))
2838 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2839 return (NILP (tem
)) ? Qnil
: Qt
;
2842 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2843 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2844 The optional argument SUBFEATURES should be a list of symbols listing
2845 particular subfeatures supported in this version of FEATURE. */)
2846 (feature
, subfeatures
)
2847 Lisp_Object feature
, subfeatures
;
2849 register Lisp_Object tem
;
2850 CHECK_SYMBOL (feature
);
2851 CHECK_LIST (subfeatures
);
2852 if (!NILP (Vautoload_queue
))
2853 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2855 tem
= Fmemq (feature
, Vfeatures
);
2857 Vfeatures
= Fcons (feature
, Vfeatures
);
2858 if (!NILP (subfeatures
))
2859 Fput (feature
, Qsubfeatures
, subfeatures
);
2860 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2862 /* Run any load-hooks for this file. */
2863 tem
= Fassq (feature
, Vafter_load_alist
);
2865 Fprogn (XCDR (tem
));
2870 /* `require' and its subroutines. */
2872 /* List of features currently being require'd, innermost first. */
2874 Lisp_Object require_nesting_list
;
2877 require_unwind (old_value
)
2878 Lisp_Object old_value
;
2880 return require_nesting_list
= old_value
;
2883 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2884 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2885 If FEATURE is not a member of the list `features', then the feature
2886 is not loaded; so load the file FILENAME.
2887 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2888 and `load' will try to load this name appended with the suffix `.elc' or
2889 `.el', in that order. The name without appended suffix will not be used.
2890 If the optional third argument NOERROR is non-nil,
2891 then return nil if the file is not found instead of signaling an error.
2892 Normally the return value is FEATURE.
2893 The normal messages at start and end of loading FILENAME are suppressed. */)
2894 (feature
, filename
, noerror
)
2895 Lisp_Object feature
, filename
, noerror
;
2897 register Lisp_Object tem
;
2898 struct gcpro gcpro1
, gcpro2
;
2899 int from_file
= load_in_progress
;
2901 CHECK_SYMBOL (feature
);
2903 /* Record the presence of `require' in this file
2904 even if the feature specified is already loaded.
2905 But not more than once in any file,
2906 and not when we aren't loading or reading from a file. */
2908 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2909 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2914 tem
= Fcons (Qrequire
, feature
);
2915 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2916 LOADHIST_ATTACH (tem
);
2918 tem
= Fmemq (feature
, Vfeatures
);
2922 int count
= SPECPDL_INDEX ();
2925 /* This is to make sure that loadup.el gives a clear picture
2926 of what files are preloaded and when. */
2927 if (! NILP (Vpurify_flag
))
2928 error ("(require %s) while preparing to dump",
2929 SDATA (SYMBOL_NAME (feature
)));
2931 /* A certain amount of recursive `require' is legitimate,
2932 but if we require the same feature recursively 3 times,
2934 tem
= require_nesting_list
;
2935 while (! NILP (tem
))
2937 if (! NILP (Fequal (feature
, XCAR (tem
))))
2942 error ("Recursive `require' for feature `%s'",
2943 SDATA (SYMBOL_NAME (feature
)));
2945 /* Update the list for any nested `require's that occur. */
2946 record_unwind_protect (require_unwind
, require_nesting_list
);
2947 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2949 /* Value saved here is to be restored into Vautoload_queue */
2950 record_unwind_protect (un_autoload
, Vautoload_queue
);
2951 Vautoload_queue
= Qt
;
2953 /* Load the file. */
2954 GCPRO2 (feature
, filename
);
2955 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2956 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2959 /* If load failed entirely, return nil. */
2961 return unbind_to (count
, Qnil
);
2963 tem
= Fmemq (feature
, Vfeatures
);
2965 error ("Required feature `%s' was not provided",
2966 SDATA (SYMBOL_NAME (feature
)));
2968 /* Once loading finishes, don't undo it. */
2969 Vautoload_queue
= Qt
;
2970 feature
= unbind_to (count
, feature
);
2976 /* Primitives for work of the "widget" library.
2977 In an ideal world, this section would not have been necessary.
2978 However, lisp function calls being as slow as they are, it turns
2979 out that some functions in the widget library (wid-edit.el) are the
2980 bottleneck of Widget operation. Here is their translation to C,
2981 for the sole reason of efficiency. */
2983 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2984 doc
: /* Return non-nil if PLIST has the property PROP.
2985 PLIST is a property list, which is a list of the form
2986 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2987 Unlike `plist-get', this allows you to distinguish between a missing
2988 property and a property with the value nil.
2989 The value is actually the tail of PLIST whose car is PROP. */)
2991 Lisp_Object plist
, prop
;
2993 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2996 plist
= XCDR (plist
);
2997 plist
= CDR (plist
);
3002 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3003 doc
: /* In WIDGET, set PROPERTY to VALUE.
3004 The value can later be retrieved with `widget-get'. */)
3005 (widget
, property
, value
)
3006 Lisp_Object widget
, property
, value
;
3008 CHECK_CONS (widget
);
3009 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3013 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3014 doc
: /* In WIDGET, get the value of PROPERTY.
3015 The value could either be specified when the widget was created, or
3016 later with `widget-put'. */)
3018 Lisp_Object widget
, property
;
3026 CHECK_CONS (widget
);
3027 tmp
= Fplist_member (XCDR (widget
), property
);
3033 tmp
= XCAR (widget
);
3036 widget
= Fget (tmp
, Qwidget_type
);
3040 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3041 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3042 ARGS are passed as extra arguments to the function.
3043 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3048 /* This function can GC. */
3049 Lisp_Object newargs
[3];
3050 struct gcpro gcpro1
, gcpro2
;
3053 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3054 newargs
[1] = args
[0];
3055 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3056 GCPRO2 (newargs
[0], newargs
[2]);
3057 result
= Fapply (3, newargs
);
3062 #ifdef HAVE_LANGINFO_CODESET
3063 #include <langinfo.h>
3066 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3067 doc
: /* Access locale data ITEM for the current C locale, if available.
3068 ITEM should be one of the following:
3070 `codeset', returning the character set as a string (locale item CODESET);
3072 `days', returning a 7-element vector of day names (locale items DAY_n);
3074 `months', returning a 12-element vector of month names (locale items MON_n);
3076 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3077 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3079 If the system can't provide such information through a call to
3080 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3082 See also Info node `(libc)Locales'.
3084 The data read from the system are decoded using `locale-coding-system'. */)
3089 #ifdef HAVE_LANGINFO_CODESET
3091 if (EQ (item
, Qcodeset
))
3093 str
= nl_langinfo (CODESET
);
3094 return build_string (str
);
3097 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3099 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3100 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3102 synchronize_system_time_locale ();
3103 for (i
= 0; i
< 7; i
++)
3105 str
= nl_langinfo (days
[i
]);
3106 val
= make_unibyte_string (str
, strlen (str
));
3107 /* Fixme: Is this coding system necessarily right, even if
3108 it is consistent with CODESET? If not, what to do? */
3109 Faset (v
, make_number (i
),
3110 code_convert_string_norecord (val
, Vlocale_coding_system
,
3117 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3119 struct Lisp_Vector
*p
= allocate_vector (12);
3120 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3121 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3123 synchronize_system_time_locale ();
3124 for (i
= 0; i
< 12; i
++)
3126 str
= nl_langinfo (months
[i
]);
3127 val
= make_unibyte_string (str
, strlen (str
));
3129 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3131 XSETVECTOR (val
, p
);
3135 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3136 but is in the locale files. This could be used by ps-print. */
3138 else if (EQ (item
, Qpaper
))
3140 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3141 make_number (nl_langinfo (PAPER_HEIGHT
)));
3143 #endif /* PAPER_WIDTH */
3144 #endif /* HAVE_LANGINFO_CODESET*/
3148 /* base64 encode/decode functions (RFC 2045).
3149 Based on code from GNU recode. */
3151 #define MIME_LINE_LENGTH 76
3153 #define IS_ASCII(Character) \
3155 #define IS_BASE64(Character) \
3156 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3157 #define IS_BASE64_IGNORABLE(Character) \
3158 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3159 || (Character) == '\f' || (Character) == '\r')
3161 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3162 character or return retval if there are no characters left to
3164 #define READ_QUADRUPLET_BYTE(retval) \
3169 if (nchars_return) \
3170 *nchars_return = nchars; \
3175 while (IS_BASE64_IGNORABLE (c))
3177 /* Table of characters coding the 64 values. */
3178 static char base64_value_to_char
[64] =
3180 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3181 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3182 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3183 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3184 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3185 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3186 '8', '9', '+', '/' /* 60-63 */
3189 /* Table of base64 values for first 128 characters. */
3190 static short base64_char_to_value
[128] =
3192 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3193 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3194 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3195 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3196 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3197 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3198 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3199 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3200 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3201 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3202 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3203 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3204 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3207 /* The following diagram shows the logical steps by which three octets
3208 get transformed into four base64 characters.
3210 .--------. .--------. .--------.
3211 |aaaaaabb| |bbbbcccc| |ccdddddd|
3212 `--------' `--------' `--------'
3214 .--------+--------+--------+--------.
3215 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3216 `--------+--------+--------+--------'
3218 .--------+--------+--------+--------.
3219 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3220 `--------+--------+--------+--------'
3222 The octets are divided into 6 bit chunks, which are then encoded into
3223 base64 characters. */
3226 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3227 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3229 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3231 doc
: /* Base64-encode the region between BEG and END.
3232 Return the length of the encoded text.
3233 Optional third argument NO-LINE-BREAK means do not break long lines
3234 into shorter lines. */)
3235 (beg
, end
, no_line_break
)
3236 Lisp_Object beg
, end
, no_line_break
;
3239 int allength
, length
;
3240 int ibeg
, iend
, encoded_length
;
3244 validate_region (&beg
, &end
);
3246 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3247 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3248 move_gap_both (XFASTINT (beg
), ibeg
);
3250 /* We need to allocate enough room for encoding the text.
3251 We need 33 1/3% more space, plus a newline every 76
3252 characters, and then we round up. */
3253 length
= iend
- ibeg
;
3254 allength
= length
+ length
/3 + 1;
3255 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3257 SAFE_ALLOCA (encoded
, char *, allength
);
3258 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3259 NILP (no_line_break
),
3260 !NILP (current_buffer
->enable_multibyte_characters
));
3261 if (encoded_length
> allength
)
3264 if (encoded_length
< 0)
3266 /* The encoding wasn't possible. */
3268 error ("Multibyte character in data for base64 encoding");
3271 /* Now we have encoded the region, so we insert the new contents
3272 and delete the old. (Insert first in order to preserve markers.) */
3273 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3274 insert (encoded
, encoded_length
);
3276 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3278 /* If point was outside of the region, restore it exactly; else just
3279 move to the beginning of the region. */
3280 if (old_pos
>= XFASTINT (end
))
3281 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3282 else if (old_pos
> XFASTINT (beg
))
3283 old_pos
= XFASTINT (beg
);
3286 /* We return the length of the encoded text. */
3287 return make_number (encoded_length
);
3290 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3292 doc
: /* Base64-encode STRING and return the result.
3293 Optional second argument NO-LINE-BREAK means do not break long lines
3294 into shorter lines. */)
3295 (string
, no_line_break
)
3296 Lisp_Object string
, no_line_break
;
3298 int allength
, length
, encoded_length
;
3300 Lisp_Object encoded_string
;
3303 CHECK_STRING (string
);
3305 /* We need to allocate enough room for encoding the text.
3306 We need 33 1/3% more space, plus a newline every 76
3307 characters, and then we round up. */
3308 length
= SBYTES (string
);
3309 allength
= length
+ length
/3 + 1;
3310 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3312 /* We need to allocate enough room for decoding the text. */
3313 SAFE_ALLOCA (encoded
, char *, allength
);
3315 encoded_length
= base64_encode_1 (SDATA (string
),
3316 encoded
, length
, NILP (no_line_break
),
3317 STRING_MULTIBYTE (string
));
3318 if (encoded_length
> allength
)
3321 if (encoded_length
< 0)
3323 /* The encoding wasn't possible. */
3325 error ("Multibyte character in data for base64 encoding");
3328 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3331 return encoded_string
;
3335 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3342 int counter
= 0, i
= 0;
3352 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3353 if (CHAR_BYTE8_P (c
))
3354 c
= CHAR_TO_BYTE8 (c
);
3362 /* Wrap line every 76 characters. */
3366 if (counter
< MIME_LINE_LENGTH
/ 4)
3375 /* Process first byte of a triplet. */
3377 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3378 value
= (0x03 & c
) << 4;
3380 /* Process second byte of a triplet. */
3384 *e
++ = base64_value_to_char
[value
];
3392 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3393 if (CHAR_BYTE8_P (c
))
3394 c
= CHAR_TO_BYTE8 (c
);
3402 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3403 value
= (0x0f & c
) << 2;
3405 /* Process third byte of a triplet. */
3409 *e
++ = base64_value_to_char
[value
];
3416 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3417 if (CHAR_BYTE8_P (c
))
3418 c
= CHAR_TO_BYTE8 (c
);
3426 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3427 *e
++ = base64_value_to_char
[0x3f & c
];
3434 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3436 doc
: /* Base64-decode the region between BEG and END.
3437 Return the length of the decoded text.
3438 If the region can't be decoded, signal an error and don't modify the buffer. */)
3440 Lisp_Object beg
, end
;
3442 int ibeg
, iend
, length
, allength
;
3447 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3450 validate_region (&beg
, &end
);
3452 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3453 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3455 length
= iend
- ibeg
;
3457 /* We need to allocate enough room for decoding the text. If we are
3458 working on a multibyte buffer, each decoded code may occupy at
3460 allength
= multibyte
? length
* 2 : length
;
3461 SAFE_ALLOCA (decoded
, char *, allength
);
3463 move_gap_both (XFASTINT (beg
), ibeg
);
3464 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3465 multibyte
, &inserted_chars
);
3466 if (decoded_length
> allength
)
3469 if (decoded_length
< 0)
3471 /* The decoding wasn't possible. */
3473 error ("Invalid base64 data");
3476 /* Now we have decoded the region, so we insert the new contents
3477 and delete the old. (Insert first in order to preserve markers.) */
3478 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3479 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3482 /* Delete the original text. */
3483 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3484 iend
+ decoded_length
, 1);
3486 /* If point was outside of the region, restore it exactly; else just
3487 move to the beginning of the region. */
3488 if (old_pos
>= XFASTINT (end
))
3489 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3490 else if (old_pos
> XFASTINT (beg
))
3491 old_pos
= XFASTINT (beg
);
3492 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3494 return make_number (inserted_chars
);
3497 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3499 doc
: /* Base64-decode STRING and return the result. */)
3504 int length
, decoded_length
;
3505 Lisp_Object decoded_string
;
3508 CHECK_STRING (string
);
3510 length
= SBYTES (string
);
3511 /* We need to allocate enough room for decoding the text. */
3512 SAFE_ALLOCA (decoded
, char *, length
);
3514 /* The decoded result should be unibyte. */
3515 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3517 if (decoded_length
> length
)
3519 else if (decoded_length
>= 0)
3520 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3522 decoded_string
= Qnil
;
3525 if (!STRINGP (decoded_string
))
3526 error ("Invalid base64 data");
3528 return decoded_string
;
3531 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3532 MULTIBYTE is nonzero, the decoded result should be in multibyte
3533 form. If NCHARS_RETRUN is not NULL, store the number of produced
3534 characters in *NCHARS_RETURN. */
3537 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3547 unsigned long value
;
3552 /* Process first byte of a quadruplet. */
3554 READ_QUADRUPLET_BYTE (e
-to
);
3558 value
= base64_char_to_value
[c
] << 18;
3560 /* Process second byte of a quadruplet. */
3562 READ_QUADRUPLET_BYTE (-1);
3566 value
|= base64_char_to_value
[c
] << 12;
3568 c
= (unsigned char) (value
>> 16);
3569 if (multibyte
&& c
>= 128)
3570 e
+= BYTE8_STRING (c
, e
);
3575 /* Process third byte of a quadruplet. */
3577 READ_QUADRUPLET_BYTE (-1);
3581 READ_QUADRUPLET_BYTE (-1);
3590 value
|= base64_char_to_value
[c
] << 6;
3592 c
= (unsigned char) (0xff & value
>> 8);
3593 if (multibyte
&& c
>= 128)
3594 e
+= BYTE8_STRING (c
, e
);
3599 /* Process fourth byte of a quadruplet. */
3601 READ_QUADRUPLET_BYTE (-1);
3608 value
|= base64_char_to_value
[c
];
3610 c
= (unsigned char) (0xff & value
);
3611 if (multibyte
&& c
>= 128)
3612 e
+= BYTE8_STRING (c
, e
);
3621 /***********************************************************************
3623 ***** Hash Tables *****
3625 ***********************************************************************/
3627 /* Implemented by gerd@gnu.org. This hash table implementation was
3628 inspired by CMUCL hash tables. */
3632 1. For small tables, association lists are probably faster than
3633 hash tables because they have lower overhead.
3635 For uses of hash tables where the O(1) behavior of table
3636 operations is not a requirement, it might therefore be a good idea
3637 not to hash. Instead, we could just do a linear search in the
3638 key_and_value vector of the hash table. This could be done
3639 if a `:linear-search t' argument is given to make-hash-table. */
3642 /* The list of all weak hash tables. Don't staticpro this one. */
3644 Lisp_Object Vweak_hash_tables
;
3646 /* Various symbols. */
3648 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3649 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3650 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3652 /* Function prototypes. */
3654 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3655 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3656 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3657 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3658 Lisp_Object
, unsigned));
3659 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3660 Lisp_Object
, unsigned));
3661 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3662 unsigned, Lisp_Object
, unsigned));
3663 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3664 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3665 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3666 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3668 static unsigned sxhash_string
P_ ((unsigned char *, int));
3669 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3670 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3671 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3672 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3676 /***********************************************************************
3678 ***********************************************************************/
3680 /* If OBJ is a Lisp hash table, return a pointer to its struct
3681 Lisp_Hash_Table. Otherwise, signal an error. */
3683 static struct Lisp_Hash_Table
*
3684 check_hash_table (obj
)
3687 CHECK_HASH_TABLE (obj
);
3688 return XHASH_TABLE (obj
);
3692 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3696 next_almost_prime (n
)
3709 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3710 which USED[I] is non-zero. If found at index I in ARGS, set
3711 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3712 -1. This function is used to extract a keyword/argument pair from
3713 a DEFUN parameter list. */
3716 get_key_arg (key
, nargs
, args
, used
)
3724 for (i
= 0; i
< nargs
- 1; ++i
)
3725 if (!used
[i
] && EQ (args
[i
], key
))
3740 /* Return a Lisp vector which has the same contents as VEC but has
3741 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3742 vector that are not copied from VEC are set to INIT. */
3745 larger_vector (vec
, new_size
, init
)
3750 struct Lisp_Vector
*v
;
3753 xassert (VECTORP (vec
));
3754 old_size
= ASIZE (vec
);
3755 xassert (new_size
>= old_size
);
3757 v
= allocate_vector (new_size
);
3758 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3759 old_size
* sizeof *v
->contents
);
3760 for (i
= old_size
; i
< new_size
; ++i
)
3761 v
->contents
[i
] = init
;
3762 XSETVECTOR (vec
, v
);
3767 /***********************************************************************
3769 ***********************************************************************/
3771 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3772 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3773 KEY2 are the same. */
3776 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3777 struct Lisp_Hash_Table
*h
;
3778 Lisp_Object key1
, key2
;
3779 unsigned hash1
, hash2
;
3781 return (FLOATP (key1
)
3783 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3787 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3788 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3789 KEY2 are the same. */
3792 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3793 struct Lisp_Hash_Table
*h
;
3794 Lisp_Object key1
, key2
;
3795 unsigned hash1
, hash2
;
3797 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3801 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3802 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3803 if KEY1 and KEY2 are the same. */
3806 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3807 struct Lisp_Hash_Table
*h
;
3808 Lisp_Object key1
, key2
;
3809 unsigned hash1
, hash2
;
3813 Lisp_Object args
[3];
3815 args
[0] = h
->user_cmp_function
;
3818 return !NILP (Ffuncall (3, args
));
3825 /* Value is a hash code for KEY for use in hash table H which uses
3826 `eq' to compare keys. The hash code returned is guaranteed to fit
3827 in a Lisp integer. */
3831 struct Lisp_Hash_Table
*h
;
3834 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3835 xassert ((hash
& ~INTMASK
) == 0);
3840 /* Value is a hash code for KEY for use in hash table H which uses
3841 `eql' to compare keys. The hash code returned is guaranteed to fit
3842 in a Lisp integer. */
3846 struct Lisp_Hash_Table
*h
;
3851 hash
= sxhash (key
, 0);
3853 hash
= XUINT (key
) ^ XTYPE (key
);
3854 xassert ((hash
& ~INTMASK
) == 0);
3859 /* Value is a hash code for KEY for use in hash table H which uses
3860 `equal' to compare keys. The hash code returned is guaranteed to fit
3861 in a Lisp integer. */
3864 hashfn_equal (h
, key
)
3865 struct Lisp_Hash_Table
*h
;
3868 unsigned hash
= sxhash (key
, 0);
3869 xassert ((hash
& ~INTMASK
) == 0);
3874 /* Value is a hash code for KEY for use in hash table H which uses as
3875 user-defined function to compare keys. The hash code returned is
3876 guaranteed to fit in a Lisp integer. */
3879 hashfn_user_defined (h
, key
)
3880 struct Lisp_Hash_Table
*h
;
3883 Lisp_Object args
[2], hash
;
3885 args
[0] = h
->user_hash_function
;
3887 hash
= Ffuncall (2, args
);
3888 if (!INTEGERP (hash
))
3889 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3890 return XUINT (hash
);
3894 /* Create and initialize a new hash table.
3896 TEST specifies the test the hash table will use to compare keys.
3897 It must be either one of the predefined tests `eq', `eql' or
3898 `equal' or a symbol denoting a user-defined test named TEST with
3899 test and hash functions USER_TEST and USER_HASH.
3901 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3903 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3904 new size when it becomes full is computed by adding REHASH_SIZE to
3905 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3906 table's new size is computed by multiplying its old size with
3909 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3910 be resized when the ratio of (number of entries in the table) /
3911 (table size) is >= REHASH_THRESHOLD.
3913 WEAK specifies the weakness of the table. If non-nil, it must be
3914 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3917 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3918 user_test
, user_hash
)
3919 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3920 Lisp_Object user_test
, user_hash
;
3922 struct Lisp_Hash_Table
*h
;
3924 int index_size
, i
, sz
;
3926 /* Preconditions. */
3927 xassert (SYMBOLP (test
));
3928 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3929 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3930 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3931 xassert (FLOATP (rehash_threshold
)
3932 && XFLOATINT (rehash_threshold
) > 0
3933 && XFLOATINT (rehash_threshold
) <= 1.0);
3935 if (XFASTINT (size
) == 0)
3936 size
= make_number (1);
3938 /* Allocate a table and initialize it. */
3939 h
= allocate_hash_table ();
3941 /* Initialize hash table slots. */
3942 sz
= XFASTINT (size
);
3945 if (EQ (test
, Qeql
))
3947 h
->cmpfn
= cmpfn_eql
;
3948 h
->hashfn
= hashfn_eql
;
3950 else if (EQ (test
, Qeq
))
3953 h
->hashfn
= hashfn_eq
;
3955 else if (EQ (test
, Qequal
))
3957 h
->cmpfn
= cmpfn_equal
;
3958 h
->hashfn
= hashfn_equal
;
3962 h
->user_cmp_function
= user_test
;
3963 h
->user_hash_function
= user_hash
;
3964 h
->cmpfn
= cmpfn_user_defined
;
3965 h
->hashfn
= hashfn_user_defined
;
3969 h
->rehash_threshold
= rehash_threshold
;
3970 h
->rehash_size
= rehash_size
;
3971 h
->count
= make_number (0);
3972 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3973 h
->hash
= Fmake_vector (size
, Qnil
);
3974 h
->next
= Fmake_vector (size
, Qnil
);
3975 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3976 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3977 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3979 /* Set up the free list. */
3980 for (i
= 0; i
< sz
- 1; ++i
)
3981 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3982 h
->next_free
= make_number (0);
3984 XSET_HASH_TABLE (table
, h
);
3985 xassert (HASH_TABLE_P (table
));
3986 xassert (XHASH_TABLE (table
) == h
);
3988 /* Maybe add this hash table to the list of all weak hash tables. */
3990 h
->next_weak
= Qnil
;
3993 h
->next_weak
= Vweak_hash_tables
;
3994 Vweak_hash_tables
= table
;
4001 /* Return a copy of hash table H1. Keys and values are not copied,
4002 only the table itself is. */
4005 copy_hash_table (h1
)
4006 struct Lisp_Hash_Table
*h1
;
4009 struct Lisp_Hash_Table
*h2
;
4010 struct Lisp_Vector
*next
;
4012 h2
= allocate_hash_table ();
4013 next
= h2
->vec_next
;
4014 bcopy (h1
, h2
, sizeof *h2
);
4015 h2
->vec_next
= next
;
4016 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4017 h2
->hash
= Fcopy_sequence (h1
->hash
);
4018 h2
->next
= Fcopy_sequence (h1
->next
);
4019 h2
->index
= Fcopy_sequence (h1
->index
);
4020 XSET_HASH_TABLE (table
, h2
);
4022 /* Maybe add this hash table to the list of all weak hash tables. */
4023 if (!NILP (h2
->weak
))
4025 h2
->next_weak
= Vweak_hash_tables
;
4026 Vweak_hash_tables
= table
;
4033 /* Resize hash table H if it's too full. If H cannot be resized
4034 because it's already too large, throw an error. */
4037 maybe_resize_hash_table (h
)
4038 struct Lisp_Hash_Table
*h
;
4040 if (NILP (h
->next_free
))
4042 int old_size
= HASH_TABLE_SIZE (h
);
4043 int i
, new_size
, index_size
;
4046 if (INTEGERP (h
->rehash_size
))
4047 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4049 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4050 new_size
= max (old_size
+ 1, new_size
);
4051 index_size
= next_almost_prime ((int)
4053 / XFLOATINT (h
->rehash_threshold
)));
4054 /* Assignment to EMACS_INT stops GCC whining about limited range
4056 nsize
= max (index_size
, 2 * new_size
);
4057 if (nsize
> MOST_POSITIVE_FIXNUM
)
4058 error ("Hash table too large to resize");
4060 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4061 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4062 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4063 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4065 /* Update the free list. Do it so that new entries are added at
4066 the end of the free list. This makes some operations like
4068 for (i
= old_size
; i
< new_size
- 1; ++i
)
4069 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4071 if (!NILP (h
->next_free
))
4073 Lisp_Object last
, next
;
4075 last
= h
->next_free
;
4076 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4080 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4083 XSETFASTINT (h
->next_free
, old_size
);
4086 for (i
= 0; i
< old_size
; ++i
)
4087 if (!NILP (HASH_HASH (h
, i
)))
4089 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4090 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
4091 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4092 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4098 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4099 the hash code of KEY. Value is the index of the entry in H
4100 matching KEY, or -1 if not found. */
4103 hash_lookup (h
, key
, hash
)
4104 struct Lisp_Hash_Table
*h
;
4109 int start_of_bucket
;
4112 hash_code
= h
->hashfn (h
, key
);
4116 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4117 idx
= HASH_INDEX (h
, start_of_bucket
);
4119 /* We need not gcpro idx since it's either an integer or nil. */
4122 int i
= XFASTINT (idx
);
4123 if (EQ (key
, HASH_KEY (h
, i
))
4125 && h
->cmpfn (h
, key
, hash_code
,
4126 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4128 idx
= HASH_NEXT (h
, i
);
4131 return NILP (idx
) ? -1 : XFASTINT (idx
);
4135 /* Put an entry into hash table H that associates KEY with VALUE.
4136 HASH is a previously computed hash code of KEY.
4137 Value is the index of the entry in H matching KEY. */
4140 hash_put (h
, key
, value
, hash
)
4141 struct Lisp_Hash_Table
*h
;
4142 Lisp_Object key
, value
;
4145 int start_of_bucket
, i
;
4147 xassert ((hash
& ~INTMASK
) == 0);
4149 /* Increment count after resizing because resizing may fail. */
4150 maybe_resize_hash_table (h
);
4151 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4153 /* Store key/value in the key_and_value vector. */
4154 i
= XFASTINT (h
->next_free
);
4155 h
->next_free
= HASH_NEXT (h
, i
);
4156 HASH_KEY (h
, i
) = key
;
4157 HASH_VALUE (h
, i
) = value
;
4159 /* Remember its hash code. */
4160 HASH_HASH (h
, i
) = make_number (hash
);
4162 /* Add new entry to its collision chain. */
4163 start_of_bucket
= hash
% ASIZE (h
->index
);
4164 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4165 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4170 /* Remove the entry matching KEY from hash table H, if there is one. */
4173 hash_remove (h
, key
)
4174 struct Lisp_Hash_Table
*h
;
4178 int start_of_bucket
;
4179 Lisp_Object idx
, prev
;
4181 hash_code
= h
->hashfn (h
, key
);
4182 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4183 idx
= HASH_INDEX (h
, start_of_bucket
);
4186 /* We need not gcpro idx, prev since they're either integers or nil. */
4189 int i
= XFASTINT (idx
);
4191 if (EQ (key
, HASH_KEY (h
, i
))
4193 && h
->cmpfn (h
, key
, hash_code
,
4194 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4196 /* Take entry out of collision chain. */
4198 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4200 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4202 /* Clear slots in key_and_value and add the slots to
4204 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4205 HASH_NEXT (h
, i
) = h
->next_free
;
4206 h
->next_free
= make_number (i
);
4207 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4208 xassert (XINT (h
->count
) >= 0);
4214 idx
= HASH_NEXT (h
, i
);
4220 /* Clear hash table H. */
4224 struct Lisp_Hash_Table
*h
;
4226 if (XFASTINT (h
->count
) > 0)
4228 int i
, size
= HASH_TABLE_SIZE (h
);
4230 for (i
= 0; i
< size
; ++i
)
4232 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4233 HASH_KEY (h
, i
) = Qnil
;
4234 HASH_VALUE (h
, i
) = Qnil
;
4235 HASH_HASH (h
, i
) = Qnil
;
4238 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4239 AREF (h
->index
, i
) = Qnil
;
4241 h
->next_free
= make_number (0);
4242 h
->count
= make_number (0);
4248 /************************************************************************
4250 ************************************************************************/
4252 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4253 entries from the table that don't survive the current GC.
4254 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4255 non-zero if anything was marked. */
4258 sweep_weak_table (h
, remove_entries_p
)
4259 struct Lisp_Hash_Table
*h
;
4260 int remove_entries_p
;
4262 int bucket
, n
, marked
;
4264 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
4267 for (bucket
= 0; bucket
< n
; ++bucket
)
4269 Lisp_Object idx
, next
, prev
;
4271 /* Follow collision chain, removing entries that
4272 don't survive this garbage collection. */
4274 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4276 int i
= XFASTINT (idx
);
4277 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4278 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4281 if (EQ (h
->weak
, Qkey
))
4282 remove_p
= !key_known_to_survive_p
;
4283 else if (EQ (h
->weak
, Qvalue
))
4284 remove_p
= !value_known_to_survive_p
;
4285 else if (EQ (h
->weak
, Qkey_or_value
))
4286 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4287 else if (EQ (h
->weak
, Qkey_and_value
))
4288 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4292 next
= HASH_NEXT (h
, i
);
4294 if (remove_entries_p
)
4298 /* Take out of collision chain. */
4300 HASH_INDEX (h
, bucket
) = next
;
4302 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4304 /* Add to free list. */
4305 HASH_NEXT (h
, i
) = h
->next_free
;
4308 /* Clear key, value, and hash. */
4309 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4310 HASH_HASH (h
, i
) = Qnil
;
4312 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4323 /* Make sure key and value survive. */
4324 if (!key_known_to_survive_p
)
4326 mark_object (HASH_KEY (h
, i
));
4330 if (!value_known_to_survive_p
)
4332 mark_object (HASH_VALUE (h
, i
));
4343 /* Remove elements from weak hash tables that don't survive the
4344 current garbage collection. Remove weak tables that don't survive
4345 from Vweak_hash_tables. Called from gc_sweep. */
4348 sweep_weak_hash_tables ()
4350 Lisp_Object table
, used
, next
;
4351 struct Lisp_Hash_Table
*h
;
4354 /* Mark all keys and values that are in use. Keep on marking until
4355 there is no more change. This is necessary for cases like
4356 value-weak table A containing an entry X -> Y, where Y is used in a
4357 key-weak table B, Z -> Y. If B comes after A in the list of weak
4358 tables, X -> Y might be removed from A, although when looking at B
4359 one finds that it shouldn't. */
4363 for (table
= Vweak_hash_tables
; !NILP (table
); table
= h
->next_weak
)
4365 h
= XHASH_TABLE (table
);
4366 if (h
->size
& ARRAY_MARK_FLAG
)
4367 marked
|= sweep_weak_table (h
, 0);
4372 /* Remove tables and entries that aren't used. */
4373 for (table
= Vweak_hash_tables
, used
= Qnil
; !NILP (table
); table
= next
)
4375 h
= XHASH_TABLE (table
);
4376 next
= h
->next_weak
;
4378 if (h
->size
& ARRAY_MARK_FLAG
)
4380 /* TABLE is marked as used. Sweep its contents. */
4381 if (XFASTINT (h
->count
) > 0)
4382 sweep_weak_table (h
, 1);
4384 /* Add table to the list of used weak hash tables. */
4385 h
->next_weak
= used
;
4390 Vweak_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 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. */)
4786 hash_clear (check_hash_table (table
));
4791 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4792 doc
: /* Look up KEY in TABLE and return its associated value.
4793 If KEY is not found, return DFLT which defaults to nil. */)
4795 Lisp_Object key
, table
, dflt
;
4797 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4798 int i
= hash_lookup (h
, key
, NULL
);
4799 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4803 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4804 doc
: /* Associate KEY with VALUE in hash table TABLE.
4805 If KEY is already present in table, replace its current value with
4808 Lisp_Object key
, value
, table
;
4810 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4814 i
= hash_lookup (h
, key
, &hash
);
4816 HASH_VALUE (h
, i
) = value
;
4818 hash_put (h
, key
, value
, hash
);
4824 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4825 doc
: /* Remove KEY from TABLE. */)
4827 Lisp_Object key
, table
;
4829 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4830 hash_remove (h
, key
);
4835 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4836 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4837 FUNCTION is called with two arguments, KEY and VALUE. */)
4839 Lisp_Object function
, table
;
4841 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4842 Lisp_Object args
[3];
4845 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4846 if (!NILP (HASH_HASH (h
, i
)))
4849 args
[1] = HASH_KEY (h
, i
);
4850 args
[2] = HASH_VALUE (h
, i
);
4858 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4859 Sdefine_hash_table_test
, 3, 3, 0,
4860 doc
: /* Define a new hash table test with name NAME, a symbol.
4862 In hash tables created with NAME specified as test, use TEST to
4863 compare keys, and HASH for computing hash codes of keys.
4865 TEST must be a function taking two arguments and returning non-nil if
4866 both arguments are the same. HASH must be a function taking one
4867 argument and return an integer that is the hash code of the argument.
4868 Hash code computation should use the whole value range of integers,
4869 including negative integers. */)
4871 Lisp_Object name
, test
, hash
;
4873 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4878 /************************************************************************
4880 ************************************************************************/
4884 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4885 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4887 A message digest is a cryptographic checksum of a document, and the
4888 algorithm to calculate it is defined in RFC 1321.
4890 The two optional arguments START and END are character positions
4891 specifying for which part of OBJECT the message digest should be
4892 computed. If nil or omitted, the digest is computed for the whole
4895 The MD5 message digest is computed from the result of encoding the
4896 text in a coding system, not directly from the internal Emacs form of
4897 the text. The optional fourth argument CODING-SYSTEM specifies which
4898 coding system to encode the text with. It should be the same coding
4899 system that you used or will use when actually writing the text into a
4902 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4903 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4904 system would be chosen by default for writing this text into a file.
4906 If OBJECT is a string, the most preferred coding system (see the
4907 command `prefer-coding-system') is used.
4909 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4910 guesswork fails. Normally, an error is signaled in such case. */)
4911 (object
, start
, end
, coding_system
, noerror
)
4912 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4914 unsigned char digest
[16];
4915 unsigned char value
[33];
4919 int start_char
= 0, end_char
= 0;
4920 int start_byte
= 0, end_byte
= 0;
4922 register struct buffer
*bp
;
4925 if (STRINGP (object
))
4927 if (NILP (coding_system
))
4929 /* Decide the coding-system to encode the data with. */
4931 if (STRING_MULTIBYTE (object
))
4932 /* use default, we can't guess correct value */
4933 coding_system
= preferred_coding_system ();
4935 coding_system
= Qraw_text
;
4938 if (NILP (Fcoding_system_p (coding_system
)))
4940 /* Invalid coding system. */
4942 if (!NILP (noerror
))
4943 coding_system
= Qraw_text
;
4945 xsignal1 (Qcoding_system_error
, coding_system
);
4948 if (STRING_MULTIBYTE (object
))
4949 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4951 size
= SCHARS (object
);
4952 size_byte
= SBYTES (object
);
4956 CHECK_NUMBER (start
);
4958 start_char
= XINT (start
);
4963 start_byte
= string_char_to_byte (object
, start_char
);
4969 end_byte
= size_byte
;
4975 end_char
= XINT (end
);
4980 end_byte
= string_char_to_byte (object
, end_char
);
4983 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4984 args_out_of_range_3 (object
, make_number (start_char
),
4985 make_number (end_char
));
4989 struct buffer
*prev
= current_buffer
;
4991 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4993 CHECK_BUFFER (object
);
4995 bp
= XBUFFER (object
);
4996 if (bp
!= current_buffer
)
4997 set_buffer_internal (bp
);
5003 CHECK_NUMBER_COERCE_MARKER (start
);
5011 CHECK_NUMBER_COERCE_MARKER (end
);
5016 temp
= b
, b
= e
, e
= temp
;
5018 if (!(BEGV
<= b
&& e
<= ZV
))
5019 args_out_of_range (start
, end
);
5021 if (NILP (coding_system
))
5023 /* Decide the coding-system to encode the data with.
5024 See fileio.c:Fwrite-region */
5026 if (!NILP (Vcoding_system_for_write
))
5027 coding_system
= Vcoding_system_for_write
;
5030 int force_raw_text
= 0;
5032 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5033 if (NILP (coding_system
)
5034 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5036 coding_system
= Qnil
;
5037 if (NILP (current_buffer
->enable_multibyte_characters
))
5041 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5043 /* Check file-coding-system-alist. */
5044 Lisp_Object args
[4], val
;
5046 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5047 args
[3] = Fbuffer_file_name(object
);
5048 val
= Ffind_operation_coding_system (4, args
);
5049 if (CONSP (val
) && !NILP (XCDR (val
)))
5050 coding_system
= XCDR (val
);
5053 if (NILP (coding_system
)
5054 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5056 /* If we still have not decided a coding system, use the
5057 default value of buffer-file-coding-system. */
5058 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5062 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5063 /* Confirm that VAL can surely encode the current region. */
5064 coding_system
= call4 (Vselect_safe_coding_system_function
,
5065 make_number (b
), make_number (e
),
5066 coding_system
, Qnil
);
5069 coding_system
= Qraw_text
;
5072 if (NILP (Fcoding_system_p (coding_system
)))
5074 /* Invalid coding system. */
5076 if (!NILP (noerror
))
5077 coding_system
= Qraw_text
;
5079 xsignal1 (Qcoding_system_error
, coding_system
);
5083 object
= make_buffer_string (b
, e
, 0);
5084 if (prev
!= current_buffer
)
5085 set_buffer_internal (prev
);
5086 /* Discard the unwind protect for recovering the current
5090 if (STRING_MULTIBYTE (object
))
5091 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5094 md5_buffer (SDATA (object
) + start_byte
,
5095 SBYTES (object
) - (size_byte
- end_byte
),
5098 for (i
= 0; i
< 16; i
++)
5099 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5102 return make_string (value
, 32);
5109 /* Hash table stuff. */
5110 Qhash_table_p
= intern ("hash-table-p");
5111 staticpro (&Qhash_table_p
);
5112 Qeq
= intern ("eq");
5114 Qeql
= intern ("eql");
5116 Qequal
= intern ("equal");
5117 staticpro (&Qequal
);
5118 QCtest
= intern (":test");
5119 staticpro (&QCtest
);
5120 QCsize
= intern (":size");
5121 staticpro (&QCsize
);
5122 QCrehash_size
= intern (":rehash-size");
5123 staticpro (&QCrehash_size
);
5124 QCrehash_threshold
= intern (":rehash-threshold");
5125 staticpro (&QCrehash_threshold
);
5126 QCweakness
= intern (":weakness");
5127 staticpro (&QCweakness
);
5128 Qkey
= intern ("key");
5130 Qvalue
= intern ("value");
5131 staticpro (&Qvalue
);
5132 Qhash_table_test
= intern ("hash-table-test");
5133 staticpro (&Qhash_table_test
);
5134 Qkey_or_value
= intern ("key-or-value");
5135 staticpro (&Qkey_or_value
);
5136 Qkey_and_value
= intern ("key-and-value");
5137 staticpro (&Qkey_and_value
);
5140 defsubr (&Smake_hash_table
);
5141 defsubr (&Scopy_hash_table
);
5142 defsubr (&Shash_table_count
);
5143 defsubr (&Shash_table_rehash_size
);
5144 defsubr (&Shash_table_rehash_threshold
);
5145 defsubr (&Shash_table_size
);
5146 defsubr (&Shash_table_test
);
5147 defsubr (&Shash_table_weakness
);
5148 defsubr (&Shash_table_p
);
5149 defsubr (&Sclrhash
);
5150 defsubr (&Sgethash
);
5151 defsubr (&Sputhash
);
5152 defsubr (&Sremhash
);
5153 defsubr (&Smaphash
);
5154 defsubr (&Sdefine_hash_table_test
);
5156 Qstring_lessp
= intern ("string-lessp");
5157 staticpro (&Qstring_lessp
);
5158 Qprovide
= intern ("provide");
5159 staticpro (&Qprovide
);
5160 Qrequire
= intern ("require");
5161 staticpro (&Qrequire
);
5162 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5163 staticpro (&Qyes_or_no_p_history
);
5164 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5165 staticpro (&Qcursor_in_echo_area
);
5166 Qwidget_type
= intern ("widget-type");
5167 staticpro (&Qwidget_type
);
5169 staticpro (&string_char_byte_cache_string
);
5170 string_char_byte_cache_string
= Qnil
;
5172 require_nesting_list
= Qnil
;
5173 staticpro (&require_nesting_list
);
5175 Fset (Qyes_or_no_p_history
, Qnil
);
5177 DEFVAR_LISP ("features", &Vfeatures
,
5178 doc
: /* A list of symbols which are the features of the executing Emacs.
5179 Used by `featurep' and `require', and altered by `provide'. */);
5180 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5181 Qsubfeatures
= intern ("subfeatures");
5182 staticpro (&Qsubfeatures
);
5184 #ifdef HAVE_LANGINFO_CODESET
5185 Qcodeset
= intern ("codeset");
5186 staticpro (&Qcodeset
);
5187 Qdays
= intern ("days");
5189 Qmonths
= intern ("months");
5190 staticpro (&Qmonths
);
5191 Qpaper
= intern ("paper");
5192 staticpro (&Qpaper
);
5193 #endif /* HAVE_LANGINFO_CODESET */
5195 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5196 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5197 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5198 invoked by mouse clicks and mouse menu items. */);
5201 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5202 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5203 This applies to commands from menus and tool bar buttons. The value of
5204 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5205 used if both `use-dialog-box' and this variable are non-nil. */);
5206 use_file_dialog
= 1;
5208 defsubr (&Sidentity
);
5211 defsubr (&Ssafe_length
);
5212 defsubr (&Sstring_bytes
);
5213 defsubr (&Sstring_equal
);
5214 defsubr (&Scompare_strings
);
5215 defsubr (&Sstring_lessp
);
5218 defsubr (&Svconcat
);
5219 defsubr (&Scopy_sequence
);
5220 defsubr (&Sstring_make_multibyte
);
5221 defsubr (&Sstring_make_unibyte
);
5222 defsubr (&Sstring_as_multibyte
);
5223 defsubr (&Sstring_as_unibyte
);
5224 defsubr (&Sstring_to_multibyte
);
5225 defsubr (&Scopy_alist
);
5226 defsubr (&Ssubstring
);
5227 defsubr (&Ssubstring_no_properties
);
5240 defsubr (&Snreverse
);
5241 defsubr (&Sreverse
);
5243 defsubr (&Splist_get
);
5245 defsubr (&Splist_put
);
5247 defsubr (&Slax_plist_get
);
5248 defsubr (&Slax_plist_put
);
5251 defsubr (&Sequal_including_properties
);
5252 defsubr (&Sfillarray
);
5253 defsubr (&Sclear_string
);
5257 defsubr (&Smapconcat
);
5258 defsubr (&Sy_or_n_p
);
5259 defsubr (&Syes_or_no_p
);
5260 defsubr (&Sload_average
);
5261 defsubr (&Sfeaturep
);
5262 defsubr (&Srequire
);
5263 defsubr (&Sprovide
);
5264 defsubr (&Splist_member
);
5265 defsubr (&Swidget_put
);
5266 defsubr (&Swidget_get
);
5267 defsubr (&Swidget_apply
);
5268 defsubr (&Sbase64_encode_region
);
5269 defsubr (&Sbase64_decode_region
);
5270 defsubr (&Sbase64_encode_string
);
5271 defsubr (&Sbase64_decode_string
);
5273 defsubr (&Slocale_info
);
5280 Vweak_hash_tables
= Qnil
;
5283 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5284 (do not change this comment) */