1 /* Random utility Lisp functions.
2 Copyright (C) 1985-1987, 1993-1995, 1997-2011
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
26 /* Note on some machines this defines `vector' as a typedef,
27 so make sure we don't use that name in this file. */
33 #include "character.h"
38 #include "intervals.h"
41 #include "blockinput.h"
43 #if defined (HAVE_X_WINDOWS)
46 #endif /* HAVE_MENUS */
49 #define NULL ((POINTER_TYPE *)0)
52 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
53 Lisp_Object Qyes_or_no_p_history
;
54 Lisp_Object Qcursor_in_echo_area
;
55 Lisp_Object Qwidget_type
;
56 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
58 static int internal_equal (Lisp_Object
, Lisp_Object
, int, int);
64 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
65 doc
: /* Return the argument unchanged. */)
71 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
72 doc
: /* Return a pseudo-random number.
73 All integers representable in Lisp are equally likely.
74 On most systems, this is 29 bits' worth.
75 With positive integer LIMIT, return random number in interval [0,LIMIT).
76 With argument t, set the random number seed from the current time and pid.
77 Other values of LIMIT are ignored. */)
81 Lisp_Object lispy_val
;
82 unsigned long denominator
;
85 seed_random (getpid () + time (NULL
));
86 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
88 /* Try to take our random number from the higher bits of VAL,
89 not the lower, since (says Gentzel) the low bits of `random'
90 are less random than the higher ones. We do this by using the
91 quotient rather than the remainder. At the high end of the RNG
92 it's possible to get a quotient larger than n; discarding
93 these values eliminates the bias that would otherwise appear
94 when using a large n. */
95 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
97 val
= get_random () / denominator
;
98 while (val
>= XFASTINT (limit
));
102 XSETINT (lispy_val
, val
);
106 /* Random data-structure functions */
108 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
109 doc
: /* Return the length of vector, list or string SEQUENCE.
110 A byte-code function object is also allowed.
111 If the string contains multibyte characters, this is not necessarily
112 the number of bytes in the string; it is the number of characters.
113 To get the number of bytes, use `string-bytes'. */)
114 (register Lisp_Object sequence
)
116 register Lisp_Object val
;
119 if (STRINGP (sequence
))
120 XSETFASTINT (val
, SCHARS (sequence
));
121 else if (VECTORP (sequence
))
122 XSETFASTINT (val
, ASIZE (sequence
));
123 else if (CHAR_TABLE_P (sequence
))
124 XSETFASTINT (val
, MAX_CHAR
);
125 else if (BOOL_VECTOR_P (sequence
))
126 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
127 else if (COMPILEDP (sequence
))
128 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
129 else if (CONSP (sequence
))
132 while (CONSP (sequence
))
134 sequence
= XCDR (sequence
);
137 if (!CONSP (sequence
))
140 sequence
= XCDR (sequence
);
145 CHECK_LIST_END (sequence
, sequence
);
147 val
= make_number (i
);
149 else if (NILP (sequence
))
150 XSETFASTINT (val
, 0);
152 wrong_type_argument (Qsequencep
, sequence
);
157 /* This does not check for quits. That is safe since it must terminate. */
159 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
160 doc
: /* Return the length of a list, but avoid error or infinite loop.
161 This function never gets an error. If LIST is not really a list,
162 it returns 0. If LIST is circular, it returns a finite value
163 which is at least the number of distinct elements. */)
166 Lisp_Object tail
, halftail
, length
;
169 /* halftail is used to detect circular lists. */
171 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
173 if (EQ (tail
, halftail
) && len
!= 0)
177 halftail
= XCDR (halftail
);
180 XSETINT (length
, len
);
184 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
185 doc
: /* Return the number of bytes in STRING.
186 If STRING is multibyte, this may be greater than the length of STRING. */)
189 CHECK_STRING (string
);
190 return make_number (SBYTES (string
));
193 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
194 doc
: /* Return t if two strings have identical contents.
195 Case is significant, but text properties are ignored.
196 Symbols are also allowed; their print names are used instead. */)
197 (register Lisp_Object s1
, Lisp_Object s2
)
200 s1
= SYMBOL_NAME (s1
);
202 s2
= SYMBOL_NAME (s2
);
206 if (SCHARS (s1
) != SCHARS (s2
)
207 || SBYTES (s1
) != SBYTES (s2
)
208 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
213 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
214 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
215 In string STR1, skip the first START1 characters and stop at END1.
216 In string STR2, skip the first START2 characters and stop at END2.
217 END1 and END2 default to the full lengths of the respective strings.
219 Case is significant in this comparison if IGNORE-CASE is nil.
220 Unibyte strings are converted to multibyte for comparison.
222 The value is t if the strings (or specified portions) match.
223 If string STR1 is less, the value is a negative number N;
224 - 1 - N is the number of characters that match at the beginning.
225 If string STR1 is greater, the value is a positive number N;
226 N - 1 is the number of characters that match at the beginning. */)
227 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
, Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
229 register EMACS_INT end1_char
, end2_char
;
230 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
235 start1
= make_number (0);
237 start2
= make_number (0);
238 CHECK_NATNUM (start1
);
239 CHECK_NATNUM (start2
);
248 i1_byte
= string_char_to_byte (str1
, i1
);
249 i2_byte
= string_char_to_byte (str2
, i2
);
251 end1_char
= SCHARS (str1
);
252 if (! NILP (end1
) && end1_char
> XINT (end1
))
253 end1_char
= XINT (end1
);
255 end2_char
= SCHARS (str2
);
256 if (! NILP (end2
) && end2_char
> XINT (end2
))
257 end2_char
= XINT (end2
);
259 while (i1
< end1_char
&& i2
< end2_char
)
261 /* When we find a mismatch, we must compare the
262 characters, not just the bytes. */
265 if (STRING_MULTIBYTE (str1
))
266 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
269 c1
= SREF (str1
, i1
++);
270 MAKE_CHAR_MULTIBYTE (c1
);
273 if (STRING_MULTIBYTE (str2
))
274 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
277 c2
= SREF (str2
, i2
++);
278 MAKE_CHAR_MULTIBYTE (c2
);
284 if (! NILP (ignore_case
))
288 tem
= Fupcase (make_number (c1
));
290 tem
= Fupcase (make_number (c2
));
297 /* Note that I1 has already been incremented
298 past the character that we are comparing;
299 hence we don't add or subtract 1 here. */
301 return make_number (- i1
+ XINT (start1
));
303 return make_number (i1
- XINT (start1
));
307 return make_number (i1
- XINT (start1
) + 1);
309 return make_number (- i1
+ XINT (start1
) - 1);
314 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
315 doc
: /* Return t if first arg string is less than second in lexicographic order.
317 Symbols are also allowed; their print names are used instead. */)
318 (register Lisp_Object s1
, Lisp_Object s2
)
320 register EMACS_INT end
;
321 register EMACS_INT i1
, i1_byte
, i2
, i2_byte
;
324 s1
= SYMBOL_NAME (s1
);
326 s2
= SYMBOL_NAME (s2
);
330 i1
= i1_byte
= i2
= i2_byte
= 0;
333 if (end
> SCHARS (s2
))
338 /* When we find a mismatch, we must compare the
339 characters, not just the bytes. */
342 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
343 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
346 return c1
< c2
? Qt
: Qnil
;
348 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
351 static Lisp_Object
concat (int nargs
, Lisp_Object
*args
,
352 enum Lisp_Type target_type
, int last_special
);
356 concat2 (Lisp_Object s1
, Lisp_Object s2
)
361 return concat (2, args
, Lisp_String
, 0);
366 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
372 return concat (3, args
, Lisp_String
, 0);
375 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
376 doc
: /* Concatenate all the arguments and make the result a list.
377 The result is a list whose elements are the elements of all the arguments.
378 Each argument may be a list, vector or string.
379 The last argument is not copied, just used as the tail of the new list.
380 usage: (append &rest SEQUENCES) */)
381 (int nargs
, Lisp_Object
*args
)
383 return concat (nargs
, args
, Lisp_Cons
, 1);
386 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
387 doc
: /* Concatenate all the arguments and make the result a string.
388 The result is a string whose elements are the elements of all the arguments.
389 Each argument may be a string or a list or vector of characters (integers).
390 usage: (concat &rest SEQUENCES) */)
391 (int nargs
, Lisp_Object
*args
)
393 return concat (nargs
, args
, Lisp_String
, 0);
396 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
397 doc
: /* Concatenate all the arguments and make the result a vector.
398 The result is a vector whose elements are the elements of all the arguments.
399 Each argument may be a list, vector or string.
400 usage: (vconcat &rest SEQUENCES) */)
401 (int nargs
, Lisp_Object
*args
)
403 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
407 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
408 doc
: /* Return a copy of a list, vector, string or char-table.
409 The elements of a list or vector are not copied; they are shared
410 with the original. */)
413 if (NILP (arg
)) return arg
;
415 if (CHAR_TABLE_P (arg
))
417 return copy_char_table (arg
);
420 if (BOOL_VECTOR_P (arg
))
424 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
425 / BOOL_VECTOR_BITS_PER_CHAR
);
427 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
428 memcpy (XBOOL_VECTOR (val
)->data
, XBOOL_VECTOR (arg
)->data
,
433 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
434 wrong_type_argument (Qsequencep
, arg
);
436 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
439 /* This structure holds information of an argument of `concat' that is
440 a string and has text properties to be copied. */
443 int argnum
; /* refer to ARGS (arguments of `concat') */
444 EMACS_INT from
; /* refer to ARGS[argnum] (argument string) */
445 EMACS_INT to
; /* refer to VAL (the target string) */
449 concat (int nargs
, Lisp_Object
*args
, enum Lisp_Type target_type
, int last_special
)
452 register Lisp_Object tail
;
453 register Lisp_Object
this;
455 EMACS_INT toindex_byte
= 0;
456 register EMACS_INT result_len
;
457 register EMACS_INT result_len_byte
;
459 Lisp_Object last_tail
;
462 /* When we make a multibyte string, we can't copy text properties
463 while concatinating each string because the length of resulting
464 string can't be decided until we finish the whole concatination.
465 So, we record strings that have text properties to be copied
466 here, and copy the text properties after the concatination. */
467 struct textprop_rec
*textprops
= NULL
;
468 /* Number of elements in textprops. */
469 int num_textprops
= 0;
474 /* In append, the last arg isn't treated like the others */
475 if (last_special
&& nargs
> 0)
478 last_tail
= args
[nargs
];
483 /* Check each argument. */
484 for (argnum
= 0; argnum
< nargs
; argnum
++)
487 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
488 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
489 wrong_type_argument (Qsequencep
, this);
492 /* Compute total length in chars of arguments in RESULT_LEN.
493 If desired output is a string, also compute length in bytes
494 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
495 whether the result should be a multibyte string. */
499 for (argnum
= 0; argnum
< nargs
; argnum
++)
503 len
= XFASTINT (Flength (this));
504 if (target_type
== Lisp_String
)
506 /* We must count the number of bytes needed in the string
507 as well as the number of characters. */
510 EMACS_INT this_len_byte
;
513 for (i
= 0; i
< len
; i
++)
516 CHECK_CHARACTER (ch
);
517 this_len_byte
= CHAR_BYTES (XINT (ch
));
518 result_len_byte
+= this_len_byte
;
519 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
522 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
523 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
524 else if (CONSP (this))
525 for (; CONSP (this); this = XCDR (this))
528 CHECK_CHARACTER (ch
);
529 this_len_byte
= CHAR_BYTES (XINT (ch
));
530 result_len_byte
+= this_len_byte
;
531 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
534 else if (STRINGP (this))
536 if (STRING_MULTIBYTE (this))
539 result_len_byte
+= SBYTES (this);
542 result_len_byte
+= count_size_as_multibyte (SDATA (this),
549 error ("String overflow");
552 if (! some_multibyte
)
553 result_len_byte
= result_len
;
555 /* Create the output object. */
556 if (target_type
== Lisp_Cons
)
557 val
= Fmake_list (make_number (result_len
), Qnil
);
558 else if (target_type
== Lisp_Vectorlike
)
559 val
= Fmake_vector (make_number (result_len
), Qnil
);
560 else if (some_multibyte
)
561 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
563 val
= make_uninit_string (result_len
);
565 /* In `append', if all but last arg are nil, return last arg. */
566 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
569 /* Copy the contents of the args into the result. */
571 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
573 toindex
= 0, toindex_byte
= 0;
577 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
579 for (argnum
= 0; argnum
< nargs
; argnum
++)
582 EMACS_INT thisleni
= 0;
583 register EMACS_INT thisindex
= 0;
584 register EMACS_INT thisindex_byte
= 0;
588 thislen
= Flength (this), thisleni
= XINT (thislen
);
590 /* Between strings of the same kind, copy fast. */
591 if (STRINGP (this) && STRINGP (val
)
592 && STRING_MULTIBYTE (this) == some_multibyte
)
594 EMACS_INT thislen_byte
= SBYTES (this);
596 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
597 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
599 textprops
[num_textprops
].argnum
= argnum
;
600 textprops
[num_textprops
].from
= 0;
601 textprops
[num_textprops
++].to
= toindex
;
603 toindex_byte
+= thislen_byte
;
606 /* Copy a single-byte string to a multibyte string. */
607 else if (STRINGP (this) && STRINGP (val
))
609 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
611 textprops
[num_textprops
].argnum
= argnum
;
612 textprops
[num_textprops
].from
= 0;
613 textprops
[num_textprops
++].to
= toindex
;
615 toindex_byte
+= copy_text (SDATA (this),
616 SDATA (val
) + toindex_byte
,
617 SCHARS (this), 0, 1);
621 /* Copy element by element. */
624 register Lisp_Object elt
;
626 /* Fetch next element of `this' arg into `elt', or break if
627 `this' is exhausted. */
628 if (NILP (this)) break;
630 elt
= XCAR (this), this = XCDR (this);
631 else if (thisindex
>= thisleni
)
633 else if (STRINGP (this))
636 if (STRING_MULTIBYTE (this))
638 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
641 XSETFASTINT (elt
, c
);
645 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
647 && !ASCII_CHAR_P (XINT (elt
))
648 && XINT (elt
) < 0400)
650 c
= BYTE8_TO_CHAR (XINT (elt
));
655 else if (BOOL_VECTOR_P (this))
658 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
659 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
667 elt
= AREF (this, thisindex
);
671 /* Store this element into the result. */
678 else if (VECTORP (val
))
680 ASET (val
, toindex
, elt
);
687 toindex_byte
+= CHAR_STRING (XINT (elt
),
688 SDATA (val
) + toindex_byte
);
690 SSET (val
, toindex_byte
++, XINT (elt
));
696 XSETCDR (prev
, last_tail
);
698 if (num_textprops
> 0)
701 EMACS_INT last_to_end
= -1;
703 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
705 this = args
[textprops
[argnum
].argnum
];
706 props
= text_property_list (this,
708 make_number (SCHARS (this)),
710 /* If successive arguments have properites, be sure that the
711 value of `composition' property be the copy. */
712 if (last_to_end
== textprops
[argnum
].to
)
713 make_composition_value_copy (props
);
714 add_text_properties_from_list (val
, props
,
715 make_number (textprops
[argnum
].to
));
716 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
724 static Lisp_Object string_char_byte_cache_string
;
725 static EMACS_INT string_char_byte_cache_charpos
;
726 static EMACS_INT string_char_byte_cache_bytepos
;
729 clear_string_char_byte_cache (void)
731 string_char_byte_cache_string
= Qnil
;
734 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
737 string_char_to_byte (Lisp_Object string
, EMACS_INT char_index
)
740 EMACS_INT best_below
, best_below_byte
;
741 EMACS_INT best_above
, best_above_byte
;
743 best_below
= best_below_byte
= 0;
744 best_above
= SCHARS (string
);
745 best_above_byte
= SBYTES (string
);
746 if (best_above
== best_above_byte
)
749 if (EQ (string
, string_char_byte_cache_string
))
751 if (string_char_byte_cache_charpos
< char_index
)
753 best_below
= string_char_byte_cache_charpos
;
754 best_below_byte
= string_char_byte_cache_bytepos
;
758 best_above
= string_char_byte_cache_charpos
;
759 best_above_byte
= string_char_byte_cache_bytepos
;
763 if (char_index
- best_below
< best_above
- char_index
)
765 unsigned char *p
= SDATA (string
) + best_below_byte
;
767 while (best_below
< char_index
)
769 p
+= BYTES_BY_CHAR_HEAD (*p
);
772 i_byte
= p
- SDATA (string
);
776 unsigned char *p
= SDATA (string
) + best_above_byte
;
778 while (best_above
> char_index
)
781 while (!CHAR_HEAD_P (*p
)) p
--;
784 i_byte
= p
- SDATA (string
);
787 string_char_byte_cache_bytepos
= i_byte
;
788 string_char_byte_cache_charpos
= char_index
;
789 string_char_byte_cache_string
= string
;
794 /* Return the character index corresponding to BYTE_INDEX in STRING. */
797 string_byte_to_char (Lisp_Object string
, EMACS_INT byte_index
)
800 EMACS_INT best_below
, best_below_byte
;
801 EMACS_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_bytepos
< byte_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 (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
825 unsigned char *p
= SDATA (string
) + best_below_byte
;
826 unsigned char *pend
= SDATA (string
) + byte_index
;
830 p
+= BYTES_BY_CHAR_HEAD (*p
);
834 i_byte
= p
- SDATA (string
);
838 unsigned char *p
= SDATA (string
) + best_above_byte
;
839 unsigned char *pbeg
= SDATA (string
) + byte_index
;
844 while (!CHAR_HEAD_P (*p
)) p
--;
848 i_byte
= p
- SDATA (string
);
851 string_char_byte_cache_bytepos
= i_byte
;
852 string_char_byte_cache_charpos
= i
;
853 string_char_byte_cache_string
= string
;
858 /* Convert STRING to a multibyte string. */
861 string_make_multibyte (Lisp_Object string
)
868 if (STRING_MULTIBYTE (string
))
871 nbytes
= count_size_as_multibyte (SDATA (string
),
873 /* If all the chars are ASCII, they won't need any more bytes
874 once converted. In that case, we can return STRING itself. */
875 if (nbytes
== SBYTES (string
))
878 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
879 copy_text (SDATA (string
), buf
, SBYTES (string
),
882 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
889 /* Convert STRING (if unibyte) to a multibyte string without changing
890 the number of characters. Characters 0200 trough 0237 are
891 converted to eight-bit characters. */
894 string_to_multibyte (Lisp_Object string
)
901 if (STRING_MULTIBYTE (string
))
904 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
905 /* If all the chars are ASCII, they won't need any more bytes once
907 if (nbytes
== SBYTES (string
))
908 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
910 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
911 memcpy (buf
, SDATA (string
), SBYTES (string
));
912 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
914 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
921 /* Convert STRING to a single-byte string. */
924 string_make_unibyte (Lisp_Object string
)
931 if (! STRING_MULTIBYTE (string
))
934 nchars
= SCHARS (string
);
936 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
937 copy_text (SDATA (string
), buf
, SBYTES (string
),
940 ret
= make_unibyte_string ((char *) buf
, nchars
);
946 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
948 doc
: /* Return the multibyte equivalent of STRING.
949 If STRING is unibyte and contains non-ASCII characters, the function
950 `unibyte-char-to-multibyte' is used to convert each unibyte character
951 to a multibyte character. In this case, the returned string is a
952 newly created string with no text properties. If STRING is multibyte
953 or entirely ASCII, it is returned unchanged. In particular, when
954 STRING is unibyte and entirely ASCII, the returned string is unibyte.
955 \(When the characters are all ASCII, Emacs primitives will treat the
956 string the same way whether it is unibyte or multibyte.) */)
959 CHECK_STRING (string
);
961 return string_make_multibyte (string
);
964 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
966 doc
: /* Return the unibyte equivalent of STRING.
967 Multibyte character codes are converted to unibyte according to
968 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
969 If the lookup in the translation table fails, this function takes just
970 the low 8 bits of each character. */)
973 CHECK_STRING (string
);
975 return string_make_unibyte (string
);
978 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
980 doc
: /* Return a unibyte string with the same individual bytes as STRING.
981 If STRING is unibyte, the result is STRING itself.
982 Otherwise it is a newly created string, with no text properties.
983 If STRING is multibyte and contains a character of charset
984 `eight-bit', it is converted to the corresponding single byte. */)
987 CHECK_STRING (string
);
989 if (STRING_MULTIBYTE (string
))
991 EMACS_INT bytes
= SBYTES (string
);
992 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
994 memcpy (str
, SDATA (string
), bytes
);
995 bytes
= str_as_unibyte (str
, bytes
);
996 string
= make_unibyte_string ((char *) str
, bytes
);
1002 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1004 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1005 If STRING is multibyte, the result is STRING itself.
1006 Otherwise it is a newly created string, with no text properties.
1008 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1009 part of a correct utf-8 sequence), it is converted to the corresponding
1010 multibyte character of charset `eight-bit'.
1011 See also `string-to-multibyte'.
1013 Beware, this often doesn't really do what you think it does.
1014 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1015 If you're not sure, whether to use `string-as-multibyte' or
1016 `string-to-multibyte', use `string-to-multibyte'. */)
1017 (Lisp_Object string
)
1019 CHECK_STRING (string
);
1021 if (! STRING_MULTIBYTE (string
))
1023 Lisp_Object new_string
;
1024 EMACS_INT nchars
, nbytes
;
1026 parse_str_as_multibyte (SDATA (string
),
1029 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1030 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1031 if (nbytes
!= SBYTES (string
))
1032 str_as_multibyte (SDATA (new_string
), nbytes
,
1033 SBYTES (string
), NULL
);
1034 string
= new_string
;
1035 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1040 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1042 doc
: /* Return a multibyte string with the same individual chars as STRING.
1043 If STRING is multibyte, the result is STRING itself.
1044 Otherwise it is a newly created string, with no text properties.
1046 If STRING is unibyte and contains an 8-bit byte, it is converted to
1047 the corresponding multibyte character of charset `eight-bit'.
1049 This differs from `string-as-multibyte' by converting each byte of a correct
1050 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1051 correct sequence. */)
1052 (Lisp_Object string
)
1054 CHECK_STRING (string
);
1056 return string_to_multibyte (string
);
1059 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1061 doc
: /* Return a unibyte string with the same individual chars as STRING.
1062 If STRING is unibyte, the result is STRING itself.
1063 Otherwise it is a newly created string, with no text properties,
1064 where each `eight-bit' character is converted to the corresponding byte.
1065 If STRING contains a non-ASCII, non-`eight-bit' character,
1066 an error is signaled. */)
1067 (Lisp_Object string
)
1069 CHECK_STRING (string
);
1071 if (STRING_MULTIBYTE (string
))
1073 EMACS_INT chars
= SCHARS (string
);
1074 unsigned char *str
= (unsigned char *) xmalloc (chars
);
1075 EMACS_INT converted
= str_to_unibyte (SDATA (string
), str
, chars
, 0);
1077 if (converted
< chars
)
1078 error ("Can't convert the %dth character to unibyte", converted
);
1079 string
= make_unibyte_string ((char *) str
, chars
);
1086 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1087 doc
: /* Return a copy of ALIST.
1088 This is an alist which represents the same mapping from objects to objects,
1089 but does not share the alist structure with ALIST.
1090 The objects mapped (cars and cdrs of elements of the alist)
1091 are shared, however.
1092 Elements of ALIST that are not conses are also shared. */)
1095 register Lisp_Object tem
;
1100 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1101 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1103 register Lisp_Object car
;
1107 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1112 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1113 doc
: /* Return a new string whose contents are a substring of STRING.
1114 The returned string consists of the characters between index FROM
1115 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1116 zero-indexed: 0 means the first character of STRING. Negative values
1117 are counted from the end of STRING. If TO is nil, the substring runs
1118 to the end of STRING.
1120 The STRING argument may also be a vector. In that case, the return
1121 value is a new vector that contains the elements between index FROM
1122 \(inclusive) and index TO (exclusive) of that vector argument. */)
1123 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1127 EMACS_INT size_byte
= 0;
1128 EMACS_INT from_char
, to_char
;
1129 EMACS_INT from_byte
= 0, to_byte
= 0;
1131 CHECK_VECTOR_OR_STRING (string
);
1132 CHECK_NUMBER (from
);
1134 if (STRINGP (string
))
1136 size
= SCHARS (string
);
1137 size_byte
= SBYTES (string
);
1140 size
= ASIZE (string
);
1145 to_byte
= size_byte
;
1151 to_char
= XINT (to
);
1155 if (STRINGP (string
))
1156 to_byte
= string_char_to_byte (string
, to_char
);
1159 from_char
= XINT (from
);
1162 if (STRINGP (string
))
1163 from_byte
= string_char_to_byte (string
, from_char
);
1165 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1166 args_out_of_range_3 (string
, make_number (from_char
),
1167 make_number (to_char
));
1169 if (STRINGP (string
))
1171 res
= make_specified_string (SSDATA (string
) + from_byte
,
1172 to_char
- from_char
, to_byte
- from_byte
,
1173 STRING_MULTIBYTE (string
));
1174 copy_text_properties (make_number (from_char
), make_number (to_char
),
1175 string
, make_number (0), res
, Qnil
);
1178 res
= Fvector (to_char
- from_char
, &AREF (string
, from_char
));
1184 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1185 doc
: /* Return a substring of STRING, without text properties.
1186 It starts at index FROM and ends before TO.
1187 TO may be nil or omitted; then the substring runs to the end of STRING.
1188 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1189 If FROM or TO is negative, it counts from the end.
1191 With one argument, just copy STRING without its properties. */)
1192 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1194 EMACS_INT size
, size_byte
;
1195 EMACS_INT from_char
, to_char
;
1196 EMACS_INT from_byte
, to_byte
;
1198 CHECK_STRING (string
);
1200 size
= SCHARS (string
);
1201 size_byte
= SBYTES (string
);
1204 from_char
= from_byte
= 0;
1207 CHECK_NUMBER (from
);
1208 from_char
= XINT (from
);
1212 from_byte
= string_char_to_byte (string
, from_char
);
1218 to_byte
= size_byte
;
1224 to_char
= XINT (to
);
1228 to_byte
= string_char_to_byte (string
, to_char
);
1231 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1232 args_out_of_range_3 (string
, make_number (from_char
),
1233 make_number (to_char
));
1235 return make_specified_string (SSDATA (string
) + from_byte
,
1236 to_char
- from_char
, to_byte
- from_byte
,
1237 STRING_MULTIBYTE (string
));
1240 /* Extract a substring of STRING, giving start and end positions
1241 both in characters and in bytes. */
1244 substring_both (Lisp_Object string
, EMACS_INT from
, EMACS_INT from_byte
,
1245 EMACS_INT to
, EMACS_INT to_byte
)
1249 EMACS_INT size_byte
;
1251 CHECK_VECTOR_OR_STRING (string
);
1253 if (STRINGP (string
))
1255 size
= SCHARS (string
);
1256 size_byte
= SBYTES (string
);
1259 size
= ASIZE (string
);
1261 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1262 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1264 if (STRINGP (string
))
1266 res
= make_specified_string (SSDATA (string
) + from_byte
,
1267 to
- from
, to_byte
- from_byte
,
1268 STRING_MULTIBYTE (string
));
1269 copy_text_properties (make_number (from
), make_number (to
),
1270 string
, make_number (0), res
, Qnil
);
1273 res
= Fvector (to
- from
, &AREF (string
, from
));
1278 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1279 doc
: /* Take cdr N times on LIST, return the result. */)
1280 (Lisp_Object n
, Lisp_Object list
)
1282 register int i
, num
;
1285 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1288 CHECK_LIST_CONS (list
, list
);
1294 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1295 doc
: /* Return the Nth element of LIST.
1296 N counts from zero. If LIST is not that long, nil is returned. */)
1297 (Lisp_Object n
, Lisp_Object list
)
1299 return Fcar (Fnthcdr (n
, list
));
1302 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1303 doc
: /* Return element of SEQUENCE at index N. */)
1304 (register Lisp_Object sequence
, Lisp_Object n
)
1307 if (CONSP (sequence
) || NILP (sequence
))
1308 return Fcar (Fnthcdr (n
, sequence
));
1310 /* Faref signals a "not array" error, so check here. */
1311 CHECK_ARRAY (sequence
, Qsequencep
);
1312 return Faref (sequence
, n
);
1315 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1316 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1317 The value is actually the tail of LIST whose car is ELT. */)
1318 (register Lisp_Object elt
, Lisp_Object list
)
1320 register Lisp_Object tail
;
1321 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1323 register Lisp_Object tem
;
1324 CHECK_LIST_CONS (tail
, list
);
1326 if (! NILP (Fequal (elt
, tem
)))
1333 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1334 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1335 The value is actually the tail of LIST whose car is ELT. */)
1336 (register Lisp_Object elt
, Lisp_Object list
)
1340 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1344 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1348 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1359 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1360 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1361 The value is actually the tail of LIST whose car is ELT. */)
1362 (register Lisp_Object elt
, Lisp_Object list
)
1364 register Lisp_Object tail
;
1367 return Fmemq (elt
, list
);
1369 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1371 register Lisp_Object tem
;
1372 CHECK_LIST_CONS (tail
, list
);
1374 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0))
1381 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1382 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1383 The value is actually the first element of LIST whose car is KEY.
1384 Elements of LIST that are not conses are ignored. */)
1385 (Lisp_Object key
, Lisp_Object list
)
1390 || (CONSP (XCAR (list
))
1391 && EQ (XCAR (XCAR (list
)), key
)))
1396 || (CONSP (XCAR (list
))
1397 && EQ (XCAR (XCAR (list
)), key
)))
1402 || (CONSP (XCAR (list
))
1403 && EQ (XCAR (XCAR (list
)), key
)))
1413 /* Like Fassq but never report an error and do not allow quits.
1414 Use only on lists known never to be circular. */
1417 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1420 && (!CONSP (XCAR (list
))
1421 || !EQ (XCAR (XCAR (list
)), key
)))
1424 return CAR_SAFE (list
);
1427 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1428 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1429 The value is actually the first element of LIST whose car equals KEY. */)
1430 (Lisp_Object key
, Lisp_Object list
)
1437 || (CONSP (XCAR (list
))
1438 && (car
= XCAR (XCAR (list
)),
1439 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1444 || (CONSP (XCAR (list
))
1445 && (car
= XCAR (XCAR (list
)),
1446 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1451 || (CONSP (XCAR (list
))
1452 && (car
= XCAR (XCAR (list
)),
1453 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1463 /* Like Fassoc but never report an error and do not allow quits.
1464 Use only on lists known never to be circular. */
1467 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1470 && (!CONSP (XCAR (list
))
1471 || (!EQ (XCAR (XCAR (list
)), key
)
1472 && NILP (Fequal (XCAR (XCAR (list
)), key
)))))
1475 return CONSP (list
) ? XCAR (list
) : Qnil
;
1478 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1479 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1480 The value is actually the first element of LIST whose cdr is KEY. */)
1481 (register Lisp_Object key
, Lisp_Object list
)
1486 || (CONSP (XCAR (list
))
1487 && EQ (XCDR (XCAR (list
)), key
)))
1492 || (CONSP (XCAR (list
))
1493 && EQ (XCDR (XCAR (list
)), key
)))
1498 || (CONSP (XCAR (list
))
1499 && EQ (XCDR (XCAR (list
)), key
)))
1509 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1510 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1511 The value is actually the first element of LIST whose cdr equals KEY. */)
1512 (Lisp_Object key
, Lisp_Object list
)
1519 || (CONSP (XCAR (list
))
1520 && (cdr
= XCDR (XCAR (list
)),
1521 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1526 || (CONSP (XCAR (list
))
1527 && (cdr
= XCDR (XCAR (list
)),
1528 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1533 || (CONSP (XCAR (list
))
1534 && (cdr
= XCDR (XCAR (list
)),
1535 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1545 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1546 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1547 The modified LIST is returned. Comparison is done with `eq'.
1548 If the first member of LIST is ELT, there is no way to remove it by side effect;
1549 therefore, write `(setq foo (delq element foo))'
1550 to be sure of changing the value of `foo'. */)
1551 (register Lisp_Object elt
, Lisp_Object list
)
1553 register Lisp_Object tail
, prev
;
1554 register Lisp_Object tem
;
1558 while (!NILP (tail
))
1560 CHECK_LIST_CONS (tail
, list
);
1567 Fsetcdr (prev
, XCDR (tail
));
1577 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1578 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1579 SEQ must be a list, a vector, or a string.
1580 The modified SEQ is returned. Comparison is done with `equal'.
1581 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1582 is not a side effect; it is simply using a different sequence.
1583 Therefore, write `(setq foo (delete element foo))'
1584 to be sure of changing the value of `foo'. */)
1585 (Lisp_Object elt
, Lisp_Object seq
)
1591 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1592 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1595 if (n
!= ASIZE (seq
))
1597 struct Lisp_Vector
*p
= allocate_vector (n
);
1599 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1600 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1601 p
->contents
[n
++] = AREF (seq
, i
);
1603 XSETVECTOR (seq
, p
);
1606 else if (STRINGP (seq
))
1608 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1611 for (i
= nchars
= nbytes
= ibyte
= 0;
1613 ++i
, ibyte
+= cbytes
)
1615 if (STRING_MULTIBYTE (seq
))
1617 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1618 cbytes
= CHAR_BYTES (c
);
1626 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1633 if (nchars
!= SCHARS (seq
))
1637 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1638 if (!STRING_MULTIBYTE (seq
))
1639 STRING_SET_UNIBYTE (tem
);
1641 for (i
= nchars
= nbytes
= ibyte
= 0;
1643 ++i
, ibyte
+= cbytes
)
1645 if (STRING_MULTIBYTE (seq
))
1647 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1648 cbytes
= CHAR_BYTES (c
);
1656 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1658 unsigned char *from
= SDATA (seq
) + ibyte
;
1659 unsigned char *to
= SDATA (tem
) + nbytes
;
1665 for (n
= cbytes
; n
--; )
1675 Lisp_Object tail
, prev
;
1677 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1679 CHECK_LIST_CONS (tail
, seq
);
1681 if (!NILP (Fequal (elt
, XCAR (tail
))))
1686 Fsetcdr (prev
, XCDR (tail
));
1697 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1698 doc
: /* Reverse LIST by modifying cdr pointers.
1699 Return the reversed list. */)
1702 register Lisp_Object prev
, tail
, next
;
1704 if (NILP (list
)) return list
;
1707 while (!NILP (tail
))
1710 CHECK_LIST_CONS (tail
, list
);
1712 Fsetcdr (tail
, prev
);
1719 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1720 doc
: /* Reverse LIST, copying. Return the reversed list.
1721 See also the function `nreverse', which is used more often. */)
1726 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1729 new = Fcons (XCAR (list
), new);
1731 CHECK_LIST_END (list
, list
);
1735 Lisp_Object
merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
);
1737 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1738 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1739 Returns the sorted list. LIST is modified by side effects.
1740 PREDICATE is called with two elements of LIST, and should return non-nil
1741 if the first element should sort before the second. */)
1742 (Lisp_Object list
, Lisp_Object predicate
)
1744 Lisp_Object front
, back
;
1745 register Lisp_Object len
, tem
;
1746 struct gcpro gcpro1
, gcpro2
;
1747 register int length
;
1750 len
= Flength (list
);
1751 length
= XINT (len
);
1755 XSETINT (len
, (length
/ 2) - 1);
1756 tem
= Fnthcdr (len
, list
);
1758 Fsetcdr (tem
, Qnil
);
1760 GCPRO2 (front
, back
);
1761 front
= Fsort (front
, predicate
);
1762 back
= Fsort (back
, predicate
);
1764 return merge (front
, back
, predicate
);
1768 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1771 register Lisp_Object tail
;
1773 register Lisp_Object l1
, l2
;
1774 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1781 /* It is sufficient to protect org_l1 and org_l2.
1782 When l1 and l2 are updated, we copy the new values
1783 back into the org_ vars. */
1784 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1804 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1820 Fsetcdr (tail
, tem
);
1826 /* This does not check for quits. That is safe since it must terminate. */
1828 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1829 doc
: /* Extract a value from a property list.
1830 PLIST is a property list, which is a list of the form
1831 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1832 corresponding to the given PROP, or nil if PROP is not one of the
1833 properties on the list. This function never signals an error. */)
1834 (Lisp_Object plist
, Lisp_Object prop
)
1836 Lisp_Object tail
, halftail
;
1838 /* halftail is used to detect circular lists. */
1839 tail
= halftail
= plist
;
1840 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1842 if (EQ (prop
, XCAR (tail
)))
1843 return XCAR (XCDR (tail
));
1845 tail
= XCDR (XCDR (tail
));
1846 halftail
= XCDR (halftail
);
1847 if (EQ (tail
, halftail
))
1850 #if 0 /* Unsafe version. */
1851 /* This function can be called asynchronously
1852 (setup_coding_system). Don't QUIT in that case. */
1853 if (!interrupt_input_blocked
)
1861 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1862 doc
: /* Return the value of SYMBOL's PROPNAME property.
1863 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1864 (Lisp_Object symbol
, Lisp_Object propname
)
1866 CHECK_SYMBOL (symbol
);
1867 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1870 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1871 doc
: /* Change value in PLIST of PROP to VAL.
1872 PLIST is a property list, which is a list of the form
1873 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1874 If PROP is already a property on the list, its value is set to VAL,
1875 otherwise the new PROP VAL pair is added. The new plist is returned;
1876 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1877 The PLIST is modified by side effects. */)
1878 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1880 register Lisp_Object tail
, prev
;
1881 Lisp_Object newcell
;
1883 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1884 tail
= XCDR (XCDR (tail
)))
1886 if (EQ (prop
, XCAR (tail
)))
1888 Fsetcar (XCDR (tail
), val
);
1895 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
1899 Fsetcdr (XCDR (prev
), newcell
);
1903 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1904 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1905 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1906 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
1908 CHECK_SYMBOL (symbol
);
1909 XSYMBOL (symbol
)->plist
1910 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1914 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1915 doc
: /* Extract a value from a property list, comparing with `equal'.
1916 PLIST is a property list, which is a list of the form
1917 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1918 corresponding to the given PROP, or nil if PROP is not
1919 one of the properties on the list. */)
1920 (Lisp_Object plist
, Lisp_Object prop
)
1925 CONSP (tail
) && CONSP (XCDR (tail
));
1926 tail
= XCDR (XCDR (tail
)))
1928 if (! NILP (Fequal (prop
, XCAR (tail
))))
1929 return XCAR (XCDR (tail
));
1934 CHECK_LIST_END (tail
, prop
);
1939 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
1940 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
1941 PLIST is a property list, which is a list of the form
1942 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
1943 If PROP is already a property on the list, its value is set to VAL,
1944 otherwise the new PROP VAL pair is added. The new plist is returned;
1945 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
1946 The PLIST is modified by side effects. */)
1947 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
1949 register Lisp_Object tail
, prev
;
1950 Lisp_Object newcell
;
1952 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1953 tail
= XCDR (XCDR (tail
)))
1955 if (! NILP (Fequal (prop
, XCAR (tail
))))
1957 Fsetcar (XCDR (tail
), val
);
1964 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1968 Fsetcdr (XCDR (prev
), newcell
);
1972 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
1973 doc
: /* Return t if the two args are the same Lisp object.
1974 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
1975 (Lisp_Object obj1
, Lisp_Object obj2
)
1978 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
1980 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
1983 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1984 doc
: /* Return t if two Lisp objects have similar structure and contents.
1985 They must have the same data type.
1986 Conses are compared by comparing the cars and the cdrs.
1987 Vectors and strings are compared element by element.
1988 Numbers are compared by value, but integers cannot equal floats.
1989 (Use `=' if you want integers and floats to be able to be equal.)
1990 Symbols must match exactly. */)
1991 (register Lisp_Object o1
, Lisp_Object o2
)
1993 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
1996 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
1997 doc
: /* Return t if two Lisp objects have similar structure and contents.
1998 This is like `equal' except that it compares the text properties
1999 of strings. (`equal' ignores text properties.) */)
2000 (register Lisp_Object o1
, Lisp_Object o2
)
2002 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2005 /* DEPTH is current depth of recursion. Signal an error if it
2007 PROPS, if non-nil, means compare string text properties too. */
2010 internal_equal (register Lisp_Object o1
, register Lisp_Object o2
, int depth
, int props
)
2013 error ("Stack overflow in equal");
2019 if (XTYPE (o1
) != XTYPE (o2
))
2028 d1
= extract_float (o1
);
2029 d2
= extract_float (o2
);
2030 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2031 though they are not =. */
2032 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2036 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2043 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2047 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2049 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2052 o1
= XOVERLAY (o1
)->plist
;
2053 o2
= XOVERLAY (o2
)->plist
;
2058 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2059 && (XMARKER (o1
)->buffer
== 0
2060 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2064 case Lisp_Vectorlike
:
2067 EMACS_INT size
= ASIZE (o1
);
2068 /* Pseudovectors have the type encoded in the size field, so this test
2069 actually checks that the objects have the same type as well as the
2071 if (ASIZE (o2
) != size
)
2073 /* Boolvectors are compared much like strings. */
2074 if (BOOL_VECTOR_P (o1
))
2077 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2078 / BOOL_VECTOR_BITS_PER_CHAR
);
2080 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2082 if (memcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2087 if (WINDOW_CONFIGURATIONP (o1
))
2088 return compare_window_configurations (o1
, o2
, 0);
2090 /* Aside from them, only true vectors, char-tables, compiled
2091 functions, and fonts (font-spec, font-entity, font-ojbect)
2092 are sensible to compare, so eliminate the others now. */
2093 if (size
& PSEUDOVECTOR_FLAG
)
2095 if (!(size
& (PVEC_COMPILED
2096 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
| PVEC_FONT
)))
2098 size
&= PSEUDOVECTOR_SIZE_MASK
;
2100 for (i
= 0; i
< size
; i
++)
2105 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2113 if (SCHARS (o1
) != SCHARS (o2
))
2115 if (SBYTES (o1
) != SBYTES (o2
))
2117 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2119 if (props
&& !compare_string_intervals (o1
, o2
))
2131 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2132 doc
: /* Store each element of ARRAY with ITEM.
2133 ARRAY is a vector, string, char-table, or bool-vector. */)
2134 (Lisp_Object array
, Lisp_Object item
)
2136 register EMACS_INT size
, idx
;
2139 if (VECTORP (array
))
2141 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2142 size
= ASIZE (array
);
2143 for (idx
= 0; idx
< size
; idx
++)
2146 else if (CHAR_TABLE_P (array
))
2150 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2151 XCHAR_TABLE (array
)->contents
[i
] = item
;
2152 XCHAR_TABLE (array
)->defalt
= item
;
2154 else if (STRINGP (array
))
2156 register unsigned char *p
= SDATA (array
);
2157 CHECK_NUMBER (item
);
2158 charval
= XINT (item
);
2159 size
= SCHARS (array
);
2160 if (STRING_MULTIBYTE (array
))
2162 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2163 int len
= CHAR_STRING (charval
, str
);
2164 EMACS_INT size_byte
= SBYTES (array
);
2165 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2168 if (size
!= size_byte
)
2171 int this_len
= BYTES_BY_CHAR_HEAD (*p1
);
2172 if (len
!= this_len
)
2173 error ("Attempt to change byte length of a string");
2176 for (i
= 0; i
< size_byte
; i
++)
2177 *p
++ = str
[i
% len
];
2180 for (idx
= 0; idx
< size
; idx
++)
2183 else if (BOOL_VECTOR_P (array
))
2185 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2187 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2188 / BOOL_VECTOR_BITS_PER_CHAR
);
2190 charval
= (! NILP (item
) ? -1 : 0);
2191 for (idx
= 0; idx
< size_in_chars
- 1; idx
++)
2193 if (idx
< size_in_chars
)
2195 /* Mask out bits beyond the vector size. */
2196 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2197 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2202 wrong_type_argument (Qarrayp
, array
);
2206 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2208 doc
: /* Clear the contents of STRING.
2209 This makes STRING unibyte and may change its length. */)
2210 (Lisp_Object string
)
2213 CHECK_STRING (string
);
2214 len
= SBYTES (string
);
2215 memset (SDATA (string
), 0, len
);
2216 STRING_SET_CHARS (string
, len
);
2217 STRING_SET_UNIBYTE (string
);
2223 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2225 Lisp_Object args
[2];
2228 return Fnconc (2, args
);
2231 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2232 doc
: /* Concatenate any number of lists by altering them.
2233 Only the last argument is not altered, and need not be a list.
2234 usage: (nconc &rest LISTS) */)
2235 (int nargs
, Lisp_Object
*args
)
2237 register int argnum
;
2238 register Lisp_Object tail
, tem
, val
;
2242 for (argnum
= 0; argnum
< nargs
; argnum
++)
2245 if (NILP (tem
)) continue;
2250 if (argnum
+ 1 == nargs
) break;
2252 CHECK_LIST_CONS (tem
, tem
);
2261 tem
= args
[argnum
+ 1];
2262 Fsetcdr (tail
, tem
);
2264 args
[argnum
+ 1] = tail
;
2270 /* This is the guts of all mapping functions.
2271 Apply FN to each element of SEQ, one by one,
2272 storing the results into elements of VALS, a C vector of Lisp_Objects.
2273 LENI is the length of VALS, which should also be the length of SEQ. */
2276 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2278 register Lisp_Object tail
;
2280 register EMACS_INT i
;
2281 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2285 /* Don't let vals contain any garbage when GC happens. */
2286 for (i
= 0; i
< leni
; i
++)
2289 GCPRO3 (dummy
, fn
, seq
);
2291 gcpro1
.nvars
= leni
;
2295 /* We need not explicitly protect `tail' because it is used only on lists, and
2296 1) lists are not relocated and 2) the list is marked via `seq' so will not
2301 for (i
= 0; i
< leni
; i
++)
2303 dummy
= call1 (fn
, AREF (seq
, i
));
2308 else if (BOOL_VECTOR_P (seq
))
2310 for (i
= 0; i
< leni
; i
++)
2313 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2314 dummy
= (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
))) ? Qt
: Qnil
;
2315 dummy
= call1 (fn
, dummy
);
2320 else if (STRINGP (seq
))
2324 for (i
= 0, i_byte
= 0; i
< leni
;)
2327 EMACS_INT i_before
= i
;
2329 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2330 XSETFASTINT (dummy
, c
);
2331 dummy
= call1 (fn
, dummy
);
2333 vals
[i_before
] = dummy
;
2336 else /* Must be a list, since Flength did not get an error */
2339 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
2341 dummy
= call1 (fn
, XCAR (tail
));
2351 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2352 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2353 In between each pair of results, stick in SEPARATOR. Thus, " " as
2354 SEPARATOR results in spaces between the values returned by FUNCTION.
2355 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2356 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2359 register EMACS_INT leni
;
2361 register Lisp_Object
*args
;
2362 register EMACS_INT i
;
2363 struct gcpro gcpro1
;
2367 len
= Flength (sequence
);
2368 if (CHAR_TABLE_P (sequence
))
2369 wrong_type_argument (Qlistp
, sequence
);
2371 nargs
= leni
+ leni
- 1;
2372 if (nargs
< 0) return empty_unibyte_string
;
2374 SAFE_ALLOCA_LISP (args
, nargs
);
2377 mapcar1 (leni
, args
, function
, sequence
);
2380 for (i
= leni
- 1; i
> 0; i
--)
2381 args
[i
+ i
] = args
[i
];
2383 for (i
= 1; i
< nargs
; i
+= 2)
2384 args
[i
] = separator
;
2386 ret
= Fconcat (nargs
, args
);
2392 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2393 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2394 The result is a list just as long as SEQUENCE.
2395 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2396 (Lisp_Object function
, Lisp_Object sequence
)
2398 register Lisp_Object len
;
2399 register EMACS_INT leni
;
2400 register Lisp_Object
*args
;
2404 len
= Flength (sequence
);
2405 if (CHAR_TABLE_P (sequence
))
2406 wrong_type_argument (Qlistp
, sequence
);
2407 leni
= XFASTINT (len
);
2409 SAFE_ALLOCA_LISP (args
, leni
);
2411 mapcar1 (leni
, args
, function
, sequence
);
2413 ret
= Flist (leni
, args
);
2419 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2420 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2421 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2422 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2423 (Lisp_Object function
, Lisp_Object sequence
)
2425 register EMACS_INT leni
;
2427 leni
= XFASTINT (Flength (sequence
));
2428 if (CHAR_TABLE_P (sequence
))
2429 wrong_type_argument (Qlistp
, sequence
);
2430 mapcar1 (leni
, 0, function
, sequence
);
2435 /* This is how C code calls `yes-or-no-p' and allows the user
2438 Anything that calls this function must protect from GC! */
2441 do_yes_or_no_p (Lisp_Object prompt
)
2443 return call1 (intern ("yes-or-no-p"), prompt
);
2446 /* Anything that calls this function must protect from GC! */
2448 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2449 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2450 PROMPT is the string to display to ask the question. It should end in
2451 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2453 The user must confirm the answer with RET, and can edit it until it
2456 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2457 is nil, and `use-dialog-box' is non-nil. */)
2458 (Lisp_Object prompt
)
2460 register Lisp_Object ans
;
2461 Lisp_Object args
[2];
2462 struct gcpro gcpro1
;
2464 CHECK_STRING (prompt
);
2467 if (FRAME_WINDOW_P (SELECTED_FRAME ())
2468 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2472 Lisp_Object pane
, menu
, obj
;
2473 redisplay_preserve_echo_area (4);
2474 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2475 Fcons (Fcons (build_string ("No"), Qnil
),
2478 menu
= Fcons (prompt
, pane
);
2479 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2483 #endif /* HAVE_MENUS */
2486 args
[1] = build_string ("(yes or no) ");
2487 prompt
= Fconcat (2, args
);
2493 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2494 Qyes_or_no_p_history
, Qnil
,
2496 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2501 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2509 message ("Please answer yes or no.");
2510 Fsleep_for (make_number (2), Qnil
);
2514 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2515 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2517 Each of the three load averages is multiplied by 100, then converted
2520 When USE-FLOATS is non-nil, floats will be used instead of integers.
2521 These floats are not multiplied by 100.
2523 If the 5-minute or 15-minute load averages are not available, return a
2524 shortened list, containing only those averages which are available.
2526 An error is thrown if the load average can't be obtained. In some
2527 cases making it work would require Emacs being installed setuid or
2528 setgid so that it can read kernel information, and that usually isn't
2530 (Lisp_Object use_floats
)
2533 int loads
= getloadavg (load_ave
, 3);
2534 Lisp_Object ret
= Qnil
;
2537 error ("load-average not implemented for this operating system");
2541 Lisp_Object load
= (NILP (use_floats
) ?
2542 make_number ((int) (100.0 * load_ave
[loads
]))
2543 : make_float (load_ave
[loads
]));
2544 ret
= Fcons (load
, ret
);
2550 Lisp_Object Qsubfeatures
;
2552 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2553 doc
: /* Return t if FEATURE is present in this Emacs.
2555 Use this to conditionalize execution of lisp code based on the
2556 presence or absence of Emacs or environment extensions.
2557 Use `provide' to declare that a feature is available. This function
2558 looks at the value of the variable `features'. The optional argument
2559 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2560 (Lisp_Object feature
, Lisp_Object subfeature
)
2562 register Lisp_Object tem
;
2563 CHECK_SYMBOL (feature
);
2564 tem
= Fmemq (feature
, Vfeatures
);
2565 if (!NILP (tem
) && !NILP (subfeature
))
2566 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2567 return (NILP (tem
)) ? Qnil
: Qt
;
2570 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2571 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2572 The optional argument SUBFEATURES should be a list of symbols listing
2573 particular subfeatures supported in this version of FEATURE. */)
2574 (Lisp_Object feature
, Lisp_Object subfeatures
)
2576 register Lisp_Object tem
;
2577 CHECK_SYMBOL (feature
);
2578 CHECK_LIST (subfeatures
);
2579 if (!NILP (Vautoload_queue
))
2580 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2582 tem
= Fmemq (feature
, Vfeatures
);
2584 Vfeatures
= Fcons (feature
, Vfeatures
);
2585 if (!NILP (subfeatures
))
2586 Fput (feature
, Qsubfeatures
, subfeatures
);
2587 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2589 /* Run any load-hooks for this file. */
2590 tem
= Fassq (feature
, Vafter_load_alist
);
2592 Fprogn (XCDR (tem
));
2597 /* `require' and its subroutines. */
2599 /* List of features currently being require'd, innermost first. */
2601 static Lisp_Object require_nesting_list
;
2604 require_unwind (Lisp_Object old_value
)
2606 return require_nesting_list
= old_value
;
2609 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2610 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2611 If FEATURE is not a member of the list `features', then the feature
2612 is not loaded; so load the file FILENAME.
2613 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2614 and `load' will try to load this name appended with the suffix `.elc' or
2615 `.el', in that order. The name without appended suffix will not be used.
2616 If the optional third argument NOERROR is non-nil,
2617 then return nil if the file is not found instead of signaling an error.
2618 Normally the return value is FEATURE.
2619 The normal messages at start and end of loading FILENAME are suppressed. */)
2620 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2622 register Lisp_Object tem
;
2623 struct gcpro gcpro1
, gcpro2
;
2624 int from_file
= load_in_progress
;
2626 CHECK_SYMBOL (feature
);
2628 /* Record the presence of `require' in this file
2629 even if the feature specified is already loaded.
2630 But not more than once in any file,
2631 and not when we aren't loading or reading from a file. */
2633 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2634 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2639 tem
= Fcons (Qrequire
, feature
);
2640 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2641 LOADHIST_ATTACH (tem
);
2643 tem
= Fmemq (feature
, Vfeatures
);
2647 int count
= SPECPDL_INDEX ();
2650 /* This is to make sure that loadup.el gives a clear picture
2651 of what files are preloaded and when. */
2652 if (! NILP (Vpurify_flag
))
2653 error ("(require %s) while preparing to dump",
2654 SDATA (SYMBOL_NAME (feature
)));
2656 /* A certain amount of recursive `require' is legitimate,
2657 but if we require the same feature recursively 3 times,
2659 tem
= require_nesting_list
;
2660 while (! NILP (tem
))
2662 if (! NILP (Fequal (feature
, XCAR (tem
))))
2667 error ("Recursive `require' for feature `%s'",
2668 SDATA (SYMBOL_NAME (feature
)));
2670 /* Update the list for any nested `require's that occur. */
2671 record_unwind_protect (require_unwind
, require_nesting_list
);
2672 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2674 /* Value saved here is to be restored into Vautoload_queue */
2675 record_unwind_protect (un_autoload
, Vautoload_queue
);
2676 Vautoload_queue
= Qt
;
2678 /* Load the file. */
2679 GCPRO2 (feature
, filename
);
2680 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2681 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2684 /* If load failed entirely, return nil. */
2686 return unbind_to (count
, Qnil
);
2688 tem
= Fmemq (feature
, Vfeatures
);
2690 error ("Required feature `%s' was not provided",
2691 SDATA (SYMBOL_NAME (feature
)));
2693 /* Once loading finishes, don't undo it. */
2694 Vautoload_queue
= Qt
;
2695 feature
= unbind_to (count
, feature
);
2701 /* Primitives for work of the "widget" library.
2702 In an ideal world, this section would not have been necessary.
2703 However, lisp function calls being as slow as they are, it turns
2704 out that some functions in the widget library (wid-edit.el) are the
2705 bottleneck of Widget operation. Here is their translation to C,
2706 for the sole reason of efficiency. */
2708 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2709 doc
: /* Return non-nil if PLIST has the property PROP.
2710 PLIST is a property list, which is a list of the form
2711 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2712 Unlike `plist-get', this allows you to distinguish between a missing
2713 property and a property with the value nil.
2714 The value is actually the tail of PLIST whose car is PROP. */)
2715 (Lisp_Object plist
, Lisp_Object prop
)
2717 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2720 plist
= XCDR (plist
);
2721 plist
= CDR (plist
);
2726 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2727 doc
: /* In WIDGET, set PROPERTY to VALUE.
2728 The value can later be retrieved with `widget-get'. */)
2729 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2731 CHECK_CONS (widget
);
2732 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2736 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2737 doc
: /* In WIDGET, get the value of PROPERTY.
2738 The value could either be specified when the widget was created, or
2739 later with `widget-put'. */)
2740 (Lisp_Object widget
, Lisp_Object property
)
2748 CHECK_CONS (widget
);
2749 tmp
= Fplist_member (XCDR (widget
), property
);
2755 tmp
= XCAR (widget
);
2758 widget
= Fget (tmp
, Qwidget_type
);
2762 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2763 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2764 ARGS are passed as extra arguments to the function.
2765 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2766 (int nargs
, Lisp_Object
*args
)
2768 /* This function can GC. */
2769 Lisp_Object newargs
[3];
2770 struct gcpro gcpro1
, gcpro2
;
2773 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2774 newargs
[1] = args
[0];
2775 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2776 GCPRO2 (newargs
[0], newargs
[2]);
2777 result
= Fapply (3, newargs
);
2782 #ifdef HAVE_LANGINFO_CODESET
2783 #include <langinfo.h>
2786 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2787 doc
: /* Access locale data ITEM for the current C locale, if available.
2788 ITEM should be one of the following:
2790 `codeset', returning the character set as a string (locale item CODESET);
2792 `days', returning a 7-element vector of day names (locale items DAY_n);
2794 `months', returning a 12-element vector of month names (locale items MON_n);
2796 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2797 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2799 If the system can't provide such information through a call to
2800 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2802 See also Info node `(libc)Locales'.
2804 The data read from the system are decoded using `locale-coding-system'. */)
2808 #ifdef HAVE_LANGINFO_CODESET
2810 if (EQ (item
, Qcodeset
))
2812 str
= nl_langinfo (CODESET
);
2813 return build_string (str
);
2816 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2818 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2819 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2821 struct gcpro gcpro1
;
2823 synchronize_system_time_locale ();
2824 for (i
= 0; i
< 7; i
++)
2826 str
= nl_langinfo (days
[i
]);
2827 val
= make_unibyte_string (str
, strlen (str
));
2828 /* Fixme: Is this coding system necessarily right, even if
2829 it is consistent with CODESET? If not, what to do? */
2830 Faset (v
, make_number (i
),
2831 code_convert_string_norecord (val
, Vlocale_coding_system
,
2839 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2841 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2842 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2843 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2845 struct gcpro gcpro1
;
2847 synchronize_system_time_locale ();
2848 for (i
= 0; i
< 12; i
++)
2850 str
= nl_langinfo (months
[i
]);
2851 val
= make_unibyte_string (str
, strlen (str
));
2852 Faset (v
, make_number (i
),
2853 code_convert_string_norecord (val
, Vlocale_coding_system
, 0));
2859 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2860 but is in the locale files. This could be used by ps-print. */
2862 else if (EQ (item
, Qpaper
))
2864 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
2865 make_number (nl_langinfo (PAPER_HEIGHT
)));
2867 #endif /* PAPER_WIDTH */
2868 #endif /* HAVE_LANGINFO_CODESET*/
2872 /* base64 encode/decode functions (RFC 2045).
2873 Based on code from GNU recode. */
2875 #define MIME_LINE_LENGTH 76
2877 #define IS_ASCII(Character) \
2879 #define IS_BASE64(Character) \
2880 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2881 #define IS_BASE64_IGNORABLE(Character) \
2882 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2883 || (Character) == '\f' || (Character) == '\r')
2885 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2886 character or return retval if there are no characters left to
2888 #define READ_QUADRUPLET_BYTE(retval) \
2893 if (nchars_return) \
2894 *nchars_return = nchars; \
2899 while (IS_BASE64_IGNORABLE (c))
2901 /* Table of characters coding the 64 values. */
2902 static const char base64_value_to_char
[64] =
2904 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2905 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2906 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2907 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2908 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2909 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2910 '8', '9', '+', '/' /* 60-63 */
2913 /* Table of base64 values for first 128 characters. */
2914 static const short base64_char_to_value
[128] =
2916 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2917 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2918 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2919 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2920 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2921 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2922 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2923 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2924 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2925 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2926 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2927 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2928 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2931 /* The following diagram shows the logical steps by which three octets
2932 get transformed into four base64 characters.
2934 .--------. .--------. .--------.
2935 |aaaaaabb| |bbbbcccc| |ccdddddd|
2936 `--------' `--------' `--------'
2938 .--------+--------+--------+--------.
2939 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2940 `--------+--------+--------+--------'
2942 .--------+--------+--------+--------.
2943 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2944 `--------+--------+--------+--------'
2946 The octets are divided into 6 bit chunks, which are then encoded into
2947 base64 characters. */
2950 static EMACS_INT
base64_encode_1 (const char *, char *, EMACS_INT
, int, int);
2951 static EMACS_INT
base64_decode_1 (const char *, char *, EMACS_INT
, int,
2954 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2956 doc
: /* Base64-encode the region between BEG and END.
2957 Return the length of the encoded text.
2958 Optional third argument NO-LINE-BREAK means do not break long lines
2959 into shorter lines. */)
2960 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
2963 EMACS_INT allength
, length
;
2964 EMACS_INT ibeg
, iend
, encoded_length
;
2965 EMACS_INT old_pos
= PT
;
2968 validate_region (&beg
, &end
);
2970 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2971 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2972 move_gap_both (XFASTINT (beg
), ibeg
);
2974 /* We need to allocate enough room for encoding the text.
2975 We need 33 1/3% more space, plus a newline every 76
2976 characters, and then we round up. */
2977 length
= iend
- ibeg
;
2978 allength
= length
+ length
/3 + 1;
2979 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2981 SAFE_ALLOCA (encoded
, char *, allength
);
2982 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
2983 encoded
, length
, NILP (no_line_break
),
2984 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
2985 if (encoded_length
> allength
)
2988 if (encoded_length
< 0)
2990 /* The encoding wasn't possible. */
2992 error ("Multibyte character in data for base64 encoding");
2995 /* Now we have encoded the region, so we insert the new contents
2996 and delete the old. (Insert first in order to preserve markers.) */
2997 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2998 insert (encoded
, encoded_length
);
3000 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3002 /* If point was outside of the region, restore it exactly; else just
3003 move to the beginning of the region. */
3004 if (old_pos
>= XFASTINT (end
))
3005 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3006 else if (old_pos
> XFASTINT (beg
))
3007 old_pos
= XFASTINT (beg
);
3010 /* We return the length of the encoded text. */
3011 return make_number (encoded_length
);
3014 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3016 doc
: /* Base64-encode STRING and return the result.
3017 Optional second argument NO-LINE-BREAK means do not break long lines
3018 into shorter lines. */)
3019 (Lisp_Object string
, Lisp_Object no_line_break
)
3021 EMACS_INT allength
, length
, encoded_length
;
3023 Lisp_Object encoded_string
;
3026 CHECK_STRING (string
);
3028 /* We need to allocate enough room for encoding the text.
3029 We need 33 1/3% more space, plus a newline every 76
3030 characters, and then we round up. */
3031 length
= SBYTES (string
);
3032 allength
= length
+ length
/3 + 1;
3033 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3035 /* We need to allocate enough room for decoding the text. */
3036 SAFE_ALLOCA (encoded
, char *, allength
);
3038 encoded_length
= base64_encode_1 (SSDATA (string
),
3039 encoded
, length
, NILP (no_line_break
),
3040 STRING_MULTIBYTE (string
));
3041 if (encoded_length
> allength
)
3044 if (encoded_length
< 0)
3046 /* The encoding wasn't possible. */
3048 error ("Multibyte character in data for base64 encoding");
3051 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3054 return encoded_string
;
3058 base64_encode_1 (const char *from
, char *to
, EMACS_INT length
,
3059 int line_break
, int multibyte
)
3072 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3073 if (CHAR_BYTE8_P (c
))
3074 c
= CHAR_TO_BYTE8 (c
);
3082 /* Wrap line every 76 characters. */
3086 if (counter
< MIME_LINE_LENGTH
/ 4)
3095 /* Process first byte of a triplet. */
3097 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3098 value
= (0x03 & c
) << 4;
3100 /* Process second byte of a triplet. */
3104 *e
++ = base64_value_to_char
[value
];
3112 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3113 if (CHAR_BYTE8_P (c
))
3114 c
= CHAR_TO_BYTE8 (c
);
3122 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3123 value
= (0x0f & c
) << 2;
3125 /* Process third byte of a triplet. */
3129 *e
++ = base64_value_to_char
[value
];
3136 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3137 if (CHAR_BYTE8_P (c
))
3138 c
= CHAR_TO_BYTE8 (c
);
3146 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3147 *e
++ = base64_value_to_char
[0x3f & c
];
3154 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3156 doc
: /* Base64-decode the region between BEG and END.
3157 Return the length of the decoded text.
3158 If the region can't be decoded, signal an error and don't modify the buffer. */)
3159 (Lisp_Object beg
, Lisp_Object end
)
3161 EMACS_INT ibeg
, iend
, length
, allength
;
3163 EMACS_INT old_pos
= PT
;
3164 EMACS_INT decoded_length
;
3165 EMACS_INT inserted_chars
;
3166 int multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3169 validate_region (&beg
, &end
);
3171 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3172 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3174 length
= iend
- ibeg
;
3176 /* We need to allocate enough room for decoding the text. If we are
3177 working on a multibyte buffer, each decoded code may occupy at
3179 allength
= multibyte
? length
* 2 : length
;
3180 SAFE_ALLOCA (decoded
, char *, allength
);
3182 move_gap_both (XFASTINT (beg
), ibeg
);
3183 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3185 multibyte
, &inserted_chars
);
3186 if (decoded_length
> allength
)
3189 if (decoded_length
< 0)
3191 /* The decoding wasn't possible. */
3193 error ("Invalid base64 data");
3196 /* Now we have decoded the region, so we insert the new contents
3197 and delete the old. (Insert first in order to preserve markers.) */
3198 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3199 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3202 /* Delete the original text. */
3203 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3204 iend
+ decoded_length
, 1);
3206 /* If point was outside of the region, restore it exactly; else just
3207 move to the beginning of the region. */
3208 if (old_pos
>= XFASTINT (end
))
3209 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3210 else if (old_pos
> XFASTINT (beg
))
3211 old_pos
= XFASTINT (beg
);
3212 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3214 return make_number (inserted_chars
);
3217 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3219 doc
: /* Base64-decode STRING and return the result. */)
3220 (Lisp_Object string
)
3223 EMACS_INT length
, decoded_length
;
3224 Lisp_Object decoded_string
;
3227 CHECK_STRING (string
);
3229 length
= SBYTES (string
);
3230 /* We need to allocate enough room for decoding the text. */
3231 SAFE_ALLOCA (decoded
, char *, length
);
3233 /* The decoded result should be unibyte. */
3234 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3236 if (decoded_length
> length
)
3238 else if (decoded_length
>= 0)
3239 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3241 decoded_string
= Qnil
;
3244 if (!STRINGP (decoded_string
))
3245 error ("Invalid base64 data");
3247 return decoded_string
;
3250 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3251 MULTIBYTE is nonzero, the decoded result should be in multibyte
3252 form. If NCHARS_RETRUN is not NULL, store the number of produced
3253 characters in *NCHARS_RETURN. */
3256 base64_decode_1 (const char *from
, char *to
, EMACS_INT length
,
3257 int multibyte
, EMACS_INT
*nchars_return
)
3259 EMACS_INT i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3262 unsigned long value
;
3263 EMACS_INT nchars
= 0;
3267 /* Process first byte of a quadruplet. */
3269 READ_QUADRUPLET_BYTE (e
-to
);
3273 value
= base64_char_to_value
[c
] << 18;
3275 /* Process second byte of a quadruplet. */
3277 READ_QUADRUPLET_BYTE (-1);
3281 value
|= base64_char_to_value
[c
] << 12;
3283 c
= (unsigned char) (value
>> 16);
3284 if (multibyte
&& c
>= 128)
3285 e
+= BYTE8_STRING (c
, e
);
3290 /* Process third byte of a quadruplet. */
3292 READ_QUADRUPLET_BYTE (-1);
3296 READ_QUADRUPLET_BYTE (-1);
3305 value
|= base64_char_to_value
[c
] << 6;
3307 c
= (unsigned char) (0xff & value
>> 8);
3308 if (multibyte
&& c
>= 128)
3309 e
+= BYTE8_STRING (c
, e
);
3314 /* Process fourth byte of a quadruplet. */
3316 READ_QUADRUPLET_BYTE (-1);
3323 value
|= base64_char_to_value
[c
];
3325 c
= (unsigned char) (0xff & value
);
3326 if (multibyte
&& c
>= 128)
3327 e
+= BYTE8_STRING (c
, e
);
3336 /***********************************************************************
3338 ***** Hash Tables *****
3340 ***********************************************************************/
3342 /* Implemented by gerd@gnu.org. This hash table implementation was
3343 inspired by CMUCL hash tables. */
3347 1. For small tables, association lists are probably faster than
3348 hash tables because they have lower overhead.
3350 For uses of hash tables where the O(1) behavior of table
3351 operations is not a requirement, it might therefore be a good idea
3352 not to hash. Instead, we could just do a linear search in the
3353 key_and_value vector of the hash table. This could be done
3354 if a `:linear-search t' argument is given to make-hash-table. */
3357 /* The list of all weak hash tables. Don't staticpro this one. */
3359 struct Lisp_Hash_Table
*weak_hash_tables
;
3361 /* Various symbols. */
3363 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3364 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3365 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3367 /* Function prototypes. */
3369 static struct Lisp_Hash_Table
*check_hash_table (Lisp_Object
);
3370 static int get_key_arg (Lisp_Object
, int, Lisp_Object
*, char *);
3371 static void maybe_resize_hash_table (struct Lisp_Hash_Table
*);
3372 static int cmpfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3373 Lisp_Object
, unsigned);
3374 static int cmpfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3375 Lisp_Object
, unsigned);
3376 static int cmpfn_user_defined (struct Lisp_Hash_Table
*, Lisp_Object
,
3377 unsigned, Lisp_Object
, unsigned);
3378 static unsigned hashfn_eq (struct Lisp_Hash_Table
*, Lisp_Object
);
3379 static unsigned hashfn_eql (struct Lisp_Hash_Table
*, Lisp_Object
);
3380 static unsigned hashfn_equal (struct Lisp_Hash_Table
*, Lisp_Object
);
3381 static unsigned hashfn_user_defined (struct Lisp_Hash_Table
*,
3383 static unsigned sxhash_string (unsigned char *, int);
3384 static unsigned sxhash_list (Lisp_Object
, int);
3385 static unsigned sxhash_vector (Lisp_Object
, int);
3386 static unsigned sxhash_bool_vector (Lisp_Object
);
3387 static int sweep_weak_table (struct Lisp_Hash_Table
*, int);
3391 /***********************************************************************
3393 ***********************************************************************/
3395 /* If OBJ is a Lisp hash table, return a pointer to its struct
3396 Lisp_Hash_Table. Otherwise, signal an error. */
3398 static struct Lisp_Hash_Table
*
3399 check_hash_table (Lisp_Object obj
)
3401 CHECK_HASH_TABLE (obj
);
3402 return XHASH_TABLE (obj
);
3406 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3410 next_almost_prime (int n
)
3422 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3423 which USED[I] is non-zero. If found at index I in ARGS, set
3424 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3425 -1. This function is used to extract a keyword/argument pair from
3426 a DEFUN parameter list. */
3429 get_key_arg (Lisp_Object key
, int nargs
, Lisp_Object
*args
, char *used
)
3433 for (i
= 0; i
< nargs
- 1; ++i
)
3434 if (!used
[i
] && EQ (args
[i
], key
))
3449 /* Return a Lisp vector which has the same contents as VEC but has
3450 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3451 vector that are not copied from VEC are set to INIT. */
3454 larger_vector (Lisp_Object vec
, int new_size
, Lisp_Object init
)
3456 struct Lisp_Vector
*v
;
3459 xassert (VECTORP (vec
));
3460 old_size
= ASIZE (vec
);
3461 xassert (new_size
>= old_size
);
3463 v
= allocate_vector (new_size
);
3464 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3465 for (i
= old_size
; i
< new_size
; ++i
)
3466 v
->contents
[i
] = init
;
3467 XSETVECTOR (vec
, v
);
3472 /***********************************************************************
3474 ***********************************************************************/
3476 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3477 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3478 KEY2 are the same. */
3481 cmpfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3483 return (FLOATP (key1
)
3485 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3489 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3490 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3491 KEY2 are the same. */
3494 cmpfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3496 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3500 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3501 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3502 if KEY1 and KEY2 are the same. */
3505 cmpfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key1
, unsigned int hash1
, Lisp_Object key2
, unsigned int hash2
)
3509 Lisp_Object args
[3];
3511 args
[0] = h
->user_cmp_function
;
3514 return !NILP (Ffuncall (3, args
));
3521 /* Value is a hash code for KEY for use in hash table H which uses
3522 `eq' to compare keys. The hash code returned is guaranteed to fit
3523 in a Lisp integer. */
3526 hashfn_eq (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3528 unsigned hash
= XUINT (key
) ^ XTYPE (key
);
3529 xassert ((hash
& ~INTMASK
) == 0);
3534 /* Value is a hash code for KEY for use in hash table H which uses
3535 `eql' to compare keys. The hash code returned is guaranteed to fit
3536 in a Lisp integer. */
3539 hashfn_eql (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3543 hash
= sxhash (key
, 0);
3545 hash
= XUINT (key
) ^ XTYPE (key
);
3546 xassert ((hash
& ~INTMASK
) == 0);
3551 /* Value is a hash code for KEY for use in hash table H which uses
3552 `equal' to compare keys. The hash code returned is guaranteed to fit
3553 in a Lisp integer. */
3556 hashfn_equal (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3558 unsigned hash
= sxhash (key
, 0);
3559 xassert ((hash
& ~INTMASK
) == 0);
3564 /* Value is a hash code for KEY for use in hash table H which uses as
3565 user-defined function to compare keys. The hash code returned is
3566 guaranteed to fit in a Lisp integer. */
3569 hashfn_user_defined (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3571 Lisp_Object args
[2], hash
;
3573 args
[0] = h
->user_hash_function
;
3575 hash
= Ffuncall (2, args
);
3576 if (!INTEGERP (hash
))
3577 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
3578 return XUINT (hash
);
3582 /* Create and initialize a new hash table.
3584 TEST specifies the test the hash table will use to compare keys.
3585 It must be either one of the predefined tests `eq', `eql' or
3586 `equal' or a symbol denoting a user-defined test named TEST with
3587 test and hash functions USER_TEST and USER_HASH.
3589 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3591 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3592 new size when it becomes full is computed by adding REHASH_SIZE to
3593 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3594 table's new size is computed by multiplying its old size with
3597 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3598 be resized when the ratio of (number of entries in the table) /
3599 (table size) is >= REHASH_THRESHOLD.
3601 WEAK specifies the weakness of the table. If non-nil, it must be
3602 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3605 make_hash_table (Lisp_Object test
, Lisp_Object size
, Lisp_Object rehash_size
,
3606 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3607 Lisp_Object user_test
, Lisp_Object user_hash
)
3609 struct Lisp_Hash_Table
*h
;
3611 int index_size
, i
, sz
;
3613 /* Preconditions. */
3614 xassert (SYMBOLP (test
));
3615 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3616 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3617 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3618 xassert (FLOATP (rehash_threshold
)
3619 && XFLOATINT (rehash_threshold
) > 0
3620 && XFLOATINT (rehash_threshold
) <= 1.0);
3622 if (XFASTINT (size
) == 0)
3623 size
= make_number (1);
3625 /* Allocate a table and initialize it. */
3626 h
= allocate_hash_table ();
3628 /* Initialize hash table slots. */
3629 sz
= XFASTINT (size
);
3632 if (EQ (test
, Qeql
))
3634 h
->cmpfn
= cmpfn_eql
;
3635 h
->hashfn
= hashfn_eql
;
3637 else if (EQ (test
, Qeq
))
3640 h
->hashfn
= hashfn_eq
;
3642 else if (EQ (test
, Qequal
))
3644 h
->cmpfn
= cmpfn_equal
;
3645 h
->hashfn
= hashfn_equal
;
3649 h
->user_cmp_function
= user_test
;
3650 h
->user_hash_function
= user_hash
;
3651 h
->cmpfn
= cmpfn_user_defined
;
3652 h
->hashfn
= hashfn_user_defined
;
3656 h
->rehash_threshold
= rehash_threshold
;
3657 h
->rehash_size
= rehash_size
;
3659 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3660 h
->hash
= Fmake_vector (size
, Qnil
);
3661 h
->next
= Fmake_vector (size
, Qnil
);
3662 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3663 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3664 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3666 /* Set up the free list. */
3667 for (i
= 0; i
< sz
- 1; ++i
)
3668 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3669 h
->next_free
= make_number (0);
3671 XSET_HASH_TABLE (table
, h
);
3672 xassert (HASH_TABLE_P (table
));
3673 xassert (XHASH_TABLE (table
) == h
);
3675 /* Maybe add this hash table to the list of all weak hash tables. */
3677 h
->next_weak
= NULL
;
3680 h
->next_weak
= weak_hash_tables
;
3681 weak_hash_tables
= h
;
3688 /* Return a copy of hash table H1. Keys and values are not copied,
3689 only the table itself is. */
3692 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3695 struct Lisp_Hash_Table
*h2
;
3696 struct Lisp_Vector
*next
;
3698 h2
= allocate_hash_table ();
3699 next
= h2
->vec_next
;
3700 memcpy (h2
, h1
, sizeof *h2
);
3701 h2
->vec_next
= next
;
3702 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3703 h2
->hash
= Fcopy_sequence (h1
->hash
);
3704 h2
->next
= Fcopy_sequence (h1
->next
);
3705 h2
->index
= Fcopy_sequence (h1
->index
);
3706 XSET_HASH_TABLE (table
, h2
);
3708 /* Maybe add this hash table to the list of all weak hash tables. */
3709 if (!NILP (h2
->weak
))
3711 h2
->next_weak
= weak_hash_tables
;
3712 weak_hash_tables
= h2
;
3719 /* Resize hash table H if it's too full. If H cannot be resized
3720 because it's already too large, throw an error. */
3723 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3725 if (NILP (h
->next_free
))
3727 int old_size
= HASH_TABLE_SIZE (h
);
3728 int i
, new_size
, index_size
;
3731 if (INTEGERP (h
->rehash_size
))
3732 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3734 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3735 new_size
= max (old_size
+ 1, new_size
);
3736 index_size
= next_almost_prime ((int)
3738 / XFLOATINT (h
->rehash_threshold
)));
3739 /* Assignment to EMACS_INT stops GCC whining about limited range
3741 nsize
= max (index_size
, 2 * new_size
);
3742 if (nsize
> MOST_POSITIVE_FIXNUM
)
3743 error ("Hash table too large to resize");
3745 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3746 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3747 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3748 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3750 /* Update the free list. Do it so that new entries are added at
3751 the end of the free list. This makes some operations like
3753 for (i
= old_size
; i
< new_size
- 1; ++i
)
3754 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3756 if (!NILP (h
->next_free
))
3758 Lisp_Object last
, next
;
3760 last
= h
->next_free
;
3761 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3765 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3768 XSETFASTINT (h
->next_free
, old_size
);
3771 for (i
= 0; i
< old_size
; ++i
)
3772 if (!NILP (HASH_HASH (h
, i
)))
3774 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3775 int start_of_bucket
= hash_code
% ASIZE (h
->index
);
3776 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3777 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3783 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3784 the hash code of KEY. Value is the index of the entry in H
3785 matching KEY, or -1 if not found. */
3788 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, unsigned int *hash
)
3791 int start_of_bucket
;
3794 hash_code
= h
->hashfn (h
, key
);
3798 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3799 idx
= HASH_INDEX (h
, start_of_bucket
);
3801 /* We need not gcpro idx since it's either an integer or nil. */
3804 int i
= XFASTINT (idx
);
3805 if (EQ (key
, HASH_KEY (h
, i
))
3807 && h
->cmpfn (h
, key
, hash_code
,
3808 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3810 idx
= HASH_NEXT (h
, i
);
3813 return NILP (idx
) ? -1 : XFASTINT (idx
);
3817 /* Put an entry into hash table H that associates KEY with VALUE.
3818 HASH is a previously computed hash code of KEY.
3819 Value is the index of the entry in H matching KEY. */
3822 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
, unsigned int hash
)
3824 int start_of_bucket
, i
;
3826 xassert ((hash
& ~INTMASK
) == 0);
3828 /* Increment count after resizing because resizing may fail. */
3829 maybe_resize_hash_table (h
);
3832 /* Store key/value in the key_and_value vector. */
3833 i
= XFASTINT (h
->next_free
);
3834 h
->next_free
= HASH_NEXT (h
, i
);
3835 HASH_KEY (h
, i
) = key
;
3836 HASH_VALUE (h
, i
) = value
;
3838 /* Remember its hash code. */
3839 HASH_HASH (h
, i
) = make_number (hash
);
3841 /* Add new entry to its collision chain. */
3842 start_of_bucket
= hash
% ASIZE (h
->index
);
3843 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3844 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3849 /* Remove the entry matching KEY from hash table H, if there is one. */
3852 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3855 int start_of_bucket
;
3856 Lisp_Object idx
, prev
;
3858 hash_code
= h
->hashfn (h
, key
);
3859 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3860 idx
= HASH_INDEX (h
, start_of_bucket
);
3863 /* We need not gcpro idx, prev since they're either integers or nil. */
3866 int i
= XFASTINT (idx
);
3868 if (EQ (key
, HASH_KEY (h
, i
))
3870 && h
->cmpfn (h
, key
, hash_code
,
3871 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3873 /* Take entry out of collision chain. */
3875 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3877 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3879 /* Clear slots in key_and_value and add the slots to
3881 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3882 HASH_NEXT (h
, i
) = h
->next_free
;
3883 h
->next_free
= make_number (i
);
3885 xassert (h
->count
>= 0);
3891 idx
= HASH_NEXT (h
, i
);
3897 /* Clear hash table H. */
3900 hash_clear (struct Lisp_Hash_Table
*h
)
3904 int i
, size
= HASH_TABLE_SIZE (h
);
3906 for (i
= 0; i
< size
; ++i
)
3908 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3909 HASH_KEY (h
, i
) = Qnil
;
3910 HASH_VALUE (h
, i
) = Qnil
;
3911 HASH_HASH (h
, i
) = Qnil
;
3914 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
3915 ASET (h
->index
, i
, Qnil
);
3917 h
->next_free
= make_number (0);
3924 /************************************************************************
3926 ************************************************************************/
3929 init_weak_hash_tables (void)
3931 weak_hash_tables
= NULL
;
3934 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3935 entries from the table that don't survive the current GC.
3936 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3937 non-zero if anything was marked. */
3940 sweep_weak_table (struct Lisp_Hash_Table
*h
, int remove_entries_p
)
3942 int bucket
, n
, marked
;
3944 n
= ASIZE (h
->index
) & ~ARRAY_MARK_FLAG
;
3947 for (bucket
= 0; bucket
< n
; ++bucket
)
3949 Lisp_Object idx
, next
, prev
;
3951 /* Follow collision chain, removing entries that
3952 don't survive this garbage collection. */
3954 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
3956 int i
= XFASTINT (idx
);
3957 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3958 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3961 if (EQ (h
->weak
, Qkey
))
3962 remove_p
= !key_known_to_survive_p
;
3963 else if (EQ (h
->weak
, Qvalue
))
3964 remove_p
= !value_known_to_survive_p
;
3965 else if (EQ (h
->weak
, Qkey_or_value
))
3966 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3967 else if (EQ (h
->weak
, Qkey_and_value
))
3968 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3972 next
= HASH_NEXT (h
, i
);
3974 if (remove_entries_p
)
3978 /* Take out of collision chain. */
3980 HASH_INDEX (h
, bucket
) = next
;
3982 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3984 /* Add to free list. */
3985 HASH_NEXT (h
, i
) = h
->next_free
;
3988 /* Clear key, value, and hash. */
3989 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3990 HASH_HASH (h
, i
) = Qnil
;
4003 /* Make sure key and value survive. */
4004 if (!key_known_to_survive_p
)
4006 mark_object (HASH_KEY (h
, i
));
4010 if (!value_known_to_survive_p
)
4012 mark_object (HASH_VALUE (h
, i
));
4023 /* Remove elements from weak hash tables that don't survive the
4024 current garbage collection. Remove weak tables that don't survive
4025 from Vweak_hash_tables. Called from gc_sweep. */
4028 sweep_weak_hash_tables (void)
4030 struct Lisp_Hash_Table
*h
, *used
, *next
;
4033 /* Mark all keys and values that are in use. Keep on marking until
4034 there is no more change. This is necessary for cases like
4035 value-weak table A containing an entry X -> Y, where Y is used in a
4036 key-weak table B, Z -> Y. If B comes after A in the list of weak
4037 tables, X -> Y might be removed from A, although when looking at B
4038 one finds that it shouldn't. */
4042 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4044 if (h
->size
& ARRAY_MARK_FLAG
)
4045 marked
|= sweep_weak_table (h
, 0);
4050 /* Remove tables and entries that aren't used. */
4051 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4053 next
= h
->next_weak
;
4055 if (h
->size
& ARRAY_MARK_FLAG
)
4057 /* TABLE is marked as used. Sweep its contents. */
4059 sweep_weak_table (h
, 1);
4061 /* Add table to the list of used weak hash tables. */
4062 h
->next_weak
= used
;
4067 weak_hash_tables
= used
;
4072 /***********************************************************************
4073 Hash Code Computation
4074 ***********************************************************************/
4076 /* Maximum depth up to which to dive into Lisp structures. */
4078 #define SXHASH_MAX_DEPTH 3
4080 /* Maximum length up to which to take list and vector elements into
4083 #define SXHASH_MAX_LEN 7
4085 /* Combine two integers X and Y for hashing. */
4087 #define SXHASH_COMBINE(X, Y) \
4088 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4092 /* Return a hash for string PTR which has length LEN. The hash
4093 code returned is guaranteed to fit in a Lisp integer. */
4096 sxhash_string (unsigned char *ptr
, int len
)
4098 unsigned char *p
= ptr
;
4099 unsigned char *end
= p
+ len
;
4108 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
4111 return hash
& INTMASK
;
4115 /* Return a hash for list LIST. DEPTH is the current depth in the
4116 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4119 sxhash_list (Lisp_Object list
, int depth
)
4124 if (depth
< SXHASH_MAX_DEPTH
)
4126 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4127 list
= XCDR (list
), ++i
)
4129 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4130 hash
= SXHASH_COMBINE (hash
, hash2
);
4135 unsigned hash2
= sxhash (list
, depth
+ 1);
4136 hash
= SXHASH_COMBINE (hash
, hash2
);
4143 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4144 the Lisp structure. */
4147 sxhash_vector (Lisp_Object vec
, int depth
)
4149 unsigned hash
= ASIZE (vec
);
4152 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4153 for (i
= 0; i
< n
; ++i
)
4155 unsigned hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4156 hash
= SXHASH_COMBINE (hash
, hash2
);
4163 /* Return a hash for bool-vector VECTOR. */
4166 sxhash_bool_vector (Lisp_Object vec
)
4168 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4171 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4172 for (i
= 0; i
< n
; ++i
)
4173 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4179 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4180 structure. Value is an unsigned integer clipped to INTMASK. */
4183 sxhash (Lisp_Object obj
, int depth
)
4187 if (depth
> SXHASH_MAX_DEPTH
)
4190 switch (XTYPE (obj
))
4201 obj
= SYMBOL_NAME (obj
);
4205 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4208 /* This can be everything from a vector to an overlay. */
4209 case Lisp_Vectorlike
:
4211 /* According to the CL HyperSpec, two arrays are equal only if
4212 they are `eq', except for strings and bit-vectors. In
4213 Emacs, this works differently. We have to compare element
4215 hash
= sxhash_vector (obj
, depth
);
4216 else if (BOOL_VECTOR_P (obj
))
4217 hash
= sxhash_bool_vector (obj
);
4219 /* Others are `equal' if they are `eq', so let's take their
4225 hash
= sxhash_list (obj
, depth
);
4230 double val
= XFLOAT_DATA (obj
);
4231 unsigned char *p
= (unsigned char *) &val
;
4232 unsigned char *e
= p
+ sizeof val
;
4233 for (hash
= 0; p
< e
; ++p
)
4234 hash
= SXHASH_COMBINE (hash
, *p
);
4242 return hash
& INTMASK
;
4247 /***********************************************************************
4249 ***********************************************************************/
4252 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4253 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4256 unsigned hash
= sxhash (obj
, 0);
4257 return make_number (hash
);
4261 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4262 doc
: /* Create and return a new hash table.
4264 Arguments are specified as keyword/argument pairs. The following
4265 arguments are defined:
4267 :test TEST -- TEST must be a symbol that specifies how to compare
4268 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4269 `equal'. User-supplied test and hash functions can be specified via
4270 `define-hash-table-test'.
4272 :size SIZE -- A hint as to how many elements will be put in the table.
4275 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4276 fills up. If REHASH-SIZE is an integer, increase the size by that
4277 amount. If it is a float, it must be > 1.0, and the new size is the
4278 old size multiplied by that factor. Default is 1.5.
4280 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4281 Resize the hash table when the ratio (number of entries / table size)
4282 is greater than or equal to THRESHOLD. Default is 0.8.
4284 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4285 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4286 returned is a weak table. Key/value pairs are removed from a weak
4287 hash table when there are no non-weak references pointing to their
4288 key, value, one of key or value, or both key and value, depending on
4289 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4292 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4293 (int nargs
, Lisp_Object
*args
)
4295 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4296 Lisp_Object user_test
, user_hash
;
4300 /* The vector `used' is used to keep track of arguments that
4301 have been consumed. */
4302 used
= (char *) alloca (nargs
* sizeof *used
);
4303 memset (used
, 0, nargs
* sizeof *used
);
4305 /* See if there's a `:test TEST' among the arguments. */
4306 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4307 test
= i
< 0 ? Qeql
: args
[i
];
4308 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4310 /* See if it is a user-defined test. */
4313 prop
= Fget (test
, Qhash_table_test
);
4314 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4315 signal_error ("Invalid hash table test", test
);
4316 user_test
= XCAR (prop
);
4317 user_hash
= XCAR (XCDR (prop
));
4320 user_test
= user_hash
= Qnil
;
4322 /* See if there's a `:size SIZE' argument. */
4323 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4324 size
= i
< 0 ? Qnil
: args
[i
];
4326 size
= make_number (DEFAULT_HASH_SIZE
);
4327 else if (!INTEGERP (size
) || XINT (size
) < 0)
4328 signal_error ("Invalid hash table size", size
);
4330 /* Look for `:rehash-size SIZE'. */
4331 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4332 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4333 if (!NUMBERP (rehash_size
)
4334 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4335 || XFLOATINT (rehash_size
) <= 1.0)
4336 signal_error ("Invalid hash table rehash size", rehash_size
);
4338 /* Look for `:rehash-threshold THRESHOLD'. */
4339 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4340 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4341 if (!FLOATP (rehash_threshold
)
4342 || XFLOATINT (rehash_threshold
) <= 0.0
4343 || XFLOATINT (rehash_threshold
) > 1.0)
4344 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4346 /* Look for `:weakness WEAK'. */
4347 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4348 weak
= i
< 0 ? Qnil
: args
[i
];
4350 weak
= Qkey_and_value
;
4353 && !EQ (weak
, Qvalue
)
4354 && !EQ (weak
, Qkey_or_value
)
4355 && !EQ (weak
, Qkey_and_value
))
4356 signal_error ("Invalid hash table weakness", weak
);
4358 /* Now, all args should have been used up, or there's a problem. */
4359 for (i
= 0; i
< nargs
; ++i
)
4361 signal_error ("Invalid argument list", args
[i
]);
4363 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4364 user_test
, user_hash
);
4368 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4369 doc
: /* Return a copy of hash table TABLE. */)
4372 return copy_hash_table (check_hash_table (table
));
4376 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4377 doc
: /* Return the number of elements in TABLE. */)
4380 return make_number (check_hash_table (table
)->count
);
4384 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4385 Shash_table_rehash_size
, 1, 1, 0,
4386 doc
: /* Return the current rehash size of TABLE. */)
4389 return check_hash_table (table
)->rehash_size
;
4393 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4394 Shash_table_rehash_threshold
, 1, 1, 0,
4395 doc
: /* Return the current rehash threshold of TABLE. */)
4398 return check_hash_table (table
)->rehash_threshold
;
4402 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4403 doc
: /* Return the size of TABLE.
4404 The size can be used as an argument to `make-hash-table' to create
4405 a hash table than can hold as many elements as TABLE holds
4406 without need for resizing. */)
4409 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4410 return make_number (HASH_TABLE_SIZE (h
));
4414 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4415 doc
: /* Return the test TABLE uses. */)
4418 return check_hash_table (table
)->test
;
4422 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4424 doc
: /* Return the weakness of TABLE. */)
4427 return check_hash_table (table
)->weak
;
4431 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4432 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4435 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4439 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4440 doc
: /* Clear hash table TABLE and return it. */)
4443 hash_clear (check_hash_table (table
));
4444 /* Be compatible with XEmacs. */
4449 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4450 doc
: /* Look up KEY in TABLE and return its associated value.
4451 If KEY is not found, return DFLT which defaults to nil. */)
4452 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4454 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4455 int i
= hash_lookup (h
, key
, NULL
);
4456 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4460 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4461 doc
: /* Associate KEY with VALUE in hash table TABLE.
4462 If KEY is already present in table, replace its current value with
4464 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4466 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4470 i
= hash_lookup (h
, key
, &hash
);
4472 HASH_VALUE (h
, i
) = value
;
4474 hash_put (h
, key
, value
, hash
);
4480 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4481 doc
: /* Remove KEY from TABLE. */)
4482 (Lisp_Object key
, Lisp_Object table
)
4484 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4485 hash_remove_from_table (h
, key
);
4490 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4491 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4492 FUNCTION is called with two arguments, KEY and VALUE. */)
4493 (Lisp_Object function
, Lisp_Object table
)
4495 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4496 Lisp_Object args
[3];
4499 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4500 if (!NILP (HASH_HASH (h
, i
)))
4503 args
[1] = HASH_KEY (h
, i
);
4504 args
[2] = HASH_VALUE (h
, i
);
4512 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4513 Sdefine_hash_table_test
, 3, 3, 0,
4514 doc
: /* Define a new hash table test with name NAME, a symbol.
4516 In hash tables created with NAME specified as test, use TEST to
4517 compare keys, and HASH for computing hash codes of keys.
4519 TEST must be a function taking two arguments and returning non-nil if
4520 both arguments are the same. HASH must be a function taking one
4521 argument and return an integer that is the hash code of the argument.
4522 Hash code computation should use the whole value range of integers,
4523 including negative integers. */)
4524 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4526 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4531 /************************************************************************
4533 ************************************************************************/
4537 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4538 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4540 A message digest is a cryptographic checksum of a document, and the
4541 algorithm to calculate it is defined in RFC 1321.
4543 The two optional arguments START and END are character positions
4544 specifying for which part of OBJECT the message digest should be
4545 computed. If nil or omitted, the digest is computed for the whole
4548 The MD5 message digest is computed from the result of encoding the
4549 text in a coding system, not directly from the internal Emacs form of
4550 the text. The optional fourth argument CODING-SYSTEM specifies which
4551 coding system to encode the text with. It should be the same coding
4552 system that you used or will use when actually writing the text into a
4555 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4556 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4557 system would be chosen by default for writing this text into a file.
4559 If OBJECT is a string, the most preferred coding system (see the
4560 command `prefer-coding-system') is used.
4562 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4563 guesswork fails. Normally, an error is signaled in such case. */)
4564 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4566 unsigned char digest
[16];
4570 EMACS_INT size_byte
= 0;
4571 EMACS_INT start_char
= 0, end_char
= 0;
4572 EMACS_INT start_byte
= 0, end_byte
= 0;
4573 register EMACS_INT b
, e
;
4574 register struct buffer
*bp
;
4577 if (STRINGP (object
))
4579 if (NILP (coding_system
))
4581 /* Decide the coding-system to encode the data with. */
4583 if (STRING_MULTIBYTE (object
))
4584 /* use default, we can't guess correct value */
4585 coding_system
= preferred_coding_system ();
4587 coding_system
= Qraw_text
;
4590 if (NILP (Fcoding_system_p (coding_system
)))
4592 /* Invalid coding system. */
4594 if (!NILP (noerror
))
4595 coding_system
= Qraw_text
;
4597 xsignal1 (Qcoding_system_error
, coding_system
);
4600 if (STRING_MULTIBYTE (object
))
4601 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4603 size
= SCHARS (object
);
4604 size_byte
= SBYTES (object
);
4608 CHECK_NUMBER (start
);
4610 start_char
= XINT (start
);
4615 start_byte
= string_char_to_byte (object
, start_char
);
4621 end_byte
= size_byte
;
4627 end_char
= XINT (end
);
4632 end_byte
= string_char_to_byte (object
, end_char
);
4635 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4636 args_out_of_range_3 (object
, make_number (start_char
),
4637 make_number (end_char
));
4641 struct buffer
*prev
= current_buffer
;
4643 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4645 CHECK_BUFFER (object
);
4647 bp
= XBUFFER (object
);
4648 if (bp
!= current_buffer
)
4649 set_buffer_internal (bp
);
4655 CHECK_NUMBER_COERCE_MARKER (start
);
4663 CHECK_NUMBER_COERCE_MARKER (end
);
4668 temp
= b
, b
= e
, e
= temp
;
4670 if (!(BEGV
<= b
&& e
<= ZV
))
4671 args_out_of_range (start
, end
);
4673 if (NILP (coding_system
))
4675 /* Decide the coding-system to encode the data with.
4676 See fileio.c:Fwrite-region */
4678 if (!NILP (Vcoding_system_for_write
))
4679 coding_system
= Vcoding_system_for_write
;
4682 int force_raw_text
= 0;
4684 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4685 if (NILP (coding_system
)
4686 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4688 coding_system
= Qnil
;
4689 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4693 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4695 /* Check file-coding-system-alist. */
4696 Lisp_Object args
[4], val
;
4698 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4699 args
[3] = Fbuffer_file_name(object
);
4700 val
= Ffind_operation_coding_system (4, args
);
4701 if (CONSP (val
) && !NILP (XCDR (val
)))
4702 coding_system
= XCDR (val
);
4705 if (NILP (coding_system
)
4706 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4708 /* If we still have not decided a coding system, use the
4709 default value of buffer-file-coding-system. */
4710 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4714 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4715 /* Confirm that VAL can surely encode the current region. */
4716 coding_system
= call4 (Vselect_safe_coding_system_function
,
4717 make_number (b
), make_number (e
),
4718 coding_system
, Qnil
);
4721 coding_system
= Qraw_text
;
4724 if (NILP (Fcoding_system_p (coding_system
)))
4726 /* Invalid coding system. */
4728 if (!NILP (noerror
))
4729 coding_system
= Qraw_text
;
4731 xsignal1 (Qcoding_system_error
, coding_system
);
4735 object
= make_buffer_string (b
, e
, 0);
4736 if (prev
!= current_buffer
)
4737 set_buffer_internal (prev
);
4738 /* Discard the unwind protect for recovering the current
4742 if (STRING_MULTIBYTE (object
))
4743 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4746 md5_buffer (SSDATA (object
) + start_byte
,
4747 SBYTES (object
) - (size_byte
- end_byte
),
4750 for (i
= 0; i
< 16; i
++)
4751 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4754 return make_string (value
, 32);
4761 /* Hash table stuff. */
4762 Qhash_table_p
= intern_c_string ("hash-table-p");
4763 staticpro (&Qhash_table_p
);
4764 Qeq
= intern_c_string ("eq");
4766 Qeql
= intern_c_string ("eql");
4768 Qequal
= intern_c_string ("equal");
4769 staticpro (&Qequal
);
4770 QCtest
= intern_c_string (":test");
4771 staticpro (&QCtest
);
4772 QCsize
= intern_c_string (":size");
4773 staticpro (&QCsize
);
4774 QCrehash_size
= intern_c_string (":rehash-size");
4775 staticpro (&QCrehash_size
);
4776 QCrehash_threshold
= intern_c_string (":rehash-threshold");
4777 staticpro (&QCrehash_threshold
);
4778 QCweakness
= intern_c_string (":weakness");
4779 staticpro (&QCweakness
);
4780 Qkey
= intern_c_string ("key");
4782 Qvalue
= intern_c_string ("value");
4783 staticpro (&Qvalue
);
4784 Qhash_table_test
= intern_c_string ("hash-table-test");
4785 staticpro (&Qhash_table_test
);
4786 Qkey_or_value
= intern_c_string ("key-or-value");
4787 staticpro (&Qkey_or_value
);
4788 Qkey_and_value
= intern_c_string ("key-and-value");
4789 staticpro (&Qkey_and_value
);
4792 defsubr (&Smake_hash_table
);
4793 defsubr (&Scopy_hash_table
);
4794 defsubr (&Shash_table_count
);
4795 defsubr (&Shash_table_rehash_size
);
4796 defsubr (&Shash_table_rehash_threshold
);
4797 defsubr (&Shash_table_size
);
4798 defsubr (&Shash_table_test
);
4799 defsubr (&Shash_table_weakness
);
4800 defsubr (&Shash_table_p
);
4801 defsubr (&Sclrhash
);
4802 defsubr (&Sgethash
);
4803 defsubr (&Sputhash
);
4804 defsubr (&Sremhash
);
4805 defsubr (&Smaphash
);
4806 defsubr (&Sdefine_hash_table_test
);
4808 Qstring_lessp
= intern_c_string ("string-lessp");
4809 staticpro (&Qstring_lessp
);
4810 Qprovide
= intern_c_string ("provide");
4811 staticpro (&Qprovide
);
4812 Qrequire
= intern_c_string ("require");
4813 staticpro (&Qrequire
);
4814 Qyes_or_no_p_history
= intern_c_string ("yes-or-no-p-history");
4815 staticpro (&Qyes_or_no_p_history
);
4816 Qcursor_in_echo_area
= intern_c_string ("cursor-in-echo-area");
4817 staticpro (&Qcursor_in_echo_area
);
4818 Qwidget_type
= intern_c_string ("widget-type");
4819 staticpro (&Qwidget_type
);
4821 staticpro (&string_char_byte_cache_string
);
4822 string_char_byte_cache_string
= Qnil
;
4824 require_nesting_list
= Qnil
;
4825 staticpro (&require_nesting_list
);
4827 Fset (Qyes_or_no_p_history
, Qnil
);
4829 DEFVAR_LISP ("features", Vfeatures
,
4830 doc
: /* A list of symbols which are the features of the executing Emacs.
4831 Used by `featurep' and `require', and altered by `provide'. */);
4832 Vfeatures
= Fcons (intern_c_string ("emacs"), Qnil
);
4833 Qsubfeatures
= intern_c_string ("subfeatures");
4834 staticpro (&Qsubfeatures
);
4836 #ifdef HAVE_LANGINFO_CODESET
4837 Qcodeset
= intern_c_string ("codeset");
4838 staticpro (&Qcodeset
);
4839 Qdays
= intern_c_string ("days");
4841 Qmonths
= intern_c_string ("months");
4842 staticpro (&Qmonths
);
4843 Qpaper
= intern_c_string ("paper");
4844 staticpro (&Qpaper
);
4845 #endif /* HAVE_LANGINFO_CODESET */
4847 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
4848 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4849 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
4850 invoked by mouse clicks and mouse menu items.
4852 On some platforms, file selection dialogs are also enabled if this is
4856 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
4857 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
4858 This applies to commands from menus and tool bar buttons even when
4859 they are initiated from the keyboard. If `use-dialog-box' is nil,
4860 that disables the use of a file dialog, regardless of the value of
4862 use_file_dialog
= 1;
4864 defsubr (&Sidentity
);
4867 defsubr (&Ssafe_length
);
4868 defsubr (&Sstring_bytes
);
4869 defsubr (&Sstring_equal
);
4870 defsubr (&Scompare_strings
);
4871 defsubr (&Sstring_lessp
);
4874 defsubr (&Svconcat
);
4875 defsubr (&Scopy_sequence
);
4876 defsubr (&Sstring_make_multibyte
);
4877 defsubr (&Sstring_make_unibyte
);
4878 defsubr (&Sstring_as_multibyte
);
4879 defsubr (&Sstring_as_unibyte
);
4880 defsubr (&Sstring_to_multibyte
);
4881 defsubr (&Sstring_to_unibyte
);
4882 defsubr (&Scopy_alist
);
4883 defsubr (&Ssubstring
);
4884 defsubr (&Ssubstring_no_properties
);
4897 defsubr (&Snreverse
);
4898 defsubr (&Sreverse
);
4900 defsubr (&Splist_get
);
4902 defsubr (&Splist_put
);
4904 defsubr (&Slax_plist_get
);
4905 defsubr (&Slax_plist_put
);
4908 defsubr (&Sequal_including_properties
);
4909 defsubr (&Sfillarray
);
4910 defsubr (&Sclear_string
);
4914 defsubr (&Smapconcat
);
4915 defsubr (&Syes_or_no_p
);
4916 defsubr (&Sload_average
);
4917 defsubr (&Sfeaturep
);
4918 defsubr (&Srequire
);
4919 defsubr (&Sprovide
);
4920 defsubr (&Splist_member
);
4921 defsubr (&Swidget_put
);
4922 defsubr (&Swidget_get
);
4923 defsubr (&Swidget_apply
);
4924 defsubr (&Sbase64_encode_region
);
4925 defsubr (&Sbase64_decode_region
);
4926 defsubr (&Sbase64_encode_string
);
4927 defsubr (&Sbase64_decode_string
);
4929 defsubr (&Slocale_info
);