1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 02, 2003
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 2, or (at your option)
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; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* On Mac OS X, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
41 #include "character.h"
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 /* Nonzero enables use of a file dialog for file name
63 questions asked by mouse commands. */
66 extern int minibuffer_auto_raise
;
67 extern Lisp_Object minibuf_window
;
68 extern Lisp_Object Vlocale_coding_system
;
70 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
71 Lisp_Object Qyes_or_no_p_history
;
72 Lisp_Object Qcursor_in_echo_area
;
73 Lisp_Object Qwidget_type
;
74 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
76 extern Lisp_Object Qinput_method_function
;
78 static int internal_equal ();
80 extern long get_random ();
81 extern void seed_random ();
87 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
88 doc
: /* Return the argument unchanged. */)
95 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
96 doc
: /* Return a pseudo-random number.
97 All integers representable in Lisp are equally likely.
98 On most systems, this is 29 bits' worth.
99 With positive integer argument N, return random number in interval [0,N).
100 With argument t, set the random number seed from the current time and pid. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (n
) && XFASTINT (n
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (n
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
145 if (STRINGP (sequence
))
146 XSETFASTINT (val
, SCHARS (sequence
));
147 else if (VECTORP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
149 else if (CHAR_TABLE_P (sequence
))
150 XSETFASTINT (val
, MAX_CHAR
);
151 else if (BOOL_VECTOR_P (sequence
))
152 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
153 else if (COMPILEDP (sequence
))
154 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
155 else if (CONSP (sequence
))
158 while (CONSP (sequence
))
160 sequence
= XCDR (sequence
);
163 if (!CONSP (sequence
))
166 sequence
= XCDR (sequence
);
171 if (!NILP (sequence
))
172 wrong_type_argument (Qlistp
, sequence
);
174 val
= make_number (i
);
176 else if (NILP (sequence
))
177 XSETFASTINT (val
, 0);
180 sequence
= wrong_type_argument (Qsequencep
, sequence
);
186 /* This does not check for quits. That is safe
187 since it must terminate. */
189 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
190 doc
: /* Return the length of a list, but avoid error or infinite loop.
191 This function never gets an error. If LIST is not really a list,
192 it returns 0. If LIST is circular, it returns a finite value
193 which is at least the number of distinct elements. */)
197 Lisp_Object tail
, halftail
, length
;
200 /* halftail is used to detect circular lists. */
202 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
204 if (EQ (tail
, halftail
) && len
!= 0)
208 halftail
= XCDR (halftail
);
211 XSETINT (length
, len
);
215 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
216 doc
: /* Return the number of bytes in STRING.
217 If STRING is a multibyte string, this is greater than the length of STRING. */)
221 CHECK_STRING (string
);
222 return make_number (SBYTES (string
));
225 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
226 doc
: /* Return t if two strings have identical contents.
227 Case is significant, but text properties are ignored.
228 Symbols are also allowed; their print names are used instead. */)
230 register Lisp_Object s1
, s2
;
233 s1
= SYMBOL_NAME (s1
);
235 s2
= SYMBOL_NAME (s2
);
239 if (SCHARS (s1
) != SCHARS (s2
)
240 || SBYTES (s1
) != SBYTES (s2
)
241 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
246 DEFUN ("compare-strings", Fcompare_strings
,
247 Scompare_strings
, 6, 7, 0,
248 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
249 In string STR1, skip the first START1 characters and stop at END1.
250 In string STR2, skip the first START2 characters and stop at END2.
251 END1 and END2 default to the full lengths of the respective strings.
253 Case is significant in this comparison if IGNORE-CASE is nil.
254 Unibyte strings are converted to multibyte for comparison.
256 The value is t if the strings (or specified portions) match.
257 If string STR1 is less, the value is a negative number N;
258 - 1 - N is the number of characters that match at the beginning.
259 If string STR1 is greater, the value is a positive number N;
260 N - 1 is the number of characters that match at the beginning. */)
261 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
262 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
264 register int end1_char
, end2_char
;
265 register int i1
, i1_byte
, i2
, i2_byte
;
270 start1
= make_number (0);
272 start2
= make_number (0);
273 CHECK_NATNUM (start1
);
274 CHECK_NATNUM (start2
);
283 i1_byte
= string_char_to_byte (str1
, i1
);
284 i2_byte
= string_char_to_byte (str2
, i2
);
286 end1_char
= SCHARS (str1
);
287 if (! NILP (end1
) && end1_char
> XINT (end1
))
288 end1_char
= XINT (end1
);
290 end2_char
= SCHARS (str2
);
291 if (! NILP (end2
) && end2_char
> XINT (end2
))
292 end2_char
= XINT (end2
);
294 while (i1
< end1_char
&& i2
< end2_char
)
296 /* When we find a mismatch, we must compare the
297 characters, not just the bytes. */
300 if (STRING_MULTIBYTE (str1
))
301 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
304 c1
= SREF (str1
, i1
++);
305 c1
= unibyte_char_to_multibyte (c1
);
308 if (STRING_MULTIBYTE (str2
))
309 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
312 c2
= SREF (str2
, i2
++);
313 c2
= unibyte_char_to_multibyte (c2
);
319 if (! NILP (ignore_case
))
323 tem
= Fupcase (make_number (c1
));
325 tem
= Fupcase (make_number (c2
));
332 /* Note that I1 has already been incremented
333 past the character that we are comparing;
334 hence we don't add or subtract 1 here. */
336 return make_number (- i1
+ XINT (start1
));
338 return make_number (i1
- XINT (start1
));
342 return make_number (i1
- XINT (start1
) + 1);
344 return make_number (- i1
+ XINT (start1
) - 1);
349 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
350 doc
: /* Return t if first arg string is less than second in lexicographic order.
352 Symbols are also allowed; their print names are used instead. */)
354 register Lisp_Object s1
, s2
;
357 register int i1
, i1_byte
, i2
, i2_byte
;
360 s1
= SYMBOL_NAME (s1
);
362 s2
= SYMBOL_NAME (s2
);
366 i1
= i1_byte
= i2
= i2_byte
= 0;
369 if (end
> SCHARS (s2
))
374 /* When we find a mismatch, we must compare the
375 characters, not just the bytes. */
378 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
379 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
382 return c1
< c2
? Qt
: Qnil
;
384 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
387 static Lisp_Object
concat ();
398 return concat (2, args
, Lisp_String
, 0);
400 return concat (2, &s1
, Lisp_String
, 0);
401 #endif /* NO_ARG_ARRAY */
407 Lisp_Object s1
, s2
, s3
;
414 return concat (3, args
, Lisp_String
, 0);
416 return concat (3, &s1
, Lisp_String
, 0);
417 #endif /* NO_ARG_ARRAY */
420 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
421 doc
: /* Concatenate all the arguments and make the result a list.
422 The result is a list whose elements are the elements of all the arguments.
423 Each argument may be a list, vector or string.
424 The last argument is not copied, just used as the tail of the new list.
425 usage: (append &rest SEQUENCES) */)
430 return concat (nargs
, args
, Lisp_Cons
, 1);
433 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
434 doc
: /* Concatenate all the arguments and make the result a string.
435 The result is a string whose elements are the elements of all the arguments.
436 Each argument may be a string or a list or vector of characters (integers).
437 usage: (concat &rest SEQUENCES) */)
442 return concat (nargs
, args
, Lisp_String
, 0);
445 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
446 doc
: /* Concatenate all the arguments and make the result a vector.
447 The result is a vector whose elements are the elements of all the arguments.
448 Each argument may be a list, vector or string.
449 usage: (vconcat &rest SEQUENCES) */)
454 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
458 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
459 doc
: /* Return a copy of a list, vector, string or char-table.
460 The elements of a list or vector are not copied; they are shared
461 with the original. */)
465 if (NILP (arg
)) return arg
;
467 if (CHAR_TABLE_P (arg
))
469 return copy_char_table (arg
);
472 if (BOOL_VECTOR_P (arg
))
476 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
478 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
479 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
484 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
485 arg
= wrong_type_argument (Qsequencep
, arg
);
486 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
490 /* In string STR of length LEN, see if bytes before STR[I] combine
491 with bytes after STR[I] to form a single character. If so, return
492 the number of bytes after STR[I] which combine in this way.
493 Otherwize, return 0. */
496 count_combining (str
, len
, i
)
500 int j
= i
- 1, bytes
;
502 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
504 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
505 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
507 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
508 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
512 /* This structure holds information of an argument of `concat' that is
513 a string and has text properties to be copied. */
516 int argnum
; /* refer to ARGS (arguments of `concat') */
517 int from
; /* refer to ARGS[argnum] (argument string) */
518 int to
; /* refer to VAL (the target string) */
522 concat (nargs
, args
, target_type
, last_special
)
525 enum Lisp_Type target_type
;
529 register Lisp_Object tail
;
530 register Lisp_Object
this;
532 int toindex_byte
= 0;
533 register int result_len
;
534 register int result_len_byte
;
536 Lisp_Object last_tail
;
539 /* When we make a multibyte string, we can't copy text properties
540 while concatinating each string because the length of resulting
541 string can't be decided until we finish the whole concatination.
542 So, we record strings that have text properties to be copied
543 here, and copy the text properties after the concatination. */
544 struct textprop_rec
*textprops
= NULL
;
545 /* Number of elments in textprops. */
546 int num_textprops
= 0;
550 /* In append, the last arg isn't treated like the others */
551 if (last_special
&& nargs
> 0)
554 last_tail
= args
[nargs
];
559 /* Canonicalize each argument. */
560 for (argnum
= 0; argnum
< nargs
; argnum
++)
563 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
564 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
566 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
570 /* Compute total length in chars of arguments in RESULT_LEN.
571 If desired output is a string, also compute length in bytes
572 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
573 whether the result should be a multibyte string. */
577 for (argnum
= 0; argnum
< nargs
; argnum
++)
581 len
= XFASTINT (Flength (this));
582 if (target_type
== Lisp_String
)
584 /* We must count the number of bytes needed in the string
585 as well as the number of characters. */
591 for (i
= 0; i
< len
; i
++)
593 ch
= XVECTOR (this)->contents
[i
];
594 if (! CHARACTERP (ch
))
595 wrong_type_argument (Qcharacterp
, ch
);
596 this_len_byte
= CHAR_BYTES (XINT (ch
));
597 result_len_byte
+= this_len_byte
;
598 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
601 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
602 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
603 else if (CONSP (this))
604 for (; CONSP (this); this = XCDR (this))
607 if (! CHARACTERP (ch
))
608 wrong_type_argument (Qcharacterp
, ch
);
609 this_len_byte
= CHAR_BYTES (XINT (ch
));
610 result_len_byte
+= this_len_byte
;
611 if (! ASCII_CHAR_P (XINT (ch
)) && ! CHAR_BYTE8_P (XINT (ch
)))
614 else if (STRINGP (this))
616 if (STRING_MULTIBYTE (this))
619 result_len_byte
+= SBYTES (this);
622 result_len_byte
+= count_size_as_multibyte (SDATA (this),
630 if (! some_multibyte
)
631 result_len_byte
= result_len
;
633 /* Create the output object. */
634 if (target_type
== Lisp_Cons
)
635 val
= Fmake_list (make_number (result_len
), Qnil
);
636 else if (target_type
== Lisp_Vectorlike
)
637 val
= Fmake_vector (make_number (result_len
), Qnil
);
638 else if (some_multibyte
)
639 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
641 val
= make_uninit_string (result_len
);
643 /* In `append', if all but last arg are nil, return last arg. */
644 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
647 /* Copy the contents of the args into the result. */
649 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
651 toindex
= 0, toindex_byte
= 0;
656 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
658 for (argnum
= 0; argnum
< nargs
; argnum
++)
662 register unsigned int thisindex
= 0;
663 register unsigned int thisindex_byte
= 0;
667 thislen
= Flength (this), thisleni
= XINT (thislen
);
669 /* Between strings of the same kind, copy fast. */
670 if (STRINGP (this) && STRINGP (val
)
671 && STRING_MULTIBYTE (this) == some_multibyte
)
673 int thislen_byte
= SBYTES (this);
675 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
677 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
679 textprops
[num_textprops
].argnum
= argnum
;
680 textprops
[num_textprops
].from
= 0;
681 textprops
[num_textprops
++].to
= toindex
;
683 toindex_byte
+= thislen_byte
;
686 /* Copy a single-byte string to a multibyte string. */
687 else if (STRINGP (this) && STRINGP (val
))
689 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
691 textprops
[num_textprops
].argnum
= argnum
;
692 textprops
[num_textprops
].from
= 0;
693 textprops
[num_textprops
++].to
= toindex
;
695 toindex_byte
+= copy_text (SDATA (this),
696 SDATA (val
) + toindex_byte
,
697 SCHARS (this), 0, 1);
701 /* Copy element by element. */
704 register Lisp_Object elt
;
706 /* Fetch next element of `this' arg into `elt', or break if
707 `this' is exhausted. */
708 if (NILP (this)) break;
710 elt
= XCAR (this), this = XCDR (this);
711 else if (thisindex
>= thisleni
)
713 else if (STRINGP (this))
716 if (STRING_MULTIBYTE (this))
718 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
721 XSETFASTINT (elt
, c
);
725 XSETFASTINT (elt
, SREF (this, thisindex
++));
727 && XINT (elt
) >= 0200
728 && XINT (elt
) < 0400)
730 c
= unibyte_char_to_multibyte (XINT (elt
));
735 else if (BOOL_VECTOR_P (this))
738 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
739 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
746 elt
= XVECTOR (this)->contents
[thisindex
++];
748 /* Store this element into the result. */
755 else if (VECTORP (val
))
756 XVECTOR (val
)->contents
[toindex
++] = elt
;
761 toindex_byte
+= CHAR_STRING (XINT (elt
),
762 SDATA (val
) + toindex_byte
);
764 SSET (val
, toindex_byte
++, XINT (elt
));
770 XSETCDR (prev
, last_tail
);
772 if (num_textprops
> 0)
775 int last_to_end
= -1;
777 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
779 this = args
[textprops
[argnum
].argnum
];
780 props
= text_property_list (this,
782 make_number (SCHARS (this)),
784 /* If successive arguments have properites, be sure that the
785 value of `composition' property be the copy. */
786 if (last_to_end
== textprops
[argnum
].to
)
787 make_composition_value_copy (props
);
788 add_text_properties_from_list (val
, props
,
789 make_number (textprops
[argnum
].to
));
790 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
796 static Lisp_Object string_char_byte_cache_string
;
797 static int string_char_byte_cache_charpos
;
798 static int string_char_byte_cache_bytepos
;
801 clear_string_char_byte_cache ()
803 string_char_byte_cache_string
= Qnil
;
806 /* Return the character index corresponding to CHAR_INDEX in STRING. */
809 string_char_to_byte (string
, char_index
)
814 int best_below
, best_below_byte
;
815 int best_above
, best_above_byte
;
817 best_below
= best_below_byte
= 0;
818 best_above
= SCHARS (string
);
819 best_above_byte
= SBYTES (string
);
820 if (best_above
== best_above_byte
)
823 if (EQ (string
, string_char_byte_cache_string
))
825 if (string_char_byte_cache_charpos
< char_index
)
827 best_below
= string_char_byte_cache_charpos
;
828 best_below_byte
= string_char_byte_cache_bytepos
;
832 best_above
= string_char_byte_cache_charpos
;
833 best_above_byte
= string_char_byte_cache_bytepos
;
837 if (char_index
- best_below
< best_above
- char_index
)
839 unsigned char *p
= SDATA (string
) + best_below_byte
;
841 while (best_below
< char_index
)
843 p
+= BYTES_BY_CHAR_HEAD (*p
);
846 i_byte
= p
- SDATA (string
);
850 unsigned char *p
= SDATA (string
) + best_above_byte
;
852 while (best_above
> char_index
)
855 while (!CHAR_HEAD_P (*p
)) p
--;
858 i_byte
= p
- SDATA (string
);
861 string_char_byte_cache_bytepos
= i_byte
;
862 string_char_byte_cache_charpos
= char_index
;
863 string_char_byte_cache_string
= string
;
868 /* Return the character index corresponding to BYTE_INDEX in STRING. */
871 string_byte_to_char (string
, byte_index
)
876 int best_below
, best_below_byte
;
877 int best_above
, best_above_byte
;
879 best_below
= best_below_byte
= 0;
880 best_above
= SCHARS (string
);
881 best_above_byte
= SBYTES (string
);
882 if (best_above
== best_above_byte
)
885 if (EQ (string
, string_char_byte_cache_string
))
887 if (string_char_byte_cache_bytepos
< byte_index
)
889 best_below
= string_char_byte_cache_charpos
;
890 best_below_byte
= string_char_byte_cache_bytepos
;
894 best_above
= string_char_byte_cache_charpos
;
895 best_above_byte
= string_char_byte_cache_bytepos
;
899 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
901 unsigned char *p
= SDATA (string
) + best_below_byte
;
902 unsigned char *pend
= SDATA (string
) + byte_index
;
906 p
+= BYTES_BY_CHAR_HEAD (*p
);
910 i_byte
= p
- SDATA (string
);
914 unsigned char *p
= SDATA (string
) + best_above_byte
;
915 unsigned char *pbeg
= SDATA (string
) + byte_index
;
920 while (!CHAR_HEAD_P (*p
)) p
--;
924 i_byte
= p
- SDATA (string
);
927 string_char_byte_cache_bytepos
= i_byte
;
928 string_char_byte_cache_charpos
= i
;
929 string_char_byte_cache_string
= string
;
934 /* Convert STRING to a multibyte string. */
937 string_make_multibyte (string
)
943 if (STRING_MULTIBYTE (string
))
946 nbytes
= count_size_as_multibyte (SDATA (string
),
948 /* If all the chars are ASCII, they won't need any more bytes
949 once converted. In that case, we can return STRING itself. */
950 if (nbytes
== SBYTES (string
))
953 buf
= (unsigned char *) alloca (nbytes
);
954 copy_text (SDATA (string
), buf
, SBYTES (string
),
957 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
961 /* Convert STRING (if unibyte) to a multibyte string without changing
962 the number of characters. Characters 0200 trough 0237 are
963 converted to eight-bit characters. */
966 string_to_multibyte (string
)
972 if (STRING_MULTIBYTE (string
))
975 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
976 /* If all the chars are ASCII, they won't need any more bytes once
978 if (nbytes
== SBYTES (string
))
979 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
981 buf
= (unsigned char *) alloca (nbytes
);
982 bcopy (SDATA (string
), buf
, SBYTES (string
));
983 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
985 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
989 /* Convert STRING to a single-byte string. */
992 string_make_unibyte (string
)
997 if (! STRING_MULTIBYTE (string
))
1000 buf
= (unsigned char *) alloca (SCHARS (string
));
1002 copy_text (SDATA (string
), buf
, SBYTES (string
),
1005 return make_unibyte_string (buf
, SCHARS (string
));
1008 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1010 doc
: /* Return the multibyte equivalent of STRING.
1011 If STRING is unibyte and contains non-ASCII characters, the function
1012 `unibyte-char-to-multibyte' is used to convert each unibyte character
1013 to a multibyte character. In this case, the returned string is a
1014 newly created string with no text properties. If STRING is multibyte
1015 or entirely ASCII, it is returned unchanged. In particular, when
1016 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1017 \(When the characters are all ASCII, Emacs primitives will treat the
1018 string the same way whether it is unibyte or multibyte.) */)
1022 CHECK_STRING (string
);
1024 return string_make_multibyte (string
);
1027 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1029 doc
: /* Return the unibyte equivalent of STRING.
1030 Multibyte character codes are converted to unibyte according to
1031 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1032 If the lookup in the translation table fails, this function takes just
1033 the low 8 bits of each character. */)
1037 CHECK_STRING (string
);
1039 return string_make_unibyte (string
);
1042 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1044 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1045 If STRING is unibyte, the result is STRING itself.
1046 Otherwise it is a newly created string, with no text properties.
1047 If STRING is multibyte and contains a character of charset
1048 `eight-bit', it is converted to the corresponding single byte. */)
1052 CHECK_STRING (string
);
1054 if (STRING_MULTIBYTE (string
))
1056 int bytes
= SBYTES (string
);
1057 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1059 bcopy (SDATA (string
), str
, bytes
);
1060 bytes
= str_as_unibyte (str
, bytes
);
1061 string
= make_unibyte_string (str
, bytes
);
1067 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1069 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1070 If STRING is multibyte, the result is STRING itself.
1071 Otherwise it is a newly created string, with no text properties.
1073 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1074 part of a correct utf-8 sequence), it is converted to the corresponding
1075 multibyte character of charset `eight-bit'.
1076 See also `string-to-multibyte'. */)
1080 CHECK_STRING (string
);
1082 if (! STRING_MULTIBYTE (string
))
1084 Lisp_Object new_string
;
1087 parse_str_as_multibyte (SDATA (string
),
1090 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1091 bcopy (SDATA (string
), SDATA (new_string
),
1093 if (nbytes
!= SBYTES (string
))
1094 str_as_multibyte (SDATA (new_string
), nbytes
,
1095 SBYTES (string
), NULL
);
1096 string
= new_string
;
1097 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1102 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1104 doc
: /* Return a multibyte string with the same individual chars as STRING.
1105 If STRING is multibyte, the result is STRING itself.
1106 Otherwise it is a newly created string, with no text properties.
1108 If STRING is unibyte and contains an 8-bit byte, it is converted to
1109 the corresponding multibyte character of charset `eight-bit'.
1111 This differs from `string-as-multibyte' by converting each byte of a correct
1112 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1113 correct sequence. */)
1117 CHECK_STRING (string
);
1119 return string_to_multibyte (string
);
1123 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1124 doc
: /* Return a copy of ALIST.
1125 This is an alist which represents the same mapping from objects to objects,
1126 but does not share the alist structure with ALIST.
1127 The objects mapped (cars and cdrs of elements of the alist)
1128 are shared, however.
1129 Elements of ALIST that are not conses are also shared. */)
1133 register Lisp_Object tem
;
1138 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1139 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1141 register Lisp_Object car
;
1145 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1150 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1151 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1152 TO may be nil or omitted; then the substring runs to the end of STRING.
1153 FROM and TO start at 0. If either is negative, it counts from the end.
1155 This function allows vectors as well as strings. */)
1158 register Lisp_Object from
, to
;
1163 int from_char
, to_char
;
1164 int from_byte
= 0, to_byte
= 0;
1166 if (! (STRINGP (string
) || VECTORP (string
)))
1167 wrong_type_argument (Qarrayp
, string
);
1169 CHECK_NUMBER (from
);
1171 if (STRINGP (string
))
1173 size
= SCHARS (string
);
1174 size_byte
= SBYTES (string
);
1177 size
= XVECTOR (string
)->size
;
1182 to_byte
= size_byte
;
1188 to_char
= XINT (to
);
1192 if (STRINGP (string
))
1193 to_byte
= string_char_to_byte (string
, to_char
);
1196 from_char
= XINT (from
);
1199 if (STRINGP (string
))
1200 from_byte
= string_char_to_byte (string
, from_char
);
1202 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1203 args_out_of_range_3 (string
, make_number (from_char
),
1204 make_number (to_char
));
1206 if (STRINGP (string
))
1208 res
= make_specified_string (SDATA (string
) + from_byte
,
1209 to_char
- from_char
, to_byte
- from_byte
,
1210 STRING_MULTIBYTE (string
));
1211 copy_text_properties (make_number (from_char
), make_number (to_char
),
1212 string
, make_number (0), res
, Qnil
);
1215 res
= Fvector (to_char
- from_char
,
1216 XVECTOR (string
)->contents
+ from_char
);
1222 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1223 doc
: /* Return a substring of STRING, without text properties.
1224 It starts at index FROM and ending before TO.
1225 TO may be nil or omitted; then the substring runs to the end of STRING.
1226 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1227 If FROM or TO is negative, it counts from the end.
1229 With one argument, just copy STRING without its properties. */)
1232 register Lisp_Object from
, to
;
1234 int size
, size_byte
;
1235 int from_char
, to_char
;
1236 int from_byte
, to_byte
;
1238 CHECK_STRING (string
);
1240 size
= SCHARS (string
);
1241 size_byte
= SBYTES (string
);
1244 from_char
= from_byte
= 0;
1247 CHECK_NUMBER (from
);
1248 from_char
= XINT (from
);
1252 from_byte
= string_char_to_byte (string
, from_char
);
1258 to_byte
= size_byte
;
1264 to_char
= XINT (to
);
1268 to_byte
= string_char_to_byte (string
, to_char
);
1271 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1272 args_out_of_range_3 (string
, make_number (from_char
),
1273 make_number (to_char
));
1275 return make_specified_string (SDATA (string
) + from_byte
,
1276 to_char
- from_char
, to_byte
- from_byte
,
1277 STRING_MULTIBYTE (string
));
1280 /* Extract a substring of STRING, giving start and end positions
1281 both in characters and in bytes. */
1284 substring_both (string
, from
, from_byte
, to
, to_byte
)
1286 int from
, from_byte
, to
, to_byte
;
1292 if (! (STRINGP (string
) || VECTORP (string
)))
1293 wrong_type_argument (Qarrayp
, string
);
1295 if (STRINGP (string
))
1297 size
= SCHARS (string
);
1298 size_byte
= SBYTES (string
);
1301 size
= XVECTOR (string
)->size
;
1303 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1304 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1306 if (STRINGP (string
))
1308 res
= make_specified_string (SDATA (string
) + from_byte
,
1309 to
- from
, to_byte
- from_byte
,
1310 STRING_MULTIBYTE (string
));
1311 copy_text_properties (make_number (from
), make_number (to
),
1312 string
, make_number (0), res
, Qnil
);
1315 res
= Fvector (to
- from
,
1316 XVECTOR (string
)->contents
+ from
);
1321 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1322 doc
: /* Take cdr N times on LIST, returns the result. */)
1325 register Lisp_Object list
;
1327 register int i
, num
;
1330 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1334 wrong_type_argument (Qlistp
, list
);
1340 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1341 doc
: /* Return the Nth element of LIST.
1342 N counts from zero. If LIST is not that long, nil is returned. */)
1344 Lisp_Object n
, list
;
1346 return Fcar (Fnthcdr (n
, list
));
1349 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1350 doc
: /* Return element of SEQUENCE at index N. */)
1352 register Lisp_Object sequence
, n
;
1357 if (CONSP (sequence
) || NILP (sequence
))
1358 return Fcar (Fnthcdr (n
, sequence
));
1359 else if (STRINGP (sequence
) || VECTORP (sequence
)
1360 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1361 return Faref (sequence
, n
);
1363 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1367 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1368 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1369 The value is actually the tail of LIST whose car is ELT. */)
1371 register Lisp_Object elt
;
1374 register Lisp_Object tail
;
1375 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1377 register Lisp_Object tem
;
1379 wrong_type_argument (Qlistp
, list
);
1381 if (! NILP (Fequal (elt
, tem
)))
1388 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1389 doc
: /* Return non-nil if ELT is an element of LIST.
1390 Comparison done with EQ. The value is actually the tail of LIST
1391 whose car is ELT. */)
1393 Lisp_Object elt
, list
;
1397 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1401 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1405 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1412 if (!CONSP (list
) && !NILP (list
))
1413 list
= wrong_type_argument (Qlistp
, list
);
1418 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1419 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1420 The value is actually the first element of LIST whose car is KEY.
1421 Elements of LIST that are not conses are ignored. */)
1423 Lisp_Object key
, list
;
1430 || (CONSP (XCAR (list
))
1431 && EQ (XCAR (XCAR (list
)), key
)))
1436 || (CONSP (XCAR (list
))
1437 && EQ (XCAR (XCAR (list
)), key
)))
1442 || (CONSP (XCAR (list
))
1443 && EQ (XCAR (XCAR (list
)), key
)))
1451 result
= XCAR (list
);
1452 else if (NILP (list
))
1455 result
= wrong_type_argument (Qlistp
, list
);
1460 /* Like Fassq but never report an error and do not allow quits.
1461 Use only on lists known never to be circular. */
1464 assq_no_quit (key
, list
)
1465 Lisp_Object key
, list
;
1468 && (!CONSP (XCAR (list
))
1469 || !EQ (XCAR (XCAR (list
)), key
)))
1472 return CONSP (list
) ? XCAR (list
) : Qnil
;
1475 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1476 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1477 The value is actually the first element of LIST whose car equals KEY. */)
1479 Lisp_Object key
, list
;
1481 Lisp_Object result
, car
;
1486 || (CONSP (XCAR (list
))
1487 && (car
= XCAR (XCAR (list
)),
1488 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1493 || (CONSP (XCAR (list
))
1494 && (car
= XCAR (XCAR (list
)),
1495 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1500 || (CONSP (XCAR (list
))
1501 && (car
= XCAR (XCAR (list
)),
1502 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1510 result
= XCAR (list
);
1511 else if (NILP (list
))
1514 result
= wrong_type_argument (Qlistp
, list
);
1519 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1520 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1521 The value is actually the first element of LIST whose cdr is KEY. */)
1523 register Lisp_Object key
;
1531 || (CONSP (XCAR (list
))
1532 && EQ (XCDR (XCAR (list
)), key
)))
1537 || (CONSP (XCAR (list
))
1538 && EQ (XCDR (XCAR (list
)), key
)))
1543 || (CONSP (XCAR (list
))
1544 && EQ (XCDR (XCAR (list
)), key
)))
1553 else if (CONSP (list
))
1554 result
= XCAR (list
);
1556 result
= wrong_type_argument (Qlistp
, list
);
1561 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1562 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1563 The value is actually the first element of LIST whose cdr equals KEY. */)
1565 Lisp_Object key
, list
;
1567 Lisp_Object result
, cdr
;
1572 || (CONSP (XCAR (list
))
1573 && (cdr
= XCDR (XCAR (list
)),
1574 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1579 || (CONSP (XCAR (list
))
1580 && (cdr
= XCDR (XCAR (list
)),
1581 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1586 || (CONSP (XCAR (list
))
1587 && (cdr
= XCDR (XCAR (list
)),
1588 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1596 result
= XCAR (list
);
1597 else if (NILP (list
))
1600 result
= wrong_type_argument (Qlistp
, list
);
1605 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1606 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1607 The modified LIST is returned. Comparison is done with `eq'.
1608 If the first member of LIST is ELT, there is no way to remove it by side effect;
1609 therefore, write `(setq foo (delq element foo))'
1610 to be sure of changing the value of `foo'. */)
1612 register Lisp_Object elt
;
1615 register Lisp_Object tail
, prev
;
1616 register Lisp_Object tem
;
1620 while (!NILP (tail
))
1623 wrong_type_argument (Qlistp
, list
);
1630 Fsetcdr (prev
, XCDR (tail
));
1640 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1641 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1642 SEQ must be a list, a vector, or a string.
1643 The modified SEQ is returned. Comparison is done with `equal'.
1644 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1645 is not a side effect; it is simply using a different sequence.
1646 Therefore, write `(setq foo (delete element foo))'
1647 to be sure of changing the value of `foo'. */)
1649 Lisp_Object elt
, seq
;
1655 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1656 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1659 if (n
!= ASIZE (seq
))
1661 struct Lisp_Vector
*p
= allocate_vector (n
);
1663 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1664 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1665 p
->contents
[n
++] = AREF (seq
, i
);
1667 XSETVECTOR (seq
, p
);
1670 else if (STRINGP (seq
))
1672 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1675 for (i
= nchars
= nbytes
= ibyte
= 0;
1677 ++i
, ibyte
+= cbytes
)
1679 if (STRING_MULTIBYTE (seq
))
1681 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1682 SBYTES (seq
) - ibyte
);
1683 cbytes
= CHAR_BYTES (c
);
1691 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1698 if (nchars
!= SCHARS (seq
))
1702 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1703 if (!STRING_MULTIBYTE (seq
))
1704 STRING_SET_UNIBYTE (tem
);
1706 for (i
= nchars
= nbytes
= ibyte
= 0;
1708 ++i
, ibyte
+= cbytes
)
1710 if (STRING_MULTIBYTE (seq
))
1712 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1713 SBYTES (seq
) - ibyte
);
1714 cbytes
= CHAR_BYTES (c
);
1722 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1724 unsigned char *from
= SDATA (seq
) + ibyte
;
1725 unsigned char *to
= SDATA (tem
) + nbytes
;
1731 for (n
= cbytes
; n
--; )
1741 Lisp_Object tail
, prev
;
1743 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1746 wrong_type_argument (Qlistp
, seq
);
1748 if (!NILP (Fequal (elt
, XCAR (tail
))))
1753 Fsetcdr (prev
, XCDR (tail
));
1764 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1765 doc
: /* Reverse LIST by modifying cdr pointers.
1766 Return the reversed list. */)
1770 register Lisp_Object prev
, tail
, next
;
1772 if (NILP (list
)) return list
;
1775 while (!NILP (tail
))
1779 wrong_type_argument (Qlistp
, list
);
1781 Fsetcdr (tail
, prev
);
1788 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1789 doc
: /* Reverse LIST, copying. Return the reversed list.
1790 See also the function `nreverse', which is used more often. */)
1796 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1799 new = Fcons (XCAR (list
), new);
1802 wrong_type_argument (Qconsp
, list
);
1806 Lisp_Object
merge ();
1808 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1809 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1810 Returns the sorted list. LIST is modified by side effects.
1811 PREDICATE is called with two elements of LIST, and should return t
1812 if the first element is "less" than the second. */)
1814 Lisp_Object list
, predicate
;
1816 Lisp_Object front
, back
;
1817 register Lisp_Object len
, tem
;
1818 struct gcpro gcpro1
, gcpro2
;
1819 register int length
;
1822 len
= Flength (list
);
1823 length
= XINT (len
);
1827 XSETINT (len
, (length
/ 2) - 1);
1828 tem
= Fnthcdr (len
, list
);
1830 Fsetcdr (tem
, Qnil
);
1832 GCPRO2 (front
, back
);
1833 front
= Fsort (front
, predicate
);
1834 back
= Fsort (back
, predicate
);
1836 return merge (front
, back
, predicate
);
1840 merge (org_l1
, org_l2
, pred
)
1841 Lisp_Object org_l1
, org_l2
;
1845 register Lisp_Object tail
;
1847 register Lisp_Object l1
, l2
;
1848 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1855 /* It is sufficient to protect org_l1 and org_l2.
1856 When l1 and l2 are updated, we copy the new values
1857 back into the org_ vars. */
1858 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1878 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1894 Fsetcdr (tail
, tem
);
1900 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1901 doc
: /* Extract a value from a property list.
1902 PLIST is a property list, which is a list of the form
1903 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1904 corresponding to the given PROP, or nil if PROP is not
1905 one of the properties on the list. */)
1913 CONSP (tail
) && CONSP (XCDR (tail
));
1914 tail
= XCDR (XCDR (tail
)))
1916 if (EQ (prop
, XCAR (tail
)))
1917 return XCAR (XCDR (tail
));
1919 /* This function can be called asynchronously
1920 (setup_coding_system). Don't QUIT in that case. */
1921 if (!interrupt_input_blocked
)
1926 wrong_type_argument (Qlistp
, prop
);
1931 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1932 doc
: /* Return the value of SYMBOL's PROPNAME property.
1933 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1935 Lisp_Object symbol
, propname
;
1937 CHECK_SYMBOL (symbol
);
1938 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1941 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1942 doc
: /* Change value in PLIST of PROP to VAL.
1943 PLIST is a property list, which is a list of the form
1944 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1945 If PROP is already a property on the list, its value is set to VAL,
1946 otherwise the new PROP VAL pair is added. The new plist is returned;
1947 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1948 The PLIST is modified by side effects. */)
1951 register Lisp_Object prop
;
1954 register Lisp_Object tail
, prev
;
1955 Lisp_Object newcell
;
1957 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1958 tail
= XCDR (XCDR (tail
)))
1960 if (EQ (prop
, XCAR (tail
)))
1962 Fsetcar (XCDR (tail
), val
);
1969 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1973 Fsetcdr (XCDR (prev
), newcell
);
1977 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1978 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1979 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1980 (symbol
, propname
, value
)
1981 Lisp_Object symbol
, propname
, value
;
1983 CHECK_SYMBOL (symbol
);
1984 XSYMBOL (symbol
)->plist
1985 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1989 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1990 doc
: /* Extract a value from a property list, comparing with `equal'.
1991 PLIST is a property list, which is a list of the form
1992 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1993 corresponding to the given PROP, or nil if PROP is not
1994 one of the properties on the list. */)
2002 CONSP (tail
) && CONSP (XCDR (tail
));
2003 tail
= XCDR (XCDR (tail
)))
2005 if (! NILP (Fequal (prop
, XCAR (tail
))))
2006 return XCAR (XCDR (tail
));
2012 wrong_type_argument (Qlistp
, prop
);
2017 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2018 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2019 PLIST is a property list, which is a list of the form
2020 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2021 If PROP is already a property on the list, its value is set to VAL,
2022 otherwise the new PROP VAL pair is added. The new plist is returned;
2023 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2024 The PLIST is modified by side effects. */)
2027 register Lisp_Object prop
;
2030 register Lisp_Object tail
, prev
;
2031 Lisp_Object newcell
;
2033 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2034 tail
= XCDR (XCDR (tail
)))
2036 if (! NILP (Fequal (prop
, XCAR (tail
))))
2038 Fsetcar (XCDR (tail
), val
);
2045 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2049 Fsetcdr (XCDR (prev
), newcell
);
2053 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2054 doc
: /* Return t if two Lisp objects have similar structure and contents.
2055 They must have the same data type.
2056 Conses are compared by comparing the cars and the cdrs.
2057 Vectors and strings are compared element by element.
2058 Numbers are compared by value, but integers cannot equal floats.
2059 (Use `=' if you want integers and floats to be able to be equal.)
2060 Symbols must match exactly. */)
2062 register Lisp_Object o1
, o2
;
2064 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2067 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2068 doc
: /* Return t if two Lisp objects have similar structure and contents.
2069 This is like `equal' except that it compares the text properties
2070 of strings. (`equal' ignores text properties.) */)
2072 register Lisp_Object o1
, o2
;
2074 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2077 /* DEPTH is current depth of recursion. Signal an error if it
2079 PROPS, if non-nil, means compare string text properties too. */
2082 internal_equal (o1
, o2
, depth
, props
)
2083 register Lisp_Object o1
, o2
;
2087 error ("Stack overflow in equal");
2093 if (XTYPE (o1
) != XTYPE (o2
))
2102 d1
= extract_float (o1
);
2103 d2
= extract_float (o2
);
2104 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2105 though they are not =. */
2106 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2110 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2117 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2121 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2123 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2126 o1
= XOVERLAY (o1
)->plist
;
2127 o2
= XOVERLAY (o2
)->plist
;
2132 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2133 && (XMARKER (o1
)->buffer
== 0
2134 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2138 case Lisp_Vectorlike
:
2141 EMACS_INT size
= XVECTOR (o1
)->size
;
2142 /* Pseudovectors have the type encoded in the size field, so this test
2143 actually checks that the objects have the same type as well as the
2145 if (XVECTOR (o2
)->size
!= size
)
2147 /* Boolvectors are compared much like strings. */
2148 if (BOOL_VECTOR_P (o1
))
2151 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2153 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2155 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2160 if (WINDOW_CONFIGURATIONP (o1
))
2161 return compare_window_configurations (o1
, o2
, 0);
2163 /* Aside from them, only true vectors, char-tables, and compiled
2164 functions are sensible to compare, so eliminate the others now. */
2165 if (size
& PSEUDOVECTOR_FLAG
)
2167 if (!(size
& (PVEC_COMPILED
2168 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
)))
2170 size
&= PSEUDOVECTOR_SIZE_MASK
;
2172 for (i
= 0; i
< size
; i
++)
2175 v1
= XVECTOR (o1
)->contents
[i
];
2176 v2
= XVECTOR (o2
)->contents
[i
];
2177 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2185 if (SCHARS (o1
) != SCHARS (o2
))
2187 if (SBYTES (o1
) != SBYTES (o2
))
2189 if (bcmp (SDATA (o1
), SDATA (o2
),
2192 if (props
&& !compare_string_intervals (o1
, o2
))
2198 case Lisp_Type_Limit
:
2205 extern Lisp_Object
Fmake_char_internal ();
2207 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2208 doc
: /* Store each element of ARRAY with ITEM.
2209 ARRAY is a vector, string, char-table, or bool-vector. */)
2211 Lisp_Object array
, item
;
2213 register int size
, index
, charval
;
2215 if (VECTORP (array
))
2217 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2218 size
= XVECTOR (array
)->size
;
2219 for (index
= 0; index
< size
; index
++)
2222 else if (CHAR_TABLE_P (array
))
2226 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2227 XCHAR_TABLE (array
)->contents
[i
] = item
;
2228 XCHAR_TABLE (array
)->defalt
= item
;
2230 else if (STRINGP (array
))
2232 register unsigned char *p
= SDATA (array
);
2233 CHECK_NUMBER (item
);
2234 charval
= XINT (item
);
2235 size
= SCHARS (array
);
2236 if (STRING_MULTIBYTE (array
))
2238 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2239 int len
= CHAR_STRING (charval
, str
);
2240 int size_byte
= SBYTES (array
);
2241 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2244 if (size
!= size_byte
)
2247 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2248 if (len
!= this_len
)
2249 error ("Attempt to change byte length of a string");
2252 for (i
= 0; i
< size_byte
; i
++)
2253 *p
++ = str
[i
% len
];
2256 for (index
= 0; index
< size
; index
++)
2259 else if (BOOL_VECTOR_P (array
))
2261 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2263 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2265 charval
= (! NILP (item
) ? -1 : 0);
2266 for (index
= 0; index
< size_in_chars
- 1; index
++)
2268 if (index
< size_in_chars
)
2270 /* Mask out bits beyond the vector size. */
2271 if (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)
2272 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)) - 1;
2278 array
= wrong_type_argument (Qarrayp
, array
);
2284 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2286 doc
: /* Clear the contents of STRING.
2287 This makes STRING unibyte and may change its length. */)
2291 int len
= SBYTES (string
);
2292 bzero (SDATA (string
), len
);
2293 STRING_SET_CHARS (string
, len
);
2294 STRING_SET_UNIBYTE (string
);
2304 Lisp_Object args
[2];
2307 return Fnconc (2, args
);
2309 return Fnconc (2, &s1
);
2310 #endif /* NO_ARG_ARRAY */
2313 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2314 doc
: /* Concatenate any number of lists by altering them.
2315 Only the last argument is not altered, and need not be a list.
2316 usage: (nconc &rest LISTS) */)
2321 register int argnum
;
2322 register Lisp_Object tail
, tem
, val
;
2326 for (argnum
= 0; argnum
< nargs
; argnum
++)
2329 if (NILP (tem
)) continue;
2334 if (argnum
+ 1 == nargs
) break;
2337 tem
= wrong_type_argument (Qlistp
, tem
);
2346 tem
= args
[argnum
+ 1];
2347 Fsetcdr (tail
, tem
);
2349 args
[argnum
+ 1] = tail
;
2355 /* This is the guts of all mapping functions.
2356 Apply FN to each element of SEQ, one by one,
2357 storing the results into elements of VALS, a C vector of Lisp_Objects.
2358 LENI is the length of VALS, which should also be the length of SEQ. */
2361 mapcar1 (leni
, vals
, fn
, seq
)
2364 Lisp_Object fn
, seq
;
2366 register Lisp_Object tail
;
2369 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2373 /* Don't let vals contain any garbage when GC happens. */
2374 for (i
= 0; i
< leni
; i
++)
2377 GCPRO3 (dummy
, fn
, seq
);
2379 gcpro1
.nvars
= leni
;
2383 /* We need not explicitly protect `tail' because it is used only on lists, and
2384 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2388 for (i
= 0; i
< leni
; i
++)
2390 dummy
= XVECTOR (seq
)->contents
[i
];
2391 dummy
= call1 (fn
, dummy
);
2396 else if (BOOL_VECTOR_P (seq
))
2398 for (i
= 0; i
< leni
; i
++)
2401 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2402 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2407 dummy
= call1 (fn
, dummy
);
2412 else if (STRINGP (seq
))
2416 for (i
= 0, i_byte
= 0; i
< leni
;)
2421 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2422 XSETFASTINT (dummy
, c
);
2423 dummy
= call1 (fn
, dummy
);
2425 vals
[i_before
] = dummy
;
2428 else /* Must be a list, since Flength did not get an error */
2431 for (i
= 0; i
< leni
; i
++)
2433 dummy
= call1 (fn
, Fcar (tail
));
2443 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2444 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2445 In between each pair of results, stick in SEPARATOR. Thus, " " as
2446 SEPARATOR results in spaces between the values returned by FUNCTION.
2447 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2448 (function
, sequence
, separator
)
2449 Lisp_Object function
, sequence
, separator
;
2454 register Lisp_Object
*args
;
2456 struct gcpro gcpro1
;
2458 len
= Flength (sequence
);
2459 if (CHAR_TABLE_P (sequence
))
2460 wrong_type_argument (Qlistp
, sequence
);
2462 nargs
= leni
+ leni
- 1;
2463 if (nargs
< 0) return build_string ("");
2465 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2468 mapcar1 (leni
, args
, function
, sequence
);
2471 for (i
= leni
- 1; i
>= 0; i
--)
2472 args
[i
+ i
] = args
[i
];
2474 for (i
= 1; i
< nargs
; i
+= 2)
2475 args
[i
] = separator
;
2477 return Fconcat (nargs
, args
);
2480 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2481 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2482 The result is a list just as long as SEQUENCE.
2483 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2484 (function
, sequence
)
2485 Lisp_Object function
, sequence
;
2487 register Lisp_Object len
;
2489 register Lisp_Object
*args
;
2491 len
= Flength (sequence
);
2492 if (CHAR_TABLE_P (sequence
))
2493 wrong_type_argument (Qlistp
, sequence
);
2494 leni
= XFASTINT (len
);
2495 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2497 mapcar1 (leni
, args
, function
, sequence
);
2499 return Flist (leni
, args
);
2502 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2503 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2504 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2505 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2506 (function
, sequence
)
2507 Lisp_Object function
, sequence
;
2511 leni
= XFASTINT (Flength (sequence
));
2512 if (CHAR_TABLE_P (sequence
))
2513 wrong_type_argument (Qlistp
, sequence
);
2514 mapcar1 (leni
, 0, function
, sequence
);
2519 /* Anything that calls this function must protect from GC! */
2521 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2522 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2523 Takes one argument, which is the string to display to ask the question.
2524 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2525 No confirmation of the answer is requested; a single character is enough.
2526 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2527 the bindings in `query-replace-map'; see the documentation of that variable
2528 for more information. In this case, the useful bindings are `act', `skip',
2529 `recenter', and `quit'.\)
2531 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2532 is nil and `use-dialog-box' is non-nil. */)
2536 register Lisp_Object obj
, key
, def
, map
;
2537 register int answer
;
2538 Lisp_Object xprompt
;
2539 Lisp_Object args
[2];
2540 struct gcpro gcpro1
, gcpro2
;
2541 int count
= SPECPDL_INDEX ();
2543 specbind (Qcursor_in_echo_area
, Qt
);
2545 map
= Fsymbol_value (intern ("query-replace-map"));
2547 CHECK_STRING (prompt
);
2549 GCPRO2 (prompt
, xprompt
);
2551 #ifdef HAVE_X_WINDOWS
2552 if (display_hourglass_p
)
2553 cancel_hourglass ();
2560 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2564 Lisp_Object pane
, menu
;
2565 redisplay_preserve_echo_area (3);
2566 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2567 Fcons (Fcons (build_string ("No"), Qnil
),
2569 menu
= Fcons (prompt
, pane
);
2570 obj
= Fx_popup_dialog (Qt
, menu
);
2571 answer
= !NILP (obj
);
2574 #endif /* HAVE_MENUS */
2575 cursor_in_echo_area
= 1;
2576 choose_minibuf_frame ();
2579 Lisp_Object pargs
[3];
2581 /* Colorize prompt according to `minibuffer-prompt' face. */
2582 pargs
[0] = build_string ("%s(y or n) ");
2583 pargs
[1] = intern ("face");
2584 pargs
[2] = intern ("minibuffer-prompt");
2585 args
[0] = Fpropertize (3, pargs
);
2590 if (minibuffer_auto_raise
)
2592 Lisp_Object mini_frame
;
2594 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2596 Fraise_frame (mini_frame
);
2599 obj
= read_filtered_event (1, 0, 0, 0);
2600 cursor_in_echo_area
= 0;
2601 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2604 key
= Fmake_vector (make_number (1), obj
);
2605 def
= Flookup_key (map
, key
, Qt
);
2607 if (EQ (def
, intern ("skip")))
2612 else if (EQ (def
, intern ("act")))
2617 else if (EQ (def
, intern ("recenter")))
2623 else if (EQ (def
, intern ("quit")))
2625 /* We want to exit this command for exit-prefix,
2626 and this is the only way to do it. */
2627 else if (EQ (def
, intern ("exit-prefix")))
2632 /* If we don't clear this, then the next call to read_char will
2633 return quit_char again, and we'll enter an infinite loop. */
2638 if (EQ (xprompt
, prompt
))
2640 args
[0] = build_string ("Please answer y or n. ");
2642 xprompt
= Fconcat (2, args
);
2647 if (! noninteractive
)
2649 cursor_in_echo_area
= -1;
2650 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2654 unbind_to (count
, Qnil
);
2655 return answer
? Qt
: Qnil
;
2658 /* This is how C code calls `yes-or-no-p' and allows the user
2661 Anything that calls this function must protect from GC! */
2664 do_yes_or_no_p (prompt
)
2667 return call1 (intern ("yes-or-no-p"), prompt
);
2670 /* Anything that calls this function must protect from GC! */
2672 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2673 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2674 Takes one argument, which is the string to display to ask the question.
2675 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2676 The user must confirm the answer with RET,
2677 and can edit it until it has been confirmed.
2679 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2680 is nil, and `use-dialog-box' is non-nil. */)
2684 register Lisp_Object ans
;
2685 Lisp_Object args
[2];
2686 struct gcpro gcpro1
;
2688 CHECK_STRING (prompt
);
2691 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2695 Lisp_Object pane
, menu
, obj
;
2696 redisplay_preserve_echo_area (4);
2697 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2698 Fcons (Fcons (build_string ("No"), Qnil
),
2701 menu
= Fcons (prompt
, pane
);
2702 obj
= Fx_popup_dialog (Qt
, menu
);
2706 #endif /* HAVE_MENUS */
2709 args
[1] = build_string ("(yes or no) ");
2710 prompt
= Fconcat (2, args
);
2716 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2717 Qyes_or_no_p_history
, Qnil
,
2719 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2724 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2732 message ("Please answer yes or no.");
2733 Fsleep_for (make_number (2), Qnil
);
2737 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2738 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2740 Each of the three load averages is multiplied by 100, then converted
2743 When USE-FLOATS is non-nil, floats will be used instead of integers.
2744 These floats are not multiplied by 100.
2746 If the 5-minute or 15-minute load averages are not available, return a
2747 shortened list, containing only those averages which are available.
2749 An error is thrown if the load average can't be obtained. In some
2750 cases making it work would require Emacs being installed setuid or
2751 setgid so that it can read kernel information, and that usually isn't
2754 Lisp_Object use_floats
;
2757 int loads
= getloadavg (load_ave
, 3);
2758 Lisp_Object ret
= Qnil
;
2761 error ("load-average not implemented for this operating system");
2765 Lisp_Object load
= (NILP (use_floats
) ?
2766 make_number ((int) (100.0 * load_ave
[loads
]))
2767 : make_float (load_ave
[loads
]));
2768 ret
= Fcons (load
, ret
);
2774 Lisp_Object Vfeatures
, Qsubfeatures
;
2775 extern Lisp_Object Vafter_load_alist
;
2777 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2778 doc
: /* Returns t if FEATURE is present in this Emacs.
2780 Use this to conditionalize execution of lisp code based on the
2781 presence or absence of emacs or environment extensions.
2782 Use `provide' to declare that a feature is available. This function
2783 looks at the value of the variable `features'. The optional argument
2784 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2785 (feature
, subfeature
)
2786 Lisp_Object feature
, subfeature
;
2788 register Lisp_Object tem
;
2789 CHECK_SYMBOL (feature
);
2790 tem
= Fmemq (feature
, Vfeatures
);
2791 if (!NILP (tem
) && !NILP (subfeature
))
2792 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2793 return (NILP (tem
)) ? Qnil
: Qt
;
2796 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2797 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2798 The optional argument SUBFEATURES should be a list of symbols listing
2799 particular subfeatures supported in this version of FEATURE. */)
2800 (feature
, subfeatures
)
2801 Lisp_Object feature
, subfeatures
;
2803 register Lisp_Object tem
;
2804 CHECK_SYMBOL (feature
);
2805 CHECK_LIST (subfeatures
);
2806 if (!NILP (Vautoload_queue
))
2807 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2808 tem
= Fmemq (feature
, Vfeatures
);
2810 Vfeatures
= Fcons (feature
, Vfeatures
);
2811 if (!NILP (subfeatures
))
2812 Fput (feature
, Qsubfeatures
, subfeatures
);
2813 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2815 /* Run any load-hooks for this file. */
2816 tem
= Fassq (feature
, Vafter_load_alist
);
2818 Fprogn (XCDR (tem
));
2823 /* `require' and its subroutines. */
2825 /* List of features currently being require'd, innermost first. */
2827 Lisp_Object require_nesting_list
;
2830 require_unwind (old_value
)
2831 Lisp_Object old_value
;
2833 return require_nesting_list
= old_value
;
2836 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2837 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2838 If FEATURE is not a member of the list `features', then the feature
2839 is not loaded; so load the file FILENAME.
2840 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2841 and `load' will try to load this name appended with the suffix `.elc' or
2842 `.el', in that order. The name without appended suffix will not be used.
2843 If the optional third argument NOERROR is non-nil,
2844 then return nil if the file is not found instead of signaling an error.
2845 Normally the return value is FEATURE.
2846 The normal messages at start and end of loading FILENAME are suppressed. */)
2847 (feature
, filename
, noerror
)
2848 Lisp_Object feature
, filename
, noerror
;
2850 register Lisp_Object tem
;
2851 struct gcpro gcpro1
, gcpro2
;
2853 CHECK_SYMBOL (feature
);
2855 tem
= Fmemq (feature
, Vfeatures
);
2859 int count
= SPECPDL_INDEX ();
2862 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2864 /* This is to make sure that loadup.el gives a clear picture
2865 of what files are preloaded and when. */
2866 if (! NILP (Vpurify_flag
))
2867 error ("(require %s) while preparing to dump",
2868 SDATA (SYMBOL_NAME (feature
)));
2870 /* A certain amount of recursive `require' is legitimate,
2871 but if we require the same feature recursively 3 times,
2873 tem
= require_nesting_list
;
2874 while (! NILP (tem
))
2876 if (! NILP (Fequal (feature
, XCAR (tem
))))
2881 error ("Recursive `require' for feature `%s'",
2882 SDATA (SYMBOL_NAME (feature
)));
2884 /* Update the list for any nested `require's that occur. */
2885 record_unwind_protect (require_unwind
, require_nesting_list
);
2886 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2888 /* Value saved here is to be restored into Vautoload_queue */
2889 record_unwind_protect (un_autoload
, Vautoload_queue
);
2890 Vautoload_queue
= Qt
;
2892 /* Load the file. */
2893 GCPRO2 (feature
, filename
);
2894 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2895 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2898 /* If load failed entirely, return nil. */
2900 return unbind_to (count
, Qnil
);
2902 tem
= Fmemq (feature
, Vfeatures
);
2904 error ("Required feature `%s' was not provided",
2905 SDATA (SYMBOL_NAME (feature
)));
2907 /* Once loading finishes, don't undo it. */
2908 Vautoload_queue
= Qt
;
2909 feature
= unbind_to (count
, feature
);
2915 /* Primitives for work of the "widget" library.
2916 In an ideal world, this section would not have been necessary.
2917 However, lisp function calls being as slow as they are, it turns
2918 out that some functions in the widget library (wid-edit.el) are the
2919 bottleneck of Widget operation. Here is their translation to C,
2920 for the sole reason of efficiency. */
2922 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2923 doc
: /* Return non-nil if PLIST has the property PROP.
2924 PLIST is a property list, which is a list of the form
2925 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2926 Unlike `plist-get', this allows you to distinguish between a missing
2927 property and a property with the value nil.
2928 The value is actually the tail of PLIST whose car is PROP. */)
2930 Lisp_Object plist
, prop
;
2932 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2935 plist
= XCDR (plist
);
2936 plist
= CDR (plist
);
2941 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2942 doc
: /* In WIDGET, set PROPERTY to VALUE.
2943 The value can later be retrieved with `widget-get'. */)
2944 (widget
, property
, value
)
2945 Lisp_Object widget
, property
, value
;
2947 CHECK_CONS (widget
);
2948 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2952 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2953 doc
: /* In WIDGET, get the value of PROPERTY.
2954 The value could either be specified when the widget was created, or
2955 later with `widget-put'. */)
2957 Lisp_Object widget
, property
;
2965 CHECK_CONS (widget
);
2966 tmp
= Fplist_member (XCDR (widget
), property
);
2972 tmp
= XCAR (widget
);
2975 widget
= Fget (tmp
, Qwidget_type
);
2979 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2980 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2981 ARGS are passed as extra arguments to the function.
2982 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2987 /* This function can GC. */
2988 Lisp_Object newargs
[3];
2989 struct gcpro gcpro1
, gcpro2
;
2992 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2993 newargs
[1] = args
[0];
2994 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2995 GCPRO2 (newargs
[0], newargs
[2]);
2996 result
= Fapply (3, newargs
);
3001 #ifdef HAVE_LANGINFO_CODESET
3002 #include <langinfo.h>
3005 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3006 doc
: /* Access locale data ITEM for the current C locale, if available.
3007 ITEM should be one of the following:
3009 `codeset', returning the character set as a string (locale item CODESET);
3011 `days', returning a 7-element vector of day names (locale items DAY_n);
3013 `months', returning a 12-element vector of month names (locale items MON_n);
3015 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3016 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3018 If the system can't provide such information through a call to
3019 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3021 See also Info node `(libc)Locales'.
3023 The data read from the system are decoded using `locale-coding-system'. */)
3028 #ifdef HAVE_LANGINFO_CODESET
3030 if (EQ (item
, Qcodeset
))
3032 str
= nl_langinfo (CODESET
);
3033 return build_string (str
);
3036 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3038 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3039 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3041 synchronize_system_time_locale ();
3042 for (i
= 0; i
< 7; i
++)
3044 str
= nl_langinfo (days
[i
]);
3045 val
= make_unibyte_string (str
, strlen (str
));
3046 /* Fixme: Is this coding system necessarily right, even if
3047 it is consistent with CODESET? If not, what to do? */
3048 Faset (v
, make_number (i
),
3049 code_convert_string_norecord (val
, Vlocale_coding_system
,
3056 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3058 struct Lisp_Vector
*p
= allocate_vector (12);
3059 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3060 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3062 synchronize_system_time_locale ();
3063 for (i
= 0; i
< 12; i
++)
3065 str
= nl_langinfo (months
[i
]);
3066 val
= make_unibyte_string (str
, strlen (str
));
3068 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3070 XSETVECTOR (val
, p
);
3074 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3075 but is in the locale files. This could be used by ps-print. */
3077 else if (EQ (item
, Qpaper
))
3079 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3080 make_number (nl_langinfo (PAPER_HEIGHT
)));
3082 #endif /* PAPER_WIDTH */
3083 #endif /* HAVE_LANGINFO_CODESET*/
3087 /* base64 encode/decode functions (RFC 2045).
3088 Based on code from GNU recode. */
3090 #define MIME_LINE_LENGTH 76
3092 #define IS_ASCII(Character) \
3094 #define IS_BASE64(Character) \
3095 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3096 #define IS_BASE64_IGNORABLE(Character) \
3097 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3098 || (Character) == '\f' || (Character) == '\r')
3100 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3101 character or return retval if there are no characters left to
3103 #define READ_QUADRUPLET_BYTE(retval) \
3108 if (nchars_return) \
3109 *nchars_return = nchars; \
3114 while (IS_BASE64_IGNORABLE (c))
3116 /* Don't use alloca for regions larger than this, lest we overflow
3118 #define MAX_ALLOCA 16*1024
3120 /* Table of characters coding the 64 values. */
3121 static char base64_value_to_char
[64] =
3123 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3124 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3125 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3126 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3127 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3128 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3129 '8', '9', '+', '/' /* 60-63 */
3132 /* Table of base64 values for first 128 characters. */
3133 static short base64_char_to_value
[128] =
3135 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3136 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3137 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3138 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3139 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3140 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3141 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3142 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3143 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3144 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3145 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3146 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3147 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3150 /* The following diagram shows the logical steps by which three octets
3151 get transformed into four base64 characters.
3153 .--------. .--------. .--------.
3154 |aaaaaabb| |bbbbcccc| |ccdddddd|
3155 `--------' `--------' `--------'
3157 .--------+--------+--------+--------.
3158 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3159 `--------+--------+--------+--------'
3161 .--------+--------+--------+--------.
3162 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3163 `--------+--------+--------+--------'
3165 The octets are divided into 6 bit chunks, which are then encoded into
3166 base64 characters. */
3169 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3170 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3172 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3174 doc
: /* Base64-encode the region between BEG and END.
3175 Return the length of the encoded text.
3176 Optional third argument NO-LINE-BREAK means do not break long lines
3177 into shorter lines. */)
3178 (beg
, end
, no_line_break
)
3179 Lisp_Object beg
, end
, no_line_break
;
3182 int allength
, length
;
3183 int ibeg
, iend
, encoded_length
;
3186 validate_region (&beg
, &end
);
3188 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3189 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3190 move_gap_both (XFASTINT (beg
), ibeg
);
3192 /* We need to allocate enough room for encoding the text.
3193 We need 33 1/3% more space, plus a newline every 76
3194 characters, and then we round up. */
3195 length
= iend
- ibeg
;
3196 allength
= length
+ length
/3 + 1;
3197 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3199 if (allength
<= MAX_ALLOCA
)
3200 encoded
= (char *) alloca (allength
);
3202 encoded
= (char *) xmalloc (allength
);
3203 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3204 NILP (no_line_break
),
3205 !NILP (current_buffer
->enable_multibyte_characters
));
3206 if (encoded_length
> allength
)
3209 if (encoded_length
< 0)
3211 /* The encoding wasn't possible. */
3212 if (length
> MAX_ALLOCA
)
3214 error ("Multibyte character in data for base64 encoding");
3217 /* Now we have encoded the region, so we insert the new contents
3218 and delete the old. (Insert first in order to preserve markers.) */
3219 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3220 insert (encoded
, encoded_length
);
3221 if (allength
> MAX_ALLOCA
)
3223 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3225 /* If point was outside of the region, restore it exactly; else just
3226 move to the beginning of the region. */
3227 if (old_pos
>= XFASTINT (end
))
3228 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3229 else if (old_pos
> XFASTINT (beg
))
3230 old_pos
= XFASTINT (beg
);
3233 /* We return the length of the encoded text. */
3234 return make_number (encoded_length
);
3237 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3239 doc
: /* Base64-encode STRING and return the result.
3240 Optional second argument NO-LINE-BREAK means do not break long lines
3241 into shorter lines. */)
3242 (string
, no_line_break
)
3243 Lisp_Object string
, no_line_break
;
3245 int allength
, length
, encoded_length
;
3247 Lisp_Object encoded_string
;
3249 CHECK_STRING (string
);
3251 /* We need to allocate enough room for encoding the text.
3252 We need 33 1/3% more space, plus a newline every 76
3253 characters, and then we round up. */
3254 length
= SBYTES (string
);
3255 allength
= length
+ length
/3 + 1;
3256 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3258 /* We need to allocate enough room for decoding the text. */
3259 if (allength
<= MAX_ALLOCA
)
3260 encoded
= (char *) alloca (allength
);
3262 encoded
= (char *) xmalloc (allength
);
3264 encoded_length
= base64_encode_1 (SDATA (string
),
3265 encoded
, length
, NILP (no_line_break
),
3266 STRING_MULTIBYTE (string
));
3267 if (encoded_length
> allength
)
3270 if (encoded_length
< 0)
3272 /* The encoding wasn't possible. */
3273 if (length
> MAX_ALLOCA
)
3275 error ("Multibyte character in data for base64 encoding");
3278 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3279 if (allength
> MAX_ALLOCA
)
3282 return encoded_string
;
3286 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3293 int counter
= 0, i
= 0;
3303 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3304 if (CHAR_BYTE8_P (c
))
3305 c
= CHAR_TO_BYTE8 (c
);
3313 /* Wrap line every 76 characters. */
3317 if (counter
< MIME_LINE_LENGTH
/ 4)
3326 /* Process first byte of a triplet. */
3328 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3329 value
= (0x03 & c
) << 4;
3331 /* Process second byte of a triplet. */
3335 *e
++ = base64_value_to_char
[value
];
3343 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3344 if (CHAR_BYTE8_P (c
))
3345 c
= CHAR_TO_BYTE8 (c
);
3353 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3354 value
= (0x0f & c
) << 2;
3356 /* Process third byte of a triplet. */
3360 *e
++ = base64_value_to_char
[value
];
3367 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3368 if (CHAR_BYTE8_P (c
))
3369 c
= CHAR_TO_BYTE8 (c
);
3377 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3378 *e
++ = base64_value_to_char
[0x3f & c
];
3385 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3387 doc
: /* Base64-decode the region between BEG and END.
3388 Return the length of the decoded text.
3389 If the region can't be decoded, signal an error and don't modify the buffer. */)
3391 Lisp_Object beg
, end
;
3393 int ibeg
, iend
, length
, allength
;
3398 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3400 validate_region (&beg
, &end
);
3402 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3403 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3405 length
= iend
- ibeg
;
3407 /* We need to allocate enough room for decoding the text. If we are
3408 working on a multibyte buffer, each decoded code may occupy at
3410 allength
= multibyte
? length
* 2 : length
;
3411 if (allength
<= MAX_ALLOCA
)
3412 decoded
= (char *) alloca (allength
);
3414 decoded
= (char *) xmalloc (allength
);
3416 move_gap_both (XFASTINT (beg
), ibeg
);
3417 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3418 multibyte
, &inserted_chars
);
3419 if (decoded_length
> allength
)
3422 if (decoded_length
< 0)
3424 /* The decoding wasn't possible. */
3425 if (allength
> MAX_ALLOCA
)
3427 error ("Invalid base64 data");
3430 /* Now we have decoded the region, so we insert the new contents
3431 and delete the old. (Insert first in order to preserve markers.) */
3432 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3433 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3434 if (allength
> MAX_ALLOCA
)
3436 /* Delete the original text. */
3437 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3438 iend
+ decoded_length
, 1);
3440 /* If point was outside of the region, restore it exactly; else just
3441 move to the beginning of the region. */
3442 if (old_pos
>= XFASTINT (end
))
3443 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3444 else if (old_pos
> XFASTINT (beg
))
3445 old_pos
= XFASTINT (beg
);
3446 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3448 return make_number (inserted_chars
);
3451 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3453 doc
: /* Base64-decode STRING and return the result. */)
3458 int length
, decoded_length
;
3459 Lisp_Object decoded_string
;
3461 CHECK_STRING (string
);
3463 length
= SBYTES (string
);
3464 /* We need to allocate enough room for decoding the text. */
3465 if (length
<= MAX_ALLOCA
)
3466 decoded
= (char *) alloca (length
);
3468 decoded
= (char *) xmalloc (length
);
3470 /* The decoded result should be unibyte. */
3471 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3473 if (decoded_length
> length
)
3475 else if (decoded_length
>= 0)
3476 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3478 decoded_string
= Qnil
;
3480 if (length
> MAX_ALLOCA
)
3482 if (!STRINGP (decoded_string
))
3483 error ("Invalid base64 data");
3485 return decoded_string
;
3488 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3489 MULTIBYTE is nonzero, the decoded result should be in multibyte
3490 form. If NCHARS_RETRUN is not NULL, store the number of produced
3491 characters in *NCHARS_RETURN. */
3494 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3504 unsigned long value
;
3509 /* Process first byte of a quadruplet. */
3511 READ_QUADRUPLET_BYTE (e
-to
);
3515 value
= base64_char_to_value
[c
] << 18;
3517 /* Process second byte of a quadruplet. */
3519 READ_QUADRUPLET_BYTE (-1);
3523 value
|= base64_char_to_value
[c
] << 12;
3525 c
= (unsigned char) (value
>> 16);
3526 if (multibyte
&& c
>= 128)
3527 e
+= BYTE8_STRING (c
, e
);
3532 /* Process third byte of a quadruplet. */
3534 READ_QUADRUPLET_BYTE (-1);
3538 READ_QUADRUPLET_BYTE (-1);
3547 value
|= base64_char_to_value
[c
] << 6;
3549 c
= (unsigned char) (0xff & value
>> 8);
3550 if (multibyte
&& c
>= 128)
3551 e
+= BYTE8_STRING (c
, e
);
3556 /* Process fourth byte of a quadruplet. */
3558 READ_QUADRUPLET_BYTE (-1);
3565 value
|= base64_char_to_value
[c
];
3567 c
= (unsigned char) (0xff & value
);
3568 if (multibyte
&& c
>= 128)
3569 e
+= BYTE8_STRING (c
, e
);
3578 /***********************************************************************
3580 ***** Hash Tables *****
3582 ***********************************************************************/
3584 /* Implemented by gerd@gnu.org. This hash table implementation was
3585 inspired by CMUCL hash tables. */
3589 1. For small tables, association lists are probably faster than
3590 hash tables because they have lower overhead.
3592 For uses of hash tables where the O(1) behavior of table
3593 operations is not a requirement, it might therefore be a good idea
3594 not to hash. Instead, we could just do a linear search in the
3595 key_and_value vector of the hash table. This could be done
3596 if a `:linear-search t' argument is given to make-hash-table. */
3599 /* The list of all weak hash tables. Don't staticpro this one. */
3601 Lisp_Object Vweak_hash_tables
;
3603 /* Various symbols. */
3605 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3606 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3607 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3609 /* Function prototypes. */
3611 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3612 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3613 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3614 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3615 Lisp_Object
, unsigned));
3616 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3617 Lisp_Object
, unsigned));
3618 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3619 unsigned, Lisp_Object
, unsigned));
3620 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3621 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3622 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3623 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3625 static unsigned sxhash_string
P_ ((unsigned char *, int));
3626 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3627 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3628 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3629 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3633 /***********************************************************************
3635 ***********************************************************************/
3637 /* If OBJ is a Lisp hash table, return a pointer to its struct
3638 Lisp_Hash_Table. Otherwise, signal an error. */
3640 static struct Lisp_Hash_Table
*
3641 check_hash_table (obj
)
3644 CHECK_HASH_TABLE (obj
);
3645 return XHASH_TABLE (obj
);
3649 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3653 next_almost_prime (n
)
3666 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3667 which USED[I] is non-zero. If found at index I in ARGS, set
3668 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3669 -1. This function is used to extract a keyword/argument pair from
3670 a DEFUN parameter list. */
3673 get_key_arg (key
, nargs
, args
, used
)
3681 for (i
= 0; i
< nargs
- 1; ++i
)
3682 if (!used
[i
] && EQ (args
[i
], key
))
3697 /* Return a Lisp vector which has the same contents as VEC but has
3698 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3699 vector that are not copied from VEC are set to INIT. */
3702 larger_vector (vec
, new_size
, init
)
3707 struct Lisp_Vector
*v
;
3710 xassert (VECTORP (vec
));
3711 old_size
= XVECTOR (vec
)->size
;
3712 xassert (new_size
>= old_size
);
3714 v
= allocate_vector (new_size
);
3715 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3716 old_size
* sizeof *v
->contents
);
3717 for (i
= old_size
; i
< new_size
; ++i
)
3718 v
->contents
[i
] = init
;
3719 XSETVECTOR (vec
, v
);
3724 /***********************************************************************
3726 ***********************************************************************/
3728 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3729 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3730 KEY2 are the same. */
3733 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3734 struct Lisp_Hash_Table
*h
;
3735 Lisp_Object key1
, key2
;
3736 unsigned hash1
, hash2
;
3738 return (FLOATP (key1
)
3740 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3744 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3745 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3746 KEY2 are the same. */
3749 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3750 struct Lisp_Hash_Table
*h
;
3751 Lisp_Object key1
, key2
;
3752 unsigned hash1
, hash2
;
3754 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3758 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3759 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3760 if KEY1 and KEY2 are the same. */
3763 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3764 struct Lisp_Hash_Table
*h
;
3765 Lisp_Object key1
, key2
;
3766 unsigned hash1
, hash2
;
3770 Lisp_Object args
[3];
3772 args
[0] = h
->user_cmp_function
;
3775 return !NILP (Ffuncall (3, args
));
3782 /* Value is a hash code for KEY for use in hash table H which uses
3783 `eq' to compare keys. The hash code returned is guaranteed to fit
3784 in a Lisp integer. */
3788 struct Lisp_Hash_Table
*h
;
3791 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3792 xassert ((hash
& ~INTMASK
) == 0);
3797 /* Value is a hash code for KEY for use in hash table H which uses
3798 `eql' to compare keys. The hash code returned is guaranteed to fit
3799 in a Lisp integer. */
3803 struct Lisp_Hash_Table
*h
;
3808 hash
= sxhash (key
, 0);
3810 hash
= XUINT (key
) ^ XGCTYPE (key
);
3811 xassert ((hash
& ~INTMASK
) == 0);
3816 /* Value is a hash code for KEY for use in hash table H which uses
3817 `equal' to compare keys. The hash code returned is guaranteed to fit
3818 in a Lisp integer. */
3821 hashfn_equal (h
, key
)
3822 struct Lisp_Hash_Table
*h
;
3825 unsigned hash
= sxhash (key
, 0);
3826 xassert ((hash
& ~INTMASK
) == 0);
3831 /* Value is a hash code for KEY for use in hash table H which uses as
3832 user-defined function to compare keys. The hash code returned is
3833 guaranteed to fit in a Lisp integer. */
3836 hashfn_user_defined (h
, key
)
3837 struct Lisp_Hash_Table
*h
;
3840 Lisp_Object args
[2], hash
;
3842 args
[0] = h
->user_hash_function
;
3844 hash
= Ffuncall (2, args
);
3845 if (!INTEGERP (hash
))
3847 list2 (build_string ("Invalid hash code returned from \
3848 user-supplied hash function"),
3850 return XUINT (hash
);
3854 /* Create and initialize a new hash table.
3856 TEST specifies the test the hash table will use to compare keys.
3857 It must be either one of the predefined tests `eq', `eql' or
3858 `equal' or a symbol denoting a user-defined test named TEST with
3859 test and hash functions USER_TEST and USER_HASH.
3861 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3863 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3864 new size when it becomes full is computed by adding REHASH_SIZE to
3865 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3866 table's new size is computed by multiplying its old size with
3869 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3870 be resized when the ratio of (number of entries in the table) /
3871 (table size) is >= REHASH_THRESHOLD.
3873 WEAK specifies the weakness of the table. If non-nil, it must be
3874 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3877 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3878 user_test
, user_hash
)
3879 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3880 Lisp_Object user_test
, user_hash
;
3882 struct Lisp_Hash_Table
*h
;
3884 int index_size
, i
, sz
;
3886 /* Preconditions. */
3887 xassert (SYMBOLP (test
));
3888 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3889 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3890 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3891 xassert (FLOATP (rehash_threshold
)
3892 && XFLOATINT (rehash_threshold
) > 0
3893 && XFLOATINT (rehash_threshold
) <= 1.0);
3895 if (XFASTINT (size
) == 0)
3896 size
= make_number (1);
3898 /* Allocate a table and initialize it. */
3899 h
= allocate_hash_table ();
3901 /* Initialize hash table slots. */
3902 sz
= XFASTINT (size
);
3905 if (EQ (test
, Qeql
))
3907 h
->cmpfn
= cmpfn_eql
;
3908 h
->hashfn
= hashfn_eql
;
3910 else if (EQ (test
, Qeq
))
3913 h
->hashfn
= hashfn_eq
;
3915 else if (EQ (test
, Qequal
))
3917 h
->cmpfn
= cmpfn_equal
;
3918 h
->hashfn
= hashfn_equal
;
3922 h
->user_cmp_function
= user_test
;
3923 h
->user_hash_function
= user_hash
;
3924 h
->cmpfn
= cmpfn_user_defined
;
3925 h
->hashfn
= hashfn_user_defined
;
3929 h
->rehash_threshold
= rehash_threshold
;
3930 h
->rehash_size
= rehash_size
;
3931 h
->count
= make_number (0);
3932 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3933 h
->hash
= Fmake_vector (size
, Qnil
);
3934 h
->next
= Fmake_vector (size
, Qnil
);
3935 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3936 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3937 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3939 /* Set up the free list. */
3940 for (i
= 0; i
< sz
- 1; ++i
)
3941 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3942 h
->next_free
= make_number (0);
3944 XSET_HASH_TABLE (table
, h
);
3945 xassert (HASH_TABLE_P (table
));
3946 xassert (XHASH_TABLE (table
) == h
);
3948 /* Maybe add this hash table to the list of all weak hash tables. */
3950 h
->next_weak
= Qnil
;
3953 h
->next_weak
= Vweak_hash_tables
;
3954 Vweak_hash_tables
= table
;
3961 /* Return a copy of hash table H1. Keys and values are not copied,
3962 only the table itself is. */
3965 copy_hash_table (h1
)
3966 struct Lisp_Hash_Table
*h1
;
3969 struct Lisp_Hash_Table
*h2
;
3970 struct Lisp_Vector
*next
;
3972 h2
= allocate_hash_table ();
3973 next
= h2
->vec_next
;
3974 bcopy (h1
, h2
, sizeof *h2
);
3975 h2
->vec_next
= next
;
3976 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3977 h2
->hash
= Fcopy_sequence (h1
->hash
);
3978 h2
->next
= Fcopy_sequence (h1
->next
);
3979 h2
->index
= Fcopy_sequence (h1
->index
);
3980 XSET_HASH_TABLE (table
, h2
);
3982 /* Maybe add this hash table to the list of all weak hash tables. */
3983 if (!NILP (h2
->weak
))
3985 h2
->next_weak
= Vweak_hash_tables
;
3986 Vweak_hash_tables
= table
;
3993 /* Resize hash table H if it's too full. If H cannot be resized
3994 because it's already too large, throw an error. */
3997 maybe_resize_hash_table (h
)
3998 struct Lisp_Hash_Table
*h
;
4000 if (NILP (h
->next_free
))
4002 int old_size
= HASH_TABLE_SIZE (h
);
4003 int i
, new_size
, index_size
;
4005 if (INTEGERP (h
->rehash_size
))
4006 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4008 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4009 new_size
= max (old_size
+ 1, new_size
);
4010 index_size
= next_almost_prime ((int)
4012 / XFLOATINT (h
->rehash_threshold
)));
4013 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4014 error ("Hash table too large to resize");
4016 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4017 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4018 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4019 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4021 /* Update the free list. Do it so that new entries are added at
4022 the end of the free list. This makes some operations like
4024 for (i
= old_size
; i
< new_size
- 1; ++i
)
4025 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4027 if (!NILP (h
->next_free
))
4029 Lisp_Object last
, next
;
4031 last
= h
->next_free
;
4032 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4036 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4039 XSETFASTINT (h
->next_free
, old_size
);
4042 for (i
= 0; i
< old_size
; ++i
)
4043 if (!NILP (HASH_HASH (h
, i
)))
4045 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4046 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4047 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4048 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4054 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4055 the hash code of KEY. Value is the index of the entry in H
4056 matching KEY, or -1 if not found. */
4059 hash_lookup (h
, key
, hash
)
4060 struct Lisp_Hash_Table
*h
;
4065 int start_of_bucket
;
4068 hash_code
= h
->hashfn (h
, key
);
4072 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4073 idx
= HASH_INDEX (h
, start_of_bucket
);
4075 /* We need not gcpro idx since it's either an integer or nil. */
4078 int i
= XFASTINT (idx
);
4079 if (EQ (key
, HASH_KEY (h
, i
))
4081 && h
->cmpfn (h
, key
, hash_code
,
4082 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4084 idx
= HASH_NEXT (h
, i
);
4087 return NILP (idx
) ? -1 : XFASTINT (idx
);
4091 /* Put an entry into hash table H that associates KEY with VALUE.
4092 HASH is a previously computed hash code of KEY.
4093 Value is the index of the entry in H matching KEY. */
4096 hash_put (h
, key
, value
, hash
)
4097 struct Lisp_Hash_Table
*h
;
4098 Lisp_Object key
, value
;
4101 int start_of_bucket
, i
;
4103 xassert ((hash
& ~INTMASK
) == 0);
4105 /* Increment count after resizing because resizing may fail. */
4106 maybe_resize_hash_table (h
);
4107 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4109 /* Store key/value in the key_and_value vector. */
4110 i
= XFASTINT (h
->next_free
);
4111 h
->next_free
= HASH_NEXT (h
, i
);
4112 HASH_KEY (h
, i
) = key
;
4113 HASH_VALUE (h
, i
) = value
;
4115 /* Remember its hash code. */
4116 HASH_HASH (h
, i
) = make_number (hash
);
4118 /* Add new entry to its collision chain. */
4119 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4120 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4121 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4126 /* Remove the entry matching KEY from hash table H, if there is one. */
4129 hash_remove (h
, key
)
4130 struct Lisp_Hash_Table
*h
;
4134 int start_of_bucket
;
4135 Lisp_Object idx
, prev
;
4137 hash_code
= h
->hashfn (h
, key
);
4138 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4139 idx
= HASH_INDEX (h
, start_of_bucket
);
4142 /* We need not gcpro idx, prev since they're either integers or nil. */
4145 int i
= XFASTINT (idx
);
4147 if (EQ (key
, HASH_KEY (h
, i
))
4149 && h
->cmpfn (h
, key
, hash_code
,
4150 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4152 /* Take entry out of collision chain. */
4154 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4156 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4158 /* Clear slots in key_and_value and add the slots to
4160 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4161 HASH_NEXT (h
, i
) = h
->next_free
;
4162 h
->next_free
= make_number (i
);
4163 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4164 xassert (XINT (h
->count
) >= 0);
4170 idx
= HASH_NEXT (h
, i
);
4176 /* Clear hash table H. */
4180 struct Lisp_Hash_Table
*h
;
4182 if (XFASTINT (h
->count
) > 0)
4184 int i
, size
= HASH_TABLE_SIZE (h
);
4186 for (i
= 0; i
< size
; ++i
)
4188 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4189 HASH_KEY (h
, i
) = Qnil
;
4190 HASH_VALUE (h
, i
) = Qnil
;
4191 HASH_HASH (h
, i
) = Qnil
;
4194 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4195 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4197 h
->next_free
= make_number (0);
4198 h
->count
= make_number (0);
4204 /************************************************************************
4206 ************************************************************************/
4208 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4209 entries from the table that don't survive the current GC.
4210 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4211 non-zero if anything was marked. */
4214 sweep_weak_table (h
, remove_entries_p
)
4215 struct Lisp_Hash_Table
*h
;
4216 int remove_entries_p
;
4218 int bucket
, n
, marked
;
4220 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4223 for (bucket
= 0; bucket
< n
; ++bucket
)
4225 Lisp_Object idx
, next
, prev
;
4227 /* Follow collision chain, removing entries that
4228 don't survive this garbage collection. */
4230 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4232 int i
= XFASTINT (idx
);
4233 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4234 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4237 if (EQ (h
->weak
, Qkey
))
4238 remove_p
= !key_known_to_survive_p
;
4239 else if (EQ (h
->weak
, Qvalue
))
4240 remove_p
= !value_known_to_survive_p
;
4241 else if (EQ (h
->weak
, Qkey_or_value
))
4242 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4243 else if (EQ (h
->weak
, Qkey_and_value
))
4244 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4248 next
= HASH_NEXT (h
, i
);
4250 if (remove_entries_p
)
4254 /* Take out of collision chain. */
4256 HASH_INDEX (h
, bucket
) = next
;
4258 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4260 /* Add to free list. */
4261 HASH_NEXT (h
, i
) = h
->next_free
;
4264 /* Clear key, value, and hash. */
4265 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4266 HASH_HASH (h
, i
) = Qnil
;
4268 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4275 /* Make sure key and value survive. */
4276 if (!key_known_to_survive_p
)
4278 mark_object (HASH_KEY (h
, i
));
4282 if (!value_known_to_survive_p
)
4284 mark_object (HASH_VALUE (h
, i
));
4295 /* Remove elements from weak hash tables that don't survive the
4296 current garbage collection. Remove weak tables that don't survive
4297 from Vweak_hash_tables. Called from gc_sweep. */
4300 sweep_weak_hash_tables ()
4302 Lisp_Object table
, used
, next
;
4303 struct Lisp_Hash_Table
*h
;
4306 /* Mark all keys and values that are in use. Keep on marking until
4307 there is no more change. This is necessary for cases like
4308 value-weak table A containing an entry X -> Y, where Y is used in a
4309 key-weak table B, Z -> Y. If B comes after A in the list of weak
4310 tables, X -> Y might be removed from A, although when looking at B
4311 one finds that it shouldn't. */
4315 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4317 h
= XHASH_TABLE (table
);
4318 if (h
->size
& ARRAY_MARK_FLAG
)
4319 marked
|= sweep_weak_table (h
, 0);
4324 /* Remove tables and entries that aren't used. */
4325 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4327 h
= XHASH_TABLE (table
);
4328 next
= h
->next_weak
;
4330 if (h
->size
& ARRAY_MARK_FLAG
)
4332 /* TABLE is marked as used. Sweep its contents. */
4333 if (XFASTINT (h
->count
) > 0)
4334 sweep_weak_table (h
, 1);
4336 /* Add table to the list of used weak hash tables. */
4337 h
->next_weak
= used
;
4342 Vweak_hash_tables
= used
;
4347 /***********************************************************************
4348 Hash Code Computation
4349 ***********************************************************************/
4351 /* Maximum depth up to which to dive into Lisp structures. */
4353 #define SXHASH_MAX_DEPTH 3
4355 /* Maximum length up to which to take list and vector elements into
4358 #define SXHASH_MAX_LEN 7
4360 /* Combine two integers X and Y for hashing. */
4362 #define SXHASH_COMBINE(X, Y) \
4363 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4367 /* Return a hash for string PTR which has length LEN. The hash
4368 code returned is guaranteed to fit in a Lisp integer. */
4371 sxhash_string (ptr
, len
)
4375 unsigned char *p
= ptr
;
4376 unsigned char *end
= p
+ len
;
4385 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4388 return hash
& INTMASK
;
4392 /* Return a hash for list LIST. DEPTH is the current depth in the
4393 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4396 sxhash_list (list
, depth
)
4403 if (depth
< SXHASH_MAX_DEPTH
)
4405 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4406 list
= XCDR (list
), ++i
)
4408 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4409 hash
= SXHASH_COMBINE (hash
, hash2
);
4416 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4417 the Lisp structure. */
4420 sxhash_vector (vec
, depth
)
4424 unsigned hash
= XVECTOR (vec
)->size
;
4427 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4428 for (i
= 0; i
< n
; ++i
)
4430 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4431 hash
= SXHASH_COMBINE (hash
, hash2
);
4438 /* Return a hash for bool-vector VECTOR. */
4441 sxhash_bool_vector (vec
)
4444 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4447 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4448 for (i
= 0; i
< n
; ++i
)
4449 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4455 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4456 structure. Value is an unsigned integer clipped to INTMASK. */
4465 if (depth
> SXHASH_MAX_DEPTH
)
4468 switch (XTYPE (obj
))
4475 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4476 SCHARS (SYMBOL_NAME (obj
)));
4484 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4487 /* This can be everything from a vector to an overlay. */
4488 case Lisp_Vectorlike
:
4490 /* According to the CL HyperSpec, two arrays are equal only if
4491 they are `eq', except for strings and bit-vectors. In
4492 Emacs, this works differently. We have to compare element
4494 hash
= sxhash_vector (obj
, depth
);
4495 else if (BOOL_VECTOR_P (obj
))
4496 hash
= sxhash_bool_vector (obj
);
4498 /* Others are `equal' if they are `eq', so let's take their
4504 hash
= sxhash_list (obj
, depth
);
4509 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4510 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4511 for (hash
= 0; p
< e
; ++p
)
4512 hash
= SXHASH_COMBINE (hash
, *p
);
4520 return hash
& INTMASK
;
4525 /***********************************************************************
4527 ***********************************************************************/
4530 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4531 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4535 unsigned hash
= sxhash (obj
, 0);;
4536 return make_number (hash
);
4540 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4541 doc
: /* Create and return a new hash table.
4543 Arguments are specified as keyword/argument pairs. The following
4544 arguments are defined:
4546 :test TEST -- TEST must be a symbol that specifies how to compare
4547 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4548 `equal'. User-supplied test and hash functions can be specified via
4549 `define-hash-table-test'.
4551 :size SIZE -- A hint as to how many elements will be put in the table.
4554 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4555 fills up. If REHASH-SIZE is an integer, add that many space. If it
4556 is a float, it must be > 1.0, and the new size is computed by
4557 multiplying the old size with that factor. Default is 1.5.
4559 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4560 Resize the hash table when ratio of the number of entries in the
4561 table. Default is 0.8.
4563 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4564 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4565 returned is a weak table. Key/value pairs are removed from a weak
4566 hash table when there are no non-weak references pointing to their
4567 key, value, one of key or value, or both key and value, depending on
4568 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4571 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4576 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4577 Lisp_Object user_test
, user_hash
;
4581 /* The vector `used' is used to keep track of arguments that
4582 have been consumed. */
4583 used
= (char *) alloca (nargs
* sizeof *used
);
4584 bzero (used
, nargs
* sizeof *used
);
4586 /* See if there's a `:test TEST' among the arguments. */
4587 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4588 test
= i
< 0 ? Qeql
: args
[i
];
4589 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4591 /* See if it is a user-defined test. */
4594 prop
= Fget (test
, Qhash_table_test
);
4595 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4596 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4598 user_test
= XCAR (prop
);
4599 user_hash
= XCAR (XCDR (prop
));
4602 user_test
= user_hash
= Qnil
;
4604 /* See if there's a `:size SIZE' argument. */
4605 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4606 size
= i
< 0 ? Qnil
: args
[i
];
4608 size
= make_number (DEFAULT_HASH_SIZE
);
4609 else if (!INTEGERP (size
) || XINT (size
) < 0)
4611 list2 (build_string ("Invalid hash table size"),
4614 /* Look for `:rehash-size SIZE'. */
4615 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4616 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4617 if (!NUMBERP (rehash_size
)
4618 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4619 || XFLOATINT (rehash_size
) <= 1.0)
4621 list2 (build_string ("Invalid hash table rehash size"),
4624 /* Look for `:rehash-threshold THRESHOLD'. */
4625 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4626 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4627 if (!FLOATP (rehash_threshold
)
4628 || XFLOATINT (rehash_threshold
) <= 0.0
4629 || XFLOATINT (rehash_threshold
) > 1.0)
4631 list2 (build_string ("Invalid hash table rehash threshold"),
4634 /* Look for `:weakness WEAK'. */
4635 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4636 weak
= i
< 0 ? Qnil
: args
[i
];
4638 weak
= Qkey_and_value
;
4641 && !EQ (weak
, Qvalue
)
4642 && !EQ (weak
, Qkey_or_value
)
4643 && !EQ (weak
, Qkey_and_value
))
4644 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4647 /* Now, all args should have been used up, or there's a problem. */
4648 for (i
= 0; i
< nargs
; ++i
)
4651 list2 (build_string ("Invalid argument list"), args
[i
]));
4653 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4654 user_test
, user_hash
);
4658 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4659 doc
: /* Return a copy of hash table TABLE. */)
4663 return copy_hash_table (check_hash_table (table
));
4667 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4668 doc
: /* Return the number of elements in TABLE. */)
4672 return check_hash_table (table
)->count
;
4676 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4677 Shash_table_rehash_size
, 1, 1, 0,
4678 doc
: /* Return the current rehash size of TABLE. */)
4682 return check_hash_table (table
)->rehash_size
;
4686 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4687 Shash_table_rehash_threshold
, 1, 1, 0,
4688 doc
: /* Return the current rehash threshold of TABLE. */)
4692 return check_hash_table (table
)->rehash_threshold
;
4696 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4697 doc
: /* Return the size of TABLE.
4698 The size can be used as an argument to `make-hash-table' to create
4699 a hash table than can hold as many elements of TABLE holds
4700 without need for resizing. */)
4704 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4705 return make_number (HASH_TABLE_SIZE (h
));
4709 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4710 doc
: /* Return the test TABLE uses. */)
4714 return check_hash_table (table
)->test
;
4718 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4720 doc
: /* Return the weakness of TABLE. */)
4724 return check_hash_table (table
)->weak
;
4728 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4729 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4733 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4737 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4738 doc
: /* Clear hash table TABLE. */)
4742 hash_clear (check_hash_table (table
));
4747 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4748 doc
: /* Look up KEY in TABLE and return its associated value.
4749 If KEY is not found, return DFLT which defaults to nil. */)
4751 Lisp_Object key
, table
, dflt
;
4753 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4754 int i
= hash_lookup (h
, key
, NULL
);
4755 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4759 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4760 doc
: /* Associate KEY with VALUE in hash table TABLE.
4761 If KEY is already present in table, replace its current value with
4764 Lisp_Object key
, value
, table
;
4766 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4770 i
= hash_lookup (h
, key
, &hash
);
4772 HASH_VALUE (h
, i
) = value
;
4774 hash_put (h
, key
, value
, hash
);
4780 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4781 doc
: /* Remove KEY from TABLE. */)
4783 Lisp_Object key
, table
;
4785 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4786 hash_remove (h
, key
);
4791 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4792 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4793 FUNCTION is called with 2 arguments KEY and VALUE. */)
4795 Lisp_Object function
, table
;
4797 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4798 Lisp_Object args
[3];
4801 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4802 if (!NILP (HASH_HASH (h
, i
)))
4805 args
[1] = HASH_KEY (h
, i
);
4806 args
[2] = HASH_VALUE (h
, i
);
4814 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4815 Sdefine_hash_table_test
, 3, 3, 0,
4816 doc
: /* Define a new hash table test with name NAME, a symbol.
4818 In hash tables created with NAME specified as test, use TEST to
4819 compare keys, and HASH for computing hash codes of keys.
4821 TEST must be a function taking two arguments and returning non-nil if
4822 both arguments are the same. HASH must be a function taking one
4823 argument and return an integer that is the hash code of the argument.
4824 Hash code computation should use the whole value range of integers,
4825 including negative integers. */)
4827 Lisp_Object name
, test
, hash
;
4829 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4834 /************************************************************************
4836 ************************************************************************/
4840 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4841 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4843 A message digest is a cryptographic checksum of a document, and the
4844 algorithm to calculate it is defined in RFC 1321.
4846 The two optional arguments START and END are character positions
4847 specifying for which part of OBJECT the message digest should be
4848 computed. If nil or omitted, the digest is computed for the whole
4851 The MD5 message digest is computed from the result of encoding the
4852 text in a coding system, not directly from the internal Emacs form of
4853 the text. The optional fourth argument CODING-SYSTEM specifies which
4854 coding system to encode the text with. It should be the same coding
4855 system that you used or will use when actually writing the text into a
4858 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4859 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4860 system would be chosen by default for writing this text into a file.
4862 If OBJECT is a string, the most preferred coding system (see the
4863 command `prefer-coding-system') is used.
4865 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4866 guesswork fails. Normally, an error is signaled in such case. */)
4867 (object
, start
, end
, coding_system
, noerror
)
4868 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4870 unsigned char digest
[16];
4871 unsigned char value
[33];
4875 int start_char
= 0, end_char
= 0;
4876 int start_byte
= 0, end_byte
= 0;
4878 register struct buffer
*bp
;
4881 if (STRINGP (object
))
4883 if (NILP (coding_system
))
4885 /* Decide the coding-system to encode the data with. */
4887 if (STRING_MULTIBYTE (object
))
4888 /* use default, we can't guess correct value */
4889 coding_system
= preferred_coding_system ();
4891 coding_system
= Qraw_text
;
4894 if (NILP (Fcoding_system_p (coding_system
)))
4896 /* Invalid coding system. */
4898 if (!NILP (noerror
))
4899 coding_system
= Qraw_text
;
4902 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4905 if (STRING_MULTIBYTE (object
))
4906 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4908 size
= SCHARS (object
);
4909 size_byte
= SBYTES (object
);
4913 CHECK_NUMBER (start
);
4915 start_char
= XINT (start
);
4920 start_byte
= string_char_to_byte (object
, start_char
);
4926 end_byte
= size_byte
;
4932 end_char
= XINT (end
);
4937 end_byte
= string_char_to_byte (object
, end_char
);
4940 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4941 args_out_of_range_3 (object
, make_number (start_char
),
4942 make_number (end_char
));
4946 struct buffer
*prev
= current_buffer
;
4948 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
4950 CHECK_BUFFER (object
);
4952 bp
= XBUFFER (object
);
4953 if (bp
!= current_buffer
)
4954 set_buffer_internal (bp
);
4960 CHECK_NUMBER_COERCE_MARKER (start
);
4968 CHECK_NUMBER_COERCE_MARKER (end
);
4973 temp
= b
, b
= e
, e
= temp
;
4975 if (!(BEGV
<= b
&& e
<= ZV
))
4976 args_out_of_range (start
, end
);
4978 if (NILP (coding_system
))
4980 /* Decide the coding-system to encode the data with.
4981 See fileio.c:Fwrite-region */
4983 if (!NILP (Vcoding_system_for_write
))
4984 coding_system
= Vcoding_system_for_write
;
4987 int force_raw_text
= 0;
4989 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4990 if (NILP (coding_system
)
4991 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4993 coding_system
= Qnil
;
4994 if (NILP (current_buffer
->enable_multibyte_characters
))
4998 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5000 /* Check file-coding-system-alist. */
5001 Lisp_Object args
[4], val
;
5003 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5004 args
[3] = Fbuffer_file_name(object
);
5005 val
= Ffind_operation_coding_system (4, args
);
5006 if (CONSP (val
) && !NILP (XCDR (val
)))
5007 coding_system
= XCDR (val
);
5010 if (NILP (coding_system
)
5011 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5013 /* If we still have not decided a coding system, use the
5014 default value of buffer-file-coding-system. */
5015 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5019 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5020 /* Confirm that VAL can surely encode the current region. */
5021 coding_system
= call4 (Vselect_safe_coding_system_function
,
5022 make_number (b
), make_number (e
),
5023 coding_system
, Qnil
);
5026 coding_system
= Qraw_text
;
5029 if (NILP (Fcoding_system_p (coding_system
)))
5031 /* Invalid coding system. */
5033 if (!NILP (noerror
))
5034 coding_system
= Qraw_text
;
5037 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5041 object
= make_buffer_string (b
, e
, 0);
5042 if (prev
!= current_buffer
)
5043 set_buffer_internal (prev
);
5044 /* Discard the unwind protect for recovering the current
5048 if (STRING_MULTIBYTE (object
))
5049 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5052 md5_buffer (SDATA (object
) + start_byte
,
5053 SBYTES (object
) - (size_byte
- end_byte
),
5056 for (i
= 0; i
< 16; i
++)
5057 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5060 return make_string (value
, 32);
5067 /* Hash table stuff. */
5068 Qhash_table_p
= intern ("hash-table-p");
5069 staticpro (&Qhash_table_p
);
5070 Qeq
= intern ("eq");
5072 Qeql
= intern ("eql");
5074 Qequal
= intern ("equal");
5075 staticpro (&Qequal
);
5076 QCtest
= intern (":test");
5077 staticpro (&QCtest
);
5078 QCsize
= intern (":size");
5079 staticpro (&QCsize
);
5080 QCrehash_size
= intern (":rehash-size");
5081 staticpro (&QCrehash_size
);
5082 QCrehash_threshold
= intern (":rehash-threshold");
5083 staticpro (&QCrehash_threshold
);
5084 QCweakness
= intern (":weakness");
5085 staticpro (&QCweakness
);
5086 Qkey
= intern ("key");
5088 Qvalue
= intern ("value");
5089 staticpro (&Qvalue
);
5090 Qhash_table_test
= intern ("hash-table-test");
5091 staticpro (&Qhash_table_test
);
5092 Qkey_or_value
= intern ("key-or-value");
5093 staticpro (&Qkey_or_value
);
5094 Qkey_and_value
= intern ("key-and-value");
5095 staticpro (&Qkey_and_value
);
5098 defsubr (&Smake_hash_table
);
5099 defsubr (&Scopy_hash_table
);
5100 defsubr (&Shash_table_count
);
5101 defsubr (&Shash_table_rehash_size
);
5102 defsubr (&Shash_table_rehash_threshold
);
5103 defsubr (&Shash_table_size
);
5104 defsubr (&Shash_table_test
);
5105 defsubr (&Shash_table_weakness
);
5106 defsubr (&Shash_table_p
);
5107 defsubr (&Sclrhash
);
5108 defsubr (&Sgethash
);
5109 defsubr (&Sputhash
);
5110 defsubr (&Sremhash
);
5111 defsubr (&Smaphash
);
5112 defsubr (&Sdefine_hash_table_test
);
5114 Qstring_lessp
= intern ("string-lessp");
5115 staticpro (&Qstring_lessp
);
5116 Qprovide
= intern ("provide");
5117 staticpro (&Qprovide
);
5118 Qrequire
= intern ("require");
5119 staticpro (&Qrequire
);
5120 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5121 staticpro (&Qyes_or_no_p_history
);
5122 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5123 staticpro (&Qcursor_in_echo_area
);
5124 Qwidget_type
= intern ("widget-type");
5125 staticpro (&Qwidget_type
);
5127 staticpro (&string_char_byte_cache_string
);
5128 string_char_byte_cache_string
= Qnil
;
5130 require_nesting_list
= Qnil
;
5131 staticpro (&require_nesting_list
);
5133 Fset (Qyes_or_no_p_history
, Qnil
);
5135 DEFVAR_LISP ("features", &Vfeatures
,
5136 doc
: /* A list of symbols which are the features of the executing emacs.
5137 Used by `featurep' and `require', and altered by `provide'. */);
5139 Qsubfeatures
= intern ("subfeatures");
5140 staticpro (&Qsubfeatures
);
5142 #ifdef HAVE_LANGINFO_CODESET
5143 Qcodeset
= intern ("codeset");
5144 staticpro (&Qcodeset
);
5145 Qdays
= intern ("days");
5147 Qmonths
= intern ("months");
5148 staticpro (&Qmonths
);
5149 Qpaper
= intern ("paper");
5150 staticpro (&Qpaper
);
5151 #endif /* HAVE_LANGINFO_CODESET */
5153 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5154 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5155 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5156 invoked by mouse clicks and mouse menu items. */);
5159 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5160 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5161 This applies to commands from menus and tool bar buttons. The value of
5162 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5163 used if both `use-dialog-box' and this variable are non-nil. */);
5164 use_file_dialog
= 1;
5166 defsubr (&Sidentity
);
5169 defsubr (&Ssafe_length
);
5170 defsubr (&Sstring_bytes
);
5171 defsubr (&Sstring_equal
);
5172 defsubr (&Scompare_strings
);
5173 defsubr (&Sstring_lessp
);
5176 defsubr (&Svconcat
);
5177 defsubr (&Scopy_sequence
);
5178 defsubr (&Sstring_make_multibyte
);
5179 defsubr (&Sstring_make_unibyte
);
5180 defsubr (&Sstring_as_multibyte
);
5181 defsubr (&Sstring_as_unibyte
);
5182 defsubr (&Sstring_to_multibyte
);
5183 defsubr (&Scopy_alist
);
5184 defsubr (&Ssubstring
);
5185 defsubr (&Ssubstring_no_properties
);
5197 defsubr (&Snreverse
);
5198 defsubr (&Sreverse
);
5200 defsubr (&Splist_get
);
5202 defsubr (&Splist_put
);
5204 defsubr (&Slax_plist_get
);
5205 defsubr (&Slax_plist_put
);
5207 defsubr (&Sequal_including_properties
);
5208 defsubr (&Sfillarray
);
5209 defsubr (&Sclear_string
);
5213 defsubr (&Smapconcat
);
5214 defsubr (&Sy_or_n_p
);
5215 defsubr (&Syes_or_no_p
);
5216 defsubr (&Sload_average
);
5217 defsubr (&Sfeaturep
);
5218 defsubr (&Srequire
);
5219 defsubr (&Sprovide
);
5220 defsubr (&Splist_member
);
5221 defsubr (&Swidget_put
);
5222 defsubr (&Swidget_get
);
5223 defsubr (&Swidget_apply
);
5224 defsubr (&Sbase64_encode_region
);
5225 defsubr (&Sbase64_decode_region
);
5226 defsubr (&Sbase64_encode_string
);
5227 defsubr (&Sbase64_decode_string
);
5229 defsubr (&Slocale_info
);
5236 Vweak_hash_tables
= Qnil
;
5239 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5240 (do not change this comment) */