1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
31 /* On Mac OS, defining this conflicts with precompiled headers. */
33 /* Note on some machines this defines `vector' as a typedef,
34 so make sure we don't use that name in this file. */
38 #endif /* ! MAC_OSX */
47 #include "intervals.h"
50 #include "blockinput.h"
51 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
56 #define NULL ((POINTER_TYPE *)0)
59 /* Nonzero enables use of dialog boxes for questions
60 asked by mouse commands. */
63 /* Nonzero enables use of a file dialog for file name
64 questions asked by mouse commands. */
67 extern int minibuffer_auto_raise
;
68 extern Lisp_Object minibuf_window
;
69 extern Lisp_Object Vlocale_coding_system
;
70 extern int load_in_progress
;
72 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
73 Lisp_Object Qyes_or_no_p_history
;
74 Lisp_Object Qcursor_in_echo_area
;
75 Lisp_Object Qwidget_type
;
76 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
78 extern Lisp_Object Qinput_method_function
;
80 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
82 extern long get_random ();
83 extern void seed_random
P_ ((long));
89 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
90 doc
: /* Return the argument unchanged. */)
97 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
98 doc
: /* Return a pseudo-random number.
99 All integers representable in Lisp are equally likely.
100 On most systems, this is 29 bits' worth.
101 With positive integer argument N, return random number in interval [0,N).
102 With argument t, set the random number seed from the current time and pid. */)
107 Lisp_Object lispy_val
;
108 unsigned long denominator
;
111 seed_random (getpid () + time (NULL
));
112 if (NATNUMP (n
) && XFASTINT (n
) != 0)
114 /* Try to take our random number from the higher bits of VAL,
115 not the lower, since (says Gentzel) the low bits of `random'
116 are less random than the higher ones. We do this by using the
117 quotient rather than the remainder. At the high end of the RNG
118 it's possible to get a quotient larger than n; discarding
119 these values eliminates the bias that would otherwise appear
120 when using a large n. */
121 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
123 val
= get_random () / denominator
;
124 while (val
>= XFASTINT (n
));
128 XSETINT (lispy_val
, val
);
132 /* Random data-structure functions */
134 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
135 doc
: /* Return the length of vector, list or string SEQUENCE.
136 A byte-code function object is also allowed.
137 If the string contains multibyte characters, this is not necessarily
138 the number of bytes in the string; it is the number of characters.
139 To get the number of bytes, use `string-bytes'. */)
141 register Lisp_Object sequence
;
143 register Lisp_Object val
;
147 if (STRINGP (sequence
))
148 XSETFASTINT (val
, SCHARS (sequence
));
149 else if (VECTORP (sequence
))
150 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
151 else if (SUB_CHAR_TABLE_P (sequence
))
152 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
153 else if (CHAR_TABLE_P (sequence
))
154 XSETFASTINT (val
, MAX_CHAR
);
155 else if (BOOL_VECTOR_P (sequence
))
156 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
157 else if (COMPILEDP (sequence
))
158 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
159 else if (CONSP (sequence
))
162 while (CONSP (sequence
))
164 sequence
= XCDR (sequence
);
167 if (!CONSP (sequence
))
170 sequence
= XCDR (sequence
);
175 if (!NILP (sequence
))
176 wrong_type_argument (Qlistp
, sequence
);
178 val
= make_number (i
);
180 else if (NILP (sequence
))
181 XSETFASTINT (val
, 0);
184 sequence
= wrong_type_argument (Qsequencep
, sequence
);
190 /* This does not check for quits. That is safe since it must terminate. */
192 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
193 doc
: /* Return the length of a list, but avoid error or infinite loop.
194 This function never gets an error. If LIST is not really a list,
195 it returns 0. If LIST is circular, it returns a finite value
196 which is at least the number of distinct elements. */)
200 Lisp_Object tail
, halftail
, length
;
203 /* halftail is used to detect circular lists. */
205 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
207 if (EQ (tail
, halftail
) && len
!= 0)
211 halftail
= XCDR (halftail
);
214 XSETINT (length
, len
);
218 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
219 doc
: /* Return the number of bytes in STRING.
220 If STRING is a multibyte string, this is greater than the length of STRING. */)
224 CHECK_STRING (string
);
225 return make_number (SBYTES (string
));
228 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
229 doc
: /* Return t if two strings have identical contents.
230 Case is significant, but text properties are ignored.
231 Symbols are also allowed; their print names are used instead. */)
233 register Lisp_Object s1
, s2
;
236 s1
= SYMBOL_NAME (s1
);
238 s2
= SYMBOL_NAME (s2
);
242 if (SCHARS (s1
) != SCHARS (s2
)
243 || SBYTES (s1
) != SBYTES (s2
)
244 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
249 DEFUN ("compare-strings", Fcompare_strings
,
250 Scompare_strings
, 6, 7, 0,
251 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
252 In string STR1, skip the first START1 characters and stop at END1.
253 In string STR2, skip the first START2 characters and stop at END2.
254 END1 and END2 default to the full lengths of the respective strings.
256 Case is significant in this comparison if IGNORE-CASE is nil.
257 Unibyte strings are converted to multibyte for comparison.
259 The value is t if the strings (or specified portions) match.
260 If string STR1 is less, the value is a negative number N;
261 - 1 - N is the number of characters that match at the beginning.
262 If string STR1 is greater, the value is a positive number N;
263 N - 1 is the number of characters that match at the beginning. */)
264 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
265 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
267 register int end1_char
, end2_char
;
268 register int i1
, i1_byte
, i2
, i2_byte
;
273 start1
= make_number (0);
275 start2
= make_number (0);
276 CHECK_NATNUM (start1
);
277 CHECK_NATNUM (start2
);
286 i1_byte
= string_char_to_byte (str1
, i1
);
287 i2_byte
= string_char_to_byte (str2
, i2
);
289 end1_char
= SCHARS (str1
);
290 if (! NILP (end1
) && end1_char
> XINT (end1
))
291 end1_char
= XINT (end1
);
293 end2_char
= SCHARS (str2
);
294 if (! NILP (end2
) && end2_char
> XINT (end2
))
295 end2_char
= XINT (end2
);
297 while (i1
< end1_char
&& i2
< end2_char
)
299 /* When we find a mismatch, we must compare the
300 characters, not just the bytes. */
303 if (STRING_MULTIBYTE (str1
))
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
307 c1
= SREF (str1
, i1
++);
308 c1
= unibyte_char_to_multibyte (c1
);
311 if (STRING_MULTIBYTE (str2
))
312 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
315 c2
= SREF (str2
, i2
++);
316 c2
= unibyte_char_to_multibyte (c2
);
322 if (! NILP (ignore_case
))
326 tem
= Fupcase (make_number (c1
));
328 tem
= Fupcase (make_number (c2
));
335 /* Note that I1 has already been incremented
336 past the character that we are comparing;
337 hence we don't add or subtract 1 here. */
339 return make_number (- i1
+ XINT (start1
));
341 return make_number (i1
- XINT (start1
));
345 return make_number (i1
- XINT (start1
) + 1);
347 return make_number (- i1
+ XINT (start1
) - 1);
352 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
353 doc
: /* Return t if first arg string is less than second in lexicographic order.
355 Symbols are also allowed; their print names are used instead. */)
357 register Lisp_Object s1
, s2
;
360 register int i1
, i1_byte
, i2
, i2_byte
;
363 s1
= SYMBOL_NAME (s1
);
365 s2
= SYMBOL_NAME (s2
);
369 i1
= i1_byte
= i2
= i2_byte
= 0;
372 if (end
> SCHARS (s2
))
377 /* When we find a mismatch, we must compare the
378 characters, not just the bytes. */
381 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
382 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
385 return c1
< c2
? Qt
: Qnil
;
387 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
390 static Lisp_Object
concat ();
401 return concat (2, args
, Lisp_String
, 0);
403 return concat (2, &s1
, Lisp_String
, 0);
404 #endif /* NO_ARG_ARRAY */
410 Lisp_Object s1
, s2
, s3
;
417 return concat (3, args
, Lisp_String
, 0);
419 return concat (3, &s1
, Lisp_String
, 0);
420 #endif /* NO_ARG_ARRAY */
423 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
424 doc
: /* Concatenate all the arguments and make the result a list.
425 The result is a list whose elements are the elements of all the arguments.
426 Each argument may be a list, vector or string.
427 The last argument is not copied, just used as the tail of the new list.
428 usage: (append &rest SEQUENCES) */)
433 return concat (nargs
, args
, Lisp_Cons
, 1);
436 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
437 doc
: /* Concatenate all the arguments and make the result a string.
438 The result is a string whose elements are the elements of all the arguments.
439 Each argument may be a string or a list or vector of characters (integers).
440 usage: (concat &rest SEQUENCES) */)
445 return concat (nargs
, args
, Lisp_String
, 0);
448 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
449 doc
: /* Concatenate all the arguments and make the result a vector.
450 The result is a vector whose elements are the elements of all the arguments.
451 Each argument may be a list, vector or string.
452 usage: (vconcat &rest SEQUENCES) */)
457 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
460 /* Return a copy of a sub char table ARG. The elements except for a
461 nested sub char table are not copied. */
463 copy_sub_char_table (arg
)
466 Lisp_Object copy
= make_sub_char_table (Qnil
);
469 XCHAR_TABLE (copy
)->defalt
= XCHAR_TABLE (arg
)->defalt
;
470 /* Copy all the contents. */
471 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
472 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
473 /* Recursively copy any sub char-tables in the ordinary slots. */
474 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
475 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
476 XCHAR_TABLE (copy
)->contents
[i
]
477 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
483 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
484 doc
: /* Return a copy of a list, vector, string or char-table.
485 The elements of a list or vector are not copied; they are shared
486 with the original. */)
490 if (NILP (arg
)) return arg
;
492 if (CHAR_TABLE_P (arg
))
497 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
498 /* Copy all the slots, including the extra ones. */
499 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
500 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
501 * sizeof (Lisp_Object
)));
503 /* Recursively copy any sub char tables in the ordinary slots
504 for multibyte characters. */
505 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
506 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
507 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
508 XCHAR_TABLE (copy
)->contents
[i
]
509 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
514 if (BOOL_VECTOR_P (arg
))
518 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
519 / BOOL_VECTOR_BITS_PER_CHAR
);
521 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
522 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
527 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
528 arg
= wrong_type_argument (Qsequencep
, arg
);
529 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
532 /* This structure holds information of an argument of `concat' that is
533 a string and has text properties to be copied. */
536 int argnum
; /* refer to ARGS (arguments of `concat') */
537 int from
; /* refer to ARGS[argnum] (argument string) */
538 int to
; /* refer to VAL (the target string) */
542 concat (nargs
, args
, target_type
, last_special
)
545 enum Lisp_Type target_type
;
549 register Lisp_Object tail
;
550 register Lisp_Object
this;
552 int toindex_byte
= 0;
553 register int result_len
;
554 register int result_len_byte
;
556 Lisp_Object last_tail
;
559 /* When we make a multibyte string, we can't copy text properties
560 while concatinating each string because the length of resulting
561 string can't be decided until we finish the whole concatination.
562 So, we record strings that have text properties to be copied
563 here, and copy the text properties after the concatination. */
564 struct textprop_rec
*textprops
= NULL
;
565 /* Number of elments in textprops. */
566 int num_textprops
= 0;
571 /* In append, the last arg isn't treated like the others */
572 if (last_special
&& nargs
> 0)
575 last_tail
= args
[nargs
];
580 /* Canonicalize each argument. */
581 for (argnum
= 0; argnum
< nargs
; argnum
++)
584 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
585 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
587 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
591 /* Compute total length in chars of arguments in RESULT_LEN.
592 If desired output is a string, also compute length in bytes
593 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
594 whether the result should be a multibyte string. */
598 for (argnum
= 0; argnum
< nargs
; argnum
++)
602 len
= XFASTINT (Flength (this));
603 if (target_type
== Lisp_String
)
605 /* We must count the number of bytes needed in the string
606 as well as the number of characters. */
612 for (i
= 0; i
< len
; i
++)
614 ch
= XVECTOR (this)->contents
[i
];
616 wrong_type_argument (Qintegerp
, ch
);
617 this_len_byte
= CHAR_BYTES (XINT (ch
));
618 result_len_byte
+= this_len_byte
;
619 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
622 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
623 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
624 else if (CONSP (this))
625 for (; CONSP (this); this = XCDR (this))
629 wrong_type_argument (Qintegerp
, ch
);
630 this_len_byte
= CHAR_BYTES (XINT (ch
));
631 result_len_byte
+= this_len_byte
;
632 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
635 else if (STRINGP (this))
637 if (STRING_MULTIBYTE (this))
640 result_len_byte
+= SBYTES (this);
643 result_len_byte
+= count_size_as_multibyte (SDATA (this),
651 if (! some_multibyte
)
652 result_len_byte
= result_len
;
654 /* Create the output object. */
655 if (target_type
== Lisp_Cons
)
656 val
= Fmake_list (make_number (result_len
), Qnil
);
657 else if (target_type
== Lisp_Vectorlike
)
658 val
= Fmake_vector (make_number (result_len
), Qnil
);
659 else if (some_multibyte
)
660 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
662 val
= make_uninit_string (result_len
);
664 /* In `append', if all but last arg are nil, return last arg. */
665 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
668 /* Copy the contents of the args into the result. */
670 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
672 toindex
= 0, toindex_byte
= 0;
676 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
678 for (argnum
= 0; argnum
< nargs
; argnum
++)
682 register unsigned int thisindex
= 0;
683 register unsigned int thisindex_byte
= 0;
687 thislen
= Flength (this), thisleni
= XINT (thislen
);
689 /* Between strings of the same kind, copy fast. */
690 if (STRINGP (this) && STRINGP (val
)
691 && STRING_MULTIBYTE (this) == some_multibyte
)
693 int thislen_byte
= SBYTES (this);
695 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
697 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
699 textprops
[num_textprops
].argnum
= argnum
;
700 textprops
[num_textprops
].from
= 0;
701 textprops
[num_textprops
++].to
= toindex
;
703 toindex_byte
+= thislen_byte
;
705 STRING_SET_CHARS (val
, SCHARS (val
));
707 /* Copy a single-byte string to a multibyte string. */
708 else if (STRINGP (this) && STRINGP (val
))
710 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
712 textprops
[num_textprops
].argnum
= argnum
;
713 textprops
[num_textprops
].from
= 0;
714 textprops
[num_textprops
++].to
= toindex
;
716 toindex_byte
+= copy_text (SDATA (this),
717 SDATA (val
) + toindex_byte
,
718 SCHARS (this), 0, 1);
722 /* Copy element by element. */
725 register Lisp_Object elt
;
727 /* Fetch next element of `this' arg into `elt', or break if
728 `this' is exhausted. */
729 if (NILP (this)) break;
731 elt
= XCAR (this), this = XCDR (this);
732 else if (thisindex
>= thisleni
)
734 else if (STRINGP (this))
737 if (STRING_MULTIBYTE (this))
739 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
742 XSETFASTINT (elt
, c
);
746 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
748 && (XINT (elt
) >= 0240
749 || (XINT (elt
) >= 0200
750 && ! NILP (Vnonascii_translation_table
)))
751 && XINT (elt
) < 0400)
753 c
= unibyte_char_to_multibyte (XINT (elt
));
758 else if (BOOL_VECTOR_P (this))
761 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
762 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
769 elt
= XVECTOR (this)->contents
[thisindex
++];
771 /* Store this element into the result. */
778 else if (VECTORP (val
))
779 XVECTOR (val
)->contents
[toindex
++] = elt
;
783 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
787 += CHAR_STRING (XINT (elt
),
788 SDATA (val
) + toindex_byte
);
790 SSET (val
, toindex_byte
++, XINT (elt
));
794 /* If we have any multibyte characters,
795 we already decided to make a multibyte string. */
798 /* P exists as a variable
799 to avoid a bug on the Masscomp C compiler. */
800 unsigned char *p
= SDATA (val
) + toindex_byte
;
802 toindex_byte
+= CHAR_STRING (c
, p
);
809 XSETCDR (prev
, last_tail
);
811 if (num_textprops
> 0)
814 int last_to_end
= -1;
816 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
818 this = args
[textprops
[argnum
].argnum
];
819 props
= text_property_list (this,
821 make_number (SCHARS (this)),
823 /* If successive arguments have properites, be sure that the
824 value of `composition' property be the copy. */
825 if (last_to_end
== textprops
[argnum
].to
)
826 make_composition_value_copy (props
);
827 add_text_properties_from_list (val
, props
,
828 make_number (textprops
[argnum
].to
));
829 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
837 static Lisp_Object string_char_byte_cache_string
;
838 static int string_char_byte_cache_charpos
;
839 static int string_char_byte_cache_bytepos
;
842 clear_string_char_byte_cache ()
844 string_char_byte_cache_string
= Qnil
;
847 /* Return the character index corresponding to CHAR_INDEX in STRING. */
850 string_char_to_byte (string
, char_index
)
855 int best_below
, best_below_byte
;
856 int best_above
, best_above_byte
;
858 best_below
= best_below_byte
= 0;
859 best_above
= SCHARS (string
);
860 best_above_byte
= SBYTES (string
);
861 if (best_above
== best_above_byte
)
864 if (EQ (string
, string_char_byte_cache_string
))
866 if (string_char_byte_cache_charpos
< char_index
)
868 best_below
= string_char_byte_cache_charpos
;
869 best_below_byte
= string_char_byte_cache_bytepos
;
873 best_above
= string_char_byte_cache_charpos
;
874 best_above_byte
= string_char_byte_cache_bytepos
;
878 if (char_index
- best_below
< best_above
- char_index
)
880 while (best_below
< char_index
)
883 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
884 best_below
, best_below_byte
);
887 i_byte
= best_below_byte
;
891 while (best_above
> char_index
)
893 unsigned char *pend
= SDATA (string
) + best_above_byte
;
894 unsigned char *pbeg
= pend
- best_above_byte
;
895 unsigned char *p
= pend
- 1;
898 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
899 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
900 if (bytes
== pend
- p
)
901 best_above_byte
-= bytes
;
902 else if (bytes
> pend
- p
)
903 best_above_byte
-= (pend
- p
);
909 i_byte
= best_above_byte
;
912 string_char_byte_cache_bytepos
= i_byte
;
913 string_char_byte_cache_charpos
= i
;
914 string_char_byte_cache_string
= string
;
919 /* Return the character index corresponding to BYTE_INDEX in STRING. */
922 string_byte_to_char (string
, byte_index
)
927 int best_below
, best_below_byte
;
928 int best_above
, best_above_byte
;
930 best_below
= best_below_byte
= 0;
931 best_above
= SCHARS (string
);
932 best_above_byte
= SBYTES (string
);
933 if (best_above
== best_above_byte
)
936 if (EQ (string
, string_char_byte_cache_string
))
938 if (string_char_byte_cache_bytepos
< byte_index
)
940 best_below
= string_char_byte_cache_charpos
;
941 best_below_byte
= string_char_byte_cache_bytepos
;
945 best_above
= string_char_byte_cache_charpos
;
946 best_above_byte
= string_char_byte_cache_bytepos
;
950 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
952 while (best_below_byte
< byte_index
)
955 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
956 best_below
, best_below_byte
);
959 i_byte
= best_below_byte
;
963 while (best_above_byte
> byte_index
)
965 unsigned char *pend
= SDATA (string
) + best_above_byte
;
966 unsigned char *pbeg
= pend
- best_above_byte
;
967 unsigned char *p
= pend
- 1;
970 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
971 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
972 if (bytes
== pend
- p
)
973 best_above_byte
-= bytes
;
974 else if (bytes
> pend
- p
)
975 best_above_byte
-= (pend
- p
);
981 i_byte
= best_above_byte
;
984 string_char_byte_cache_bytepos
= i_byte
;
985 string_char_byte_cache_charpos
= i
;
986 string_char_byte_cache_string
= string
;
991 /* Convert STRING to a multibyte string.
992 Single-byte characters 0240 through 0377 are converted
993 by adding nonascii_insert_offset to each. */
996 string_make_multibyte (string
)
1004 if (STRING_MULTIBYTE (string
))
1007 nbytes
= count_size_as_multibyte (SDATA (string
),
1009 /* If all the chars are ASCII, they won't need any more bytes
1010 once converted. In that case, we can return STRING itself. */
1011 if (nbytes
== SBYTES (string
))
1014 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1015 copy_text (SDATA (string
), buf
, SBYTES (string
),
1018 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1025 /* Convert STRING to a multibyte string without changing each
1026 character codes. Thus, characters 0200 trough 0237 are converted
1027 to eight-bit-control characters, and characters 0240 through 0377
1028 are converted eight-bit-graphic characters. */
1031 string_to_multibyte (string
)
1039 if (STRING_MULTIBYTE (string
))
1042 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1043 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1044 any more bytes once converted. */
1045 if (nbytes
== SBYTES (string
))
1046 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1048 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1049 bcopy (SDATA (string
), buf
, SBYTES (string
));
1050 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1052 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1059 /* Convert STRING to a single-byte string. */
1062 string_make_unibyte (string
)
1070 if (! STRING_MULTIBYTE (string
))
1073 nchars
= SCHARS (string
);
1075 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1076 copy_text (SDATA (string
), buf
, SBYTES (string
),
1079 ret
= make_unibyte_string (buf
, nchars
);
1085 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1087 doc
: /* Return the multibyte equivalent of STRING.
1088 If STRING is unibyte and contains non-ASCII characters, the function
1089 `unibyte-char-to-multibyte' is used to convert each unibyte character
1090 to a multibyte character. In this case, the returned string is a
1091 newly created string with no text properties. If STRING is multibyte
1092 or entirely ASCII, it is returned unchanged. In particular, when
1093 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1094 \(When the characters are all ASCII, Emacs primitives will treat the
1095 string the same way whether it is unibyte or multibyte.) */)
1099 CHECK_STRING (string
);
1101 return string_make_multibyte (string
);
1104 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1106 doc
: /* Return the unibyte equivalent of STRING.
1107 Multibyte character codes are converted to unibyte according to
1108 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1109 If the lookup in the translation table fails, this function takes just
1110 the low 8 bits of each character. */)
1114 CHECK_STRING (string
);
1116 return string_make_unibyte (string
);
1119 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1121 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1122 If STRING is unibyte, the result is STRING itself.
1123 Otherwise it is a newly created string, with no text properties.
1124 If STRING is multibyte and contains a character of charset
1125 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1126 corresponding single byte. */)
1130 CHECK_STRING (string
);
1132 if (STRING_MULTIBYTE (string
))
1134 int bytes
= SBYTES (string
);
1135 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1137 bcopy (SDATA (string
), str
, bytes
);
1138 bytes
= str_as_unibyte (str
, bytes
);
1139 string
= make_unibyte_string (str
, bytes
);
1145 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1147 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1148 If STRING is multibyte, the result is STRING itself.
1149 Otherwise it is a newly created string, with no text properties.
1150 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1151 part of a multibyte form), it is converted to the corresponding
1152 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.
1153 Beware, this often doesn't really do what you think it does.
1154 It is similar to (decode-coding-string STRING 'emacs-mule-unix).
1155 If you're not sure, whether to use `string-as-multibyte' or
1156 `string-to-multibyte', use `string-to-multibyte'. Beware:
1157 (aref (string-as-multibyte "\\201") 0) -> 129 (aka ?\\201)
1158 (aref (string-as-multibyte "\\300") 0) -> 192 (aka ?\\300)
1159 (aref (string-as-multibyte "\\300\\201") 0) -> 192 (aka ?\\300)
1160 (aref (string-as-multibyte "\\300\\201") 1) -> 129 (aka ?\\201)
1162 (aref (string-as-multibyte "\\201\\300") 0) -> 2240
1163 (aref (string-as-multibyte "\\201\\300") 1) -> <error> */)
1167 CHECK_STRING (string
);
1169 if (! STRING_MULTIBYTE (string
))
1171 Lisp_Object new_string
;
1174 parse_str_as_multibyte (SDATA (string
),
1177 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1178 bcopy (SDATA (string
), SDATA (new_string
),
1180 if (nbytes
!= SBYTES (string
))
1181 str_as_multibyte (SDATA (new_string
), nbytes
,
1182 SBYTES (string
), NULL
);
1183 string
= new_string
;
1184 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1189 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1191 doc
: /* Return a multibyte string with the same individual chars as STRING.
1192 If STRING is multibyte, the result is STRING itself.
1193 Otherwise it is a newly created string, with no text properties.
1194 Characters 0200 through 0237 are converted to eight-bit-control
1195 characters of the same character code. Characters 0240 through 0377
1196 are converted to eight-bit-graphic characters of the same character
1198 This is similar to (decode-coding-string STRING 'binary) */)
1202 CHECK_STRING (string
);
1204 return string_to_multibyte (string
);
1208 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1209 doc
: /* Return a copy of ALIST.
1210 This is an alist which represents the same mapping from objects to objects,
1211 but does not share the alist structure with ALIST.
1212 The objects mapped (cars and cdrs of elements of the alist)
1213 are shared, however.
1214 Elements of ALIST that are not conses are also shared. */)
1218 register Lisp_Object tem
;
1223 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1224 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1226 register Lisp_Object car
;
1230 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1235 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1236 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1237 TO may be nil or omitted; then the substring runs to the end of STRING.
1238 FROM and TO start at 0. If either is negative, it counts from the end.
1240 This function allows vectors as well as strings. */)
1243 register Lisp_Object from
, to
;
1248 int from_char
, to_char
;
1249 int from_byte
= 0, to_byte
= 0;
1251 if (! (STRINGP (string
) || VECTORP (string
)))
1252 wrong_type_argument (Qarrayp
, string
);
1254 CHECK_NUMBER (from
);
1256 if (STRINGP (string
))
1258 size
= SCHARS (string
);
1259 size_byte
= SBYTES (string
);
1262 size
= XVECTOR (string
)->size
;
1267 to_byte
= size_byte
;
1273 to_char
= XINT (to
);
1277 if (STRINGP (string
))
1278 to_byte
= string_char_to_byte (string
, to_char
);
1281 from_char
= XINT (from
);
1284 if (STRINGP (string
))
1285 from_byte
= string_char_to_byte (string
, from_char
);
1287 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1288 args_out_of_range_3 (string
, make_number (from_char
),
1289 make_number (to_char
));
1291 if (STRINGP (string
))
1293 res
= make_specified_string (SDATA (string
) + from_byte
,
1294 to_char
- from_char
, to_byte
- from_byte
,
1295 STRING_MULTIBYTE (string
));
1296 copy_text_properties (make_number (from_char
), make_number (to_char
),
1297 string
, make_number (0), res
, Qnil
);
1300 res
= Fvector (to_char
- from_char
,
1301 XVECTOR (string
)->contents
+ from_char
);
1307 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1308 doc
: /* Return a substring of STRING, without text properties.
1309 It starts at index FROM and ending before TO.
1310 TO may be nil or omitted; then the substring runs to the end of STRING.
1311 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1312 If FROM or TO is negative, it counts from the end.
1314 With one argument, just copy STRING without its properties. */)
1317 register Lisp_Object from
, to
;
1319 int size
, size_byte
;
1320 int from_char
, to_char
;
1321 int from_byte
, to_byte
;
1323 CHECK_STRING (string
);
1325 size
= SCHARS (string
);
1326 size_byte
= SBYTES (string
);
1329 from_char
= from_byte
= 0;
1332 CHECK_NUMBER (from
);
1333 from_char
= XINT (from
);
1337 from_byte
= string_char_to_byte (string
, from_char
);
1343 to_byte
= size_byte
;
1349 to_char
= XINT (to
);
1353 to_byte
= string_char_to_byte (string
, to_char
);
1356 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1357 args_out_of_range_3 (string
, make_number (from_char
),
1358 make_number (to_char
));
1360 return make_specified_string (SDATA (string
) + from_byte
,
1361 to_char
- from_char
, to_byte
- from_byte
,
1362 STRING_MULTIBYTE (string
));
1365 /* Extract a substring of STRING, giving start and end positions
1366 both in characters and in bytes. */
1369 substring_both (string
, from
, from_byte
, to
, to_byte
)
1371 int from
, from_byte
, to
, to_byte
;
1377 if (! (STRINGP (string
) || VECTORP (string
)))
1378 wrong_type_argument (Qarrayp
, string
);
1380 if (STRINGP (string
))
1382 size
= SCHARS (string
);
1383 size_byte
= SBYTES (string
);
1386 size
= XVECTOR (string
)->size
;
1388 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1389 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1391 if (STRINGP (string
))
1393 res
= make_specified_string (SDATA (string
) + from_byte
,
1394 to
- from
, to_byte
- from_byte
,
1395 STRING_MULTIBYTE (string
));
1396 copy_text_properties (make_number (from
), make_number (to
),
1397 string
, make_number (0), res
, Qnil
);
1400 res
= Fvector (to
- from
,
1401 XVECTOR (string
)->contents
+ from
);
1406 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1407 doc
: /* Take cdr N times on LIST, returns the result. */)
1410 register Lisp_Object list
;
1412 register int i
, num
;
1415 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1419 wrong_type_argument (Qlistp
, list
);
1425 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1426 doc
: /* Return the Nth element of LIST.
1427 N counts from zero. If LIST is not that long, nil is returned. */)
1429 Lisp_Object n
, list
;
1431 return Fcar (Fnthcdr (n
, list
));
1434 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1435 doc
: /* Return element of SEQUENCE at index N. */)
1437 register Lisp_Object sequence
, n
;
1442 if (CONSP (sequence
) || NILP (sequence
))
1443 return Fcar (Fnthcdr (n
, sequence
));
1444 else if (STRINGP (sequence
) || VECTORP (sequence
)
1445 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1446 return Faref (sequence
, n
);
1448 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1452 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1453 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1454 The value is actually the tail of LIST whose car is ELT. */)
1456 register Lisp_Object elt
;
1459 register Lisp_Object tail
;
1460 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1462 register Lisp_Object tem
;
1464 wrong_type_argument (Qlistp
, list
);
1466 if (! NILP (Fequal (elt
, tem
)))
1473 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1474 doc
: /* Return non-nil if ELT is an element of LIST.
1475 Comparison done with `eq'. The value is actually the tail of LIST
1476 whose car is ELT. */)
1478 Lisp_Object elt
, list
;
1482 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1486 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1490 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1497 if (!CONSP (list
) && !NILP (list
))
1498 list
= wrong_type_argument (Qlistp
, list
);
1503 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1504 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1505 The value is actually the first element of LIST whose car is KEY.
1506 Elements of LIST that are not conses are ignored. */)
1508 Lisp_Object key
, list
;
1515 || (CONSP (XCAR (list
))
1516 && EQ (XCAR (XCAR (list
)), key
)))
1521 || (CONSP (XCAR (list
))
1522 && EQ (XCAR (XCAR (list
)), key
)))
1527 || (CONSP (XCAR (list
))
1528 && EQ (XCAR (XCAR (list
)), key
)))
1536 result
= XCAR (list
);
1537 else if (NILP (list
))
1540 result
= wrong_type_argument (Qlistp
, list
);
1545 /* Like Fassq but never report an error and do not allow quits.
1546 Use only on lists known never to be circular. */
1549 assq_no_quit (key
, list
)
1550 Lisp_Object key
, list
;
1553 && (!CONSP (XCAR (list
))
1554 || !EQ (XCAR (XCAR (list
)), key
)))
1557 return CONSP (list
) ? XCAR (list
) : Qnil
;
1560 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1561 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1562 The value is actually the first element of LIST whose car equals KEY. */)
1564 Lisp_Object key
, list
;
1566 Lisp_Object result
, car
;
1571 || (CONSP (XCAR (list
))
1572 && (car
= XCAR (XCAR (list
)),
1573 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1578 || (CONSP (XCAR (list
))
1579 && (car
= XCAR (XCAR (list
)),
1580 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1585 || (CONSP (XCAR (list
))
1586 && (car
= XCAR (XCAR (list
)),
1587 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1595 result
= XCAR (list
);
1596 else if (NILP (list
))
1599 result
= wrong_type_argument (Qlistp
, list
);
1604 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1605 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1606 The value is actually the first element of LIST whose cdr is KEY. */)
1608 register Lisp_Object key
;
1616 || (CONSP (XCAR (list
))
1617 && EQ (XCDR (XCAR (list
)), key
)))
1622 || (CONSP (XCAR (list
))
1623 && EQ (XCDR (XCAR (list
)), key
)))
1628 || (CONSP (XCAR (list
))
1629 && EQ (XCDR (XCAR (list
)), key
)))
1638 else if (CONSP (list
))
1639 result
= XCAR (list
);
1641 result
= wrong_type_argument (Qlistp
, list
);
1646 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1647 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1648 The value is actually the first element of LIST whose cdr equals KEY. */)
1650 Lisp_Object key
, list
;
1652 Lisp_Object result
, cdr
;
1657 || (CONSP (XCAR (list
))
1658 && (cdr
= XCDR (XCAR (list
)),
1659 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1664 || (CONSP (XCAR (list
))
1665 && (cdr
= XCDR (XCAR (list
)),
1666 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1671 || (CONSP (XCAR (list
))
1672 && (cdr
= XCDR (XCAR (list
)),
1673 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1681 result
= XCAR (list
);
1682 else if (NILP (list
))
1685 result
= wrong_type_argument (Qlistp
, list
);
1690 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1691 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1692 The modified LIST is returned. Comparison is done with `eq'.
1693 If the first member of LIST is ELT, there is no way to remove it by side effect;
1694 therefore, write `(setq foo (delq element foo))'
1695 to be sure of changing the value of `foo'. */)
1697 register Lisp_Object elt
;
1700 register Lisp_Object tail
, prev
;
1701 register Lisp_Object tem
;
1705 while (!NILP (tail
))
1708 wrong_type_argument (Qlistp
, list
);
1715 Fsetcdr (prev
, XCDR (tail
));
1725 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1726 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1727 SEQ must be a list, a vector, or a string.
1728 The modified SEQ is returned. Comparison is done with `equal'.
1729 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1730 is not a side effect; it is simply using a different sequence.
1731 Therefore, write `(setq foo (delete element foo))'
1732 to be sure of changing the value of `foo'. */)
1734 Lisp_Object elt
, seq
;
1740 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1741 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1744 if (n
!= ASIZE (seq
))
1746 struct Lisp_Vector
*p
= allocate_vector (n
);
1748 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1749 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1750 p
->contents
[n
++] = AREF (seq
, i
);
1752 XSETVECTOR (seq
, p
);
1755 else if (STRINGP (seq
))
1757 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1760 for (i
= nchars
= nbytes
= ibyte
= 0;
1762 ++i
, ibyte
+= cbytes
)
1764 if (STRING_MULTIBYTE (seq
))
1766 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1767 SBYTES (seq
) - ibyte
);
1768 cbytes
= CHAR_BYTES (c
);
1776 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1783 if (nchars
!= SCHARS (seq
))
1787 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1788 if (!STRING_MULTIBYTE (seq
))
1789 STRING_SET_UNIBYTE (tem
);
1791 for (i
= nchars
= nbytes
= ibyte
= 0;
1793 ++i
, ibyte
+= cbytes
)
1795 if (STRING_MULTIBYTE (seq
))
1797 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1798 SBYTES (seq
) - ibyte
);
1799 cbytes
= CHAR_BYTES (c
);
1807 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1809 unsigned char *from
= SDATA (seq
) + ibyte
;
1810 unsigned char *to
= SDATA (tem
) + nbytes
;
1816 for (n
= cbytes
; n
--; )
1826 Lisp_Object tail
, prev
;
1828 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1831 wrong_type_argument (Qlistp
, seq
);
1833 if (!NILP (Fequal (elt
, XCAR (tail
))))
1838 Fsetcdr (prev
, XCDR (tail
));
1849 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1850 doc
: /* Reverse LIST by modifying cdr pointers.
1851 Return the reversed list. */)
1855 register Lisp_Object prev
, tail
, next
;
1857 if (NILP (list
)) return list
;
1860 while (!NILP (tail
))
1864 wrong_type_argument (Qlistp
, list
);
1866 Fsetcdr (tail
, prev
);
1873 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1874 doc
: /* Reverse LIST, copying. Return the reversed list.
1875 See also the function `nreverse', which is used more often. */)
1881 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1884 new = Fcons (XCAR (list
), new);
1887 wrong_type_argument (Qconsp
, list
);
1891 Lisp_Object
merge ();
1893 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1894 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1895 Returns the sorted list. LIST is modified by side effects.
1896 PREDICATE is called with two elements of LIST, and should return non-nil
1897 if the first element should sort before the second. */)
1899 Lisp_Object list
, predicate
;
1901 Lisp_Object front
, back
;
1902 register Lisp_Object len
, tem
;
1903 struct gcpro gcpro1
, gcpro2
;
1904 register int length
;
1907 len
= Flength (list
);
1908 length
= XINT (len
);
1912 XSETINT (len
, (length
/ 2) - 1);
1913 tem
= Fnthcdr (len
, list
);
1915 Fsetcdr (tem
, Qnil
);
1917 GCPRO2 (front
, back
);
1918 front
= Fsort (front
, predicate
);
1919 back
= Fsort (back
, predicate
);
1921 return merge (front
, back
, predicate
);
1925 merge (org_l1
, org_l2
, pred
)
1926 Lisp_Object org_l1
, org_l2
;
1930 register Lisp_Object tail
;
1932 register Lisp_Object l1
, l2
;
1933 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1940 /* It is sufficient to protect org_l1 and org_l2.
1941 When l1 and l2 are updated, we copy the new values
1942 back into the org_ vars. */
1943 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1963 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1979 Fsetcdr (tail
, tem
);
1985 #if 0 /* Unsafe version. */
1986 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1987 doc
: /* Extract a value from a property list.
1988 PLIST is a property list, which is a list of the form
1989 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1990 corresponding to the given PROP, or nil if PROP is not
1991 one of the properties on the list. */)
1999 CONSP (tail
) && CONSP (XCDR (tail
));
2000 tail
= XCDR (XCDR (tail
)))
2002 if (EQ (prop
, XCAR (tail
)))
2003 return XCAR (XCDR (tail
));
2005 /* This function can be called asynchronously
2006 (setup_coding_system). Don't QUIT in that case. */
2007 if (!interrupt_input_blocked
)
2012 wrong_type_argument (Qlistp
, prop
);
2018 /* This does not check for quits. That is safe since it must terminate. */
2020 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2021 doc
: /* Extract a value from a property list.
2022 PLIST is a property list, which is a list of the form
2023 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2024 corresponding to the given PROP, or nil if PROP is not one of the
2025 properties on the list. This function never signals an error. */)
2030 Lisp_Object tail
, halftail
;
2032 /* halftail is used to detect circular lists. */
2033 tail
= halftail
= plist
;
2034 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2036 if (EQ (prop
, XCAR (tail
)))
2037 return XCAR (XCDR (tail
));
2039 tail
= XCDR (XCDR (tail
));
2040 halftail
= XCDR (halftail
);
2041 if (EQ (tail
, halftail
))
2048 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2049 doc
: /* Return the value of SYMBOL's PROPNAME property.
2050 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2052 Lisp_Object symbol
, propname
;
2054 CHECK_SYMBOL (symbol
);
2055 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2058 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2059 doc
: /* Change value in PLIST of PROP to VAL.
2060 PLIST is a property list, which is a list of the form
2061 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2062 If PROP is already a property on the list, its value is set to VAL,
2063 otherwise the new PROP VAL pair is added. The new plist is returned;
2064 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2065 The PLIST is modified by side effects. */)
2068 register Lisp_Object prop
;
2071 register Lisp_Object tail
, prev
;
2072 Lisp_Object newcell
;
2074 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2075 tail
= XCDR (XCDR (tail
)))
2077 if (EQ (prop
, XCAR (tail
)))
2079 Fsetcar (XCDR (tail
), val
);
2086 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2090 Fsetcdr (XCDR (prev
), newcell
);
2094 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2095 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2096 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2097 (symbol
, propname
, value
)
2098 Lisp_Object symbol
, propname
, value
;
2100 CHECK_SYMBOL (symbol
);
2101 XSYMBOL (symbol
)->plist
2102 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2106 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2107 doc
: /* Extract a value from a property list, comparing with `equal'.
2108 PLIST is a property list, which is a list of the form
2109 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2110 corresponding to the given PROP, or nil if PROP is not
2111 one of the properties on the list. */)
2119 CONSP (tail
) && CONSP (XCDR (tail
));
2120 tail
= XCDR (XCDR (tail
)))
2122 if (! NILP (Fequal (prop
, XCAR (tail
))))
2123 return XCAR (XCDR (tail
));
2129 wrong_type_argument (Qlistp
, prop
);
2134 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2135 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2136 PLIST is a property list, which is a list of the form
2137 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2138 If PROP is already a property on the list, its value is set to VAL,
2139 otherwise the new PROP VAL pair is added. The new plist is returned;
2140 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2141 The PLIST is modified by side effects. */)
2144 register Lisp_Object prop
;
2147 register Lisp_Object tail
, prev
;
2148 Lisp_Object newcell
;
2150 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2151 tail
= XCDR (XCDR (tail
)))
2153 if (! NILP (Fequal (prop
, XCAR (tail
))))
2155 Fsetcar (XCDR (tail
), val
);
2162 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2166 Fsetcdr (XCDR (prev
), newcell
);
2170 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2171 doc
: /* Return t if the two args are the same Lisp object.
2172 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2174 Lisp_Object obj1
, obj2
;
2177 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2179 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2182 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2183 doc
: /* Return t if two Lisp objects have similar structure and contents.
2184 They must have the same data type.
2185 Conses are compared by comparing the cars and the cdrs.
2186 Vectors and strings are compared element by element.
2187 Numbers are compared by value, but integers cannot equal floats.
2188 (Use `=' if you want integers and floats to be able to be equal.)
2189 Symbols must match exactly. */)
2191 register Lisp_Object o1
, o2
;
2193 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2196 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2197 doc
: /* Return t if two Lisp objects have similar structure and contents.
2198 This is like `equal' except that it compares the text properties
2199 of strings. (`equal' ignores text properties.) */)
2201 register Lisp_Object o1
, o2
;
2203 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2206 /* DEPTH is current depth of recursion. Signal an error if it
2208 PROPS, if non-nil, means compare string text properties too. */
2211 internal_equal (o1
, o2
, depth
, props
)
2212 register Lisp_Object o1
, o2
;
2216 error ("Stack overflow in equal");
2222 if (XTYPE (o1
) != XTYPE (o2
))
2231 d1
= extract_float (o1
);
2232 d2
= extract_float (o2
);
2233 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2234 though they are not =. */
2235 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2239 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2246 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2250 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2252 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2255 o1
= XOVERLAY (o1
)->plist
;
2256 o2
= XOVERLAY (o2
)->plist
;
2261 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2262 && (XMARKER (o1
)->buffer
== 0
2263 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2267 case Lisp_Vectorlike
:
2270 EMACS_INT size
= XVECTOR (o1
)->size
;
2271 /* Pseudovectors have the type encoded in the size field, so this test
2272 actually checks that the objects have the same type as well as the
2274 if (XVECTOR (o2
)->size
!= size
)
2276 /* Boolvectors are compared much like strings. */
2277 if (BOOL_VECTOR_P (o1
))
2280 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2281 / BOOL_VECTOR_BITS_PER_CHAR
);
2283 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2285 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2290 if (WINDOW_CONFIGURATIONP (o1
))
2291 return compare_window_configurations (o1
, o2
, 0);
2293 /* Aside from them, only true vectors, char-tables, and compiled
2294 functions are sensible to compare, so eliminate the others now. */
2295 if (size
& PSEUDOVECTOR_FLAG
)
2297 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2299 size
&= PSEUDOVECTOR_SIZE_MASK
;
2301 for (i
= 0; i
< size
; i
++)
2304 v1
= XVECTOR (o1
)->contents
[i
];
2305 v2
= XVECTOR (o2
)->contents
[i
];
2306 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2314 if (SCHARS (o1
) != SCHARS (o2
))
2316 if (SBYTES (o1
) != SBYTES (o2
))
2318 if (bcmp (SDATA (o1
), SDATA (o2
),
2321 if (props
&& !compare_string_intervals (o1
, o2
))
2327 case Lisp_Type_Limit
:
2334 extern Lisp_Object
Fmake_char_internal ();
2336 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2337 doc
: /* Store each element of ARRAY with ITEM.
2338 ARRAY is a vector, string, char-table, or bool-vector. */)
2340 Lisp_Object array
, item
;
2342 register int size
, index
, charval
;
2344 if (VECTORP (array
))
2346 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2347 size
= XVECTOR (array
)->size
;
2348 for (index
= 0; index
< size
; index
++)
2351 else if (CHAR_TABLE_P (array
))
2353 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2354 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2355 for (index
= 0; index
< size
; index
++)
2357 XCHAR_TABLE (array
)->defalt
= Qnil
;
2359 else if (STRINGP (array
))
2361 register unsigned char *p
= SDATA (array
);
2362 CHECK_NUMBER (item
);
2363 charval
= XINT (item
);
2364 size
= SCHARS (array
);
2365 if (STRING_MULTIBYTE (array
))
2367 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2368 int len
= CHAR_STRING (charval
, str
);
2369 int size_byte
= SBYTES (array
);
2370 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2373 if (size
!= size_byte
)
2376 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2377 if (len
!= this_len
)
2378 error ("Attempt to change byte length of a string");
2381 for (i
= 0; i
< size_byte
; i
++)
2382 *p
++ = str
[i
% len
];
2385 for (index
= 0; index
< size
; index
++)
2388 else if (BOOL_VECTOR_P (array
))
2390 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2392 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2393 / BOOL_VECTOR_BITS_PER_CHAR
);
2395 charval
= (! NILP (item
) ? -1 : 0);
2396 for (index
= 0; index
< size_in_chars
- 1; index
++)
2398 if (index
< size_in_chars
)
2400 /* Mask out bits beyond the vector size. */
2401 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2402 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2408 array
= wrong_type_argument (Qarrayp
, array
);
2414 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2416 doc
: /* Clear the contents of STRING.
2417 This makes STRING unibyte and may change its length. */)
2422 CHECK_STRING (string
);
2423 len
= SBYTES (string
);
2424 bzero (SDATA (string
), len
);
2425 STRING_SET_CHARS (string
, len
);
2426 STRING_SET_UNIBYTE (string
);
2430 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2432 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2434 Lisp_Object char_table
;
2436 CHECK_CHAR_TABLE (char_table
);
2438 return XCHAR_TABLE (char_table
)->purpose
;
2441 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2443 doc
: /* Return the parent char-table of CHAR-TABLE.
2444 The value is either nil or another char-table.
2445 If CHAR-TABLE holds nil for a given character,
2446 then the actual applicable value is inherited from the parent char-table
2447 \(or from its parents, if necessary). */)
2449 Lisp_Object char_table
;
2451 CHECK_CHAR_TABLE (char_table
);
2453 return XCHAR_TABLE (char_table
)->parent
;
2456 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2458 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2459 Return PARENT. PARENT must be either nil or another char-table. */)
2460 (char_table
, parent
)
2461 Lisp_Object char_table
, parent
;
2465 CHECK_CHAR_TABLE (char_table
);
2469 CHECK_CHAR_TABLE (parent
);
2471 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2472 if (EQ (temp
, char_table
))
2473 error ("Attempt to make a chartable be its own parent");
2476 XCHAR_TABLE (char_table
)->parent
= parent
;
2481 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2483 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2485 Lisp_Object char_table
, n
;
2487 CHECK_CHAR_TABLE (char_table
);
2490 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2491 args_out_of_range (char_table
, n
);
2493 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2496 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2497 Sset_char_table_extra_slot
,
2499 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2500 (char_table
, n
, value
)
2501 Lisp_Object char_table
, n
, value
;
2503 CHECK_CHAR_TABLE (char_table
);
2506 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2507 args_out_of_range (char_table
, n
);
2509 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2513 char_table_range (table
, from
, to
, defalt
)
2520 if (! NILP (XCHAR_TABLE (table
)->defalt
))
2521 defalt
= XCHAR_TABLE (table
)->defalt
;
2522 val
= XCHAR_TABLE (table
)->contents
[from
];
2523 if (SUB_CHAR_TABLE_P (val
))
2524 val
= char_table_range (val
, 32, 127, defalt
);
2525 else if (NILP (val
))
2527 for (from
++; from
<= to
; from
++)
2529 Lisp_Object this_val
;
2531 this_val
= XCHAR_TABLE (table
)->contents
[from
];
2532 if (SUB_CHAR_TABLE_P (this_val
))
2533 this_val
= char_table_range (this_val
, 32, 127, defalt
);
2534 else if (NILP (this_val
))
2536 if (! EQ (val
, this_val
))
2537 error ("Characters in the range have inconsistent values");
2543 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2545 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2546 RANGE should be nil (for the default value),
2547 a vector which identifies a character set or a row of a character set,
2548 a character set name, or a character code.
2549 If the characters in the specified range have different values,
2550 an error is signaled.
2552 Note that this function doesn't check the parent of CHAR-TABLE. */)
2554 Lisp_Object char_table
, range
;
2556 int charset_id
, c1
= 0, c2
= 0;
2558 Lisp_Object ch
, val
, current_default
;
2560 CHECK_CHAR_TABLE (char_table
);
2562 if (EQ (range
, Qnil
))
2563 return XCHAR_TABLE (char_table
)->defalt
;
2564 if (INTEGERP (range
))
2566 int c
= XINT (range
);
2567 if (! CHAR_VALID_P (c
, 0))
2568 error ("Invalid character code: %d", c
);
2570 SPLIT_CHAR (c
, charset_id
, c1
, c2
);
2572 else if (SYMBOLP (range
))
2574 Lisp_Object charset_info
;
2576 charset_info
= Fget (range
, Qcharset
);
2577 CHECK_VECTOR (charset_info
);
2578 charset_id
= XINT (XVECTOR (charset_info
)->contents
[0]);
2579 ch
= Fmake_char_internal (make_number (charset_id
),
2580 make_number (0), make_number (0));
2582 else if (VECTORP (range
))
2584 size
= ASIZE (range
);
2586 args_out_of_range (range
, make_number (0));
2587 CHECK_NUMBER (AREF (range
, 0));
2588 charset_id
= XINT (AREF (range
, 0));
2591 CHECK_NUMBER (AREF (range
, 1));
2592 c1
= XINT (AREF (range
, 1));
2595 CHECK_NUMBER (AREF (range
, 2));
2596 c2
= XINT (AREF (range
, 2));
2600 /* This checks if charset_id, c0, and c1 are all valid or not. */
2601 ch
= Fmake_char_internal (make_number (charset_id
),
2602 make_number (c1
), make_number (c2
));
2605 error ("Invalid RANGE argument to `char-table-range'");
2607 if (c1
> 0 && (CHARSET_DIMENSION (charset_id
) == 1 || c2
> 0))
2609 /* Fully specified character. */
2610 Lisp_Object parent
= XCHAR_TABLE (char_table
)->parent
;
2612 XCHAR_TABLE (char_table
)->parent
= Qnil
;
2613 val
= Faref (char_table
, ch
);
2614 XCHAR_TABLE (char_table
)->parent
= parent
;
2618 current_default
= XCHAR_TABLE (char_table
)->defalt
;
2619 if (charset_id
== CHARSET_ASCII
2620 || charset_id
== CHARSET_8_BIT_CONTROL
2621 || charset_id
== CHARSET_8_BIT_GRAPHIC
)
2623 int from
, to
, defalt
;
2625 if (charset_id
== CHARSET_ASCII
)
2626 from
= 0, to
= 127, defalt
= CHAR_TABLE_DEFAULT_SLOT_ASCII
;
2627 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2628 from
= 128, to
= 159, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
;
2630 from
= 160, to
= 255, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
;
2631 if (! NILP (XCHAR_TABLE (char_table
)->contents
[defalt
]))
2632 current_default
= XCHAR_TABLE (char_table
)->contents
[defalt
];
2633 return char_table_range (char_table
, from
, to
, current_default
);
2636 val
= XCHAR_TABLE (char_table
)->contents
[128 + charset_id
];
2637 if (! SUB_CHAR_TABLE_P (val
))
2638 return (NILP (val
) ? current_default
: val
);
2639 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2640 current_default
= XCHAR_TABLE (val
)->defalt
;
2642 return char_table_range (val
, 32, 127, current_default
);
2643 val
= XCHAR_TABLE (val
)->contents
[c1
];
2644 if (! SUB_CHAR_TABLE_P (val
))
2645 return (NILP (val
) ? current_default
: val
);
2646 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2647 current_default
= XCHAR_TABLE (val
)->defalt
;
2648 return char_table_range (val
, 32, 127, current_default
);
2651 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2653 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2654 RANGE should be t (for all characters), nil (for the default value),
2655 a character set, a vector which identifies a character set, a row of a
2656 character set, or a character code. Return VALUE. */)
2657 (char_table
, range
, value
)
2658 Lisp_Object char_table
, range
, value
;
2662 CHECK_CHAR_TABLE (char_table
);
2665 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2667 /* Don't set these special slots used for default values of
2668 ascii, eight-bit-control, and eight-bit-graphic. */
2669 if (i
!= CHAR_TABLE_DEFAULT_SLOT_ASCII
2670 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2671 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
)
2672 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2674 else if (EQ (range
, Qnil
))
2675 XCHAR_TABLE (char_table
)->defalt
= value
;
2676 else if (SYMBOLP (range
))
2678 Lisp_Object charset_info
;
2681 charset_info
= Fget (range
, Qcharset
);
2682 if (! VECTORP (charset_info
)
2683 || ! NATNUMP (AREF (charset_info
, 0))
2684 || (charset_id
= XINT (AREF (charset_info
, 0)),
2685 ! CHARSET_DEFINED_P (charset_id
)))
2686 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2688 if (charset_id
== CHARSET_ASCII
)
2689 for (i
= 0; i
< 128; i
++)
2690 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2691 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2692 for (i
= 128; i
< 160; i
++)
2693 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2694 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2695 for (i
= 160; i
< 256; i
++)
2696 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2698 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2700 else if (INTEGERP (range
))
2701 Faset (char_table
, range
, value
);
2702 else if (VECTORP (range
))
2704 int size
= XVECTOR (range
)->size
;
2705 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2706 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2707 size
<= 1 ? Qnil
: val
[1],
2708 size
<= 2 ? Qnil
: val
[2]);
2709 Faset (char_table
, ch
, value
);
2712 error ("Invalid RANGE argument to `set-char-table-range'");
2717 DEFUN ("set-char-table-default", Fset_char_table_default
,
2718 Sset_char_table_default
, 3, 3, 0,
2719 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2720 The generic character specifies the group of characters.
2721 If CH is a normal character, set the default value for a group of
2722 characters to which CH belongs.
2723 See also the documentation of `make-char'. */)
2724 (char_table
, ch
, value
)
2725 Lisp_Object char_table
, ch
, value
;
2727 int c
, charset
, code1
, code2
;
2730 CHECK_CHAR_TABLE (char_table
);
2734 SPLIT_CHAR (c
, charset
, code1
, code2
);
2736 /* Since we may want to set the default value for a character set
2737 not yet defined, we check only if the character set is in the
2738 valid range or not, instead of it is already defined or not. */
2739 if (! CHARSET_VALID_P (charset
))
2740 invalid_character (c
);
2742 if (SINGLE_BYTE_CHAR_P (c
))
2744 /* We use special slots for the default values of single byte
2747 = (c
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2748 : c
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2749 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2751 return (XCHAR_TABLE (char_table
)->contents
[default_slot
] = value
);
2754 /* Even if C is not a generic char, we had better behave as if a
2755 generic char is specified. */
2756 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2758 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2759 if (! SUB_CHAR_TABLE_P (temp
))
2761 temp
= make_sub_char_table (temp
);
2762 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = temp
;
2766 XCHAR_TABLE (temp
)->defalt
= value
;
2770 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2771 if (SUB_CHAR_TABLE_P (temp
))
2772 XCHAR_TABLE (temp
)->defalt
= value
;
2774 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2778 /* Look up the element in TABLE at index CH,
2779 and return it as an integer.
2780 If the element is nil, return CH itself.
2781 (Actually we do that for any non-integer.) */
2784 char_table_translate (table
, ch
)
2789 value
= Faref (table
, make_number (ch
));
2790 if (! INTEGERP (value
))
2792 return XINT (value
);
2796 optimize_sub_char_table (table
, chars
)
2804 from
= 33, to
= 127;
2806 from
= 32, to
= 128;
2808 if (!SUB_CHAR_TABLE_P (*table
))
2810 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2811 for (; from
< to
; from
++)
2812 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2817 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2818 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2826 CHECK_CHAR_TABLE (table
);
2828 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2830 elt
= XCHAR_TABLE (table
)->contents
[i
];
2831 if (!SUB_CHAR_TABLE_P (elt
))
2833 dim
= CHARSET_DIMENSION (i
- 128);
2835 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2836 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2837 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2843 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2844 character or group of characters that share a value.
2845 DEPTH is the current depth in the originally specified
2846 chartable, and INDICES contains the vector indices
2847 for the levels our callers have descended.
2849 ARG is passed to C_FUNCTION when that is called. */
2852 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2853 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2854 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2858 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2860 GCPRO4 (arg
, table
, subtable
, function
);
2864 /* At first, handle ASCII and 8-bit European characters. */
2865 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2867 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2869 elt
= XCHAR_TABLE (subtable
)->defalt
;
2871 elt
= Faref (subtable
, make_number (i
));
2873 (*c_function
) (arg
, make_number (i
), elt
);
2875 call2 (function
, make_number (i
), elt
);
2877 #if 0 /* If the char table has entries for higher characters,
2878 we should report them. */
2879 if (NILP (current_buffer
->enable_multibyte_characters
))
2885 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2889 int charset
= XFASTINT (indices
[0]) - 128;
2892 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2893 if (CHARSET_CHARS (charset
) == 94)
2902 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2903 XSETFASTINT (indices
[depth
], i
);
2904 charset
= XFASTINT (indices
[0]) - 128;
2906 && (!CHARSET_DEFINED_P (charset
)
2907 || charset
== CHARSET_8_BIT_CONTROL
2908 || charset
== CHARSET_8_BIT_GRAPHIC
))
2911 if (SUB_CHAR_TABLE_P (elt
))
2914 error ("Too deep char table");
2915 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2921 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2922 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2923 c
= MAKE_CHAR (charset
, c1
, c2
);
2926 elt
= XCHAR_TABLE (subtable
)->defalt
;
2928 elt
= Faref (table
, make_number (c
));
2931 (*c_function
) (arg
, make_number (c
), elt
);
2933 call2 (function
, make_number (c
), elt
);
2939 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2941 void_call2 (a
, b
, c
)
2942 Lisp_Object a
, b
, c
;
2947 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2949 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2950 FUNCTION is called with two arguments--a key and a value.
2951 The key is always a possible IDX argument to `aref'. */)
2952 (function
, char_table
)
2953 Lisp_Object function
, char_table
;
2955 /* The depth of char table is at most 3. */
2956 Lisp_Object indices
[3];
2958 CHECK_CHAR_TABLE (char_table
);
2960 /* When Lisp_Object is represented as a union, `call2' cannot directly
2961 be passed to map_char_table because it returns a Lisp_Object rather
2962 than returning nothing.
2963 Casting leads to crashes on some architectures. -stef */
2964 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2968 /* Return a value for character C in char-table TABLE. Store the
2969 actual index for that value in *IDX. Ignore the default value of
2973 char_table_ref_and_index (table
, c
, idx
)
2977 int charset
, c1
, c2
;
2980 if (SINGLE_BYTE_CHAR_P (c
))
2983 return XCHAR_TABLE (table
)->contents
[c
];
2985 SPLIT_CHAR (c
, charset
, c1
, c2
);
2986 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2987 *idx
= MAKE_CHAR (charset
, 0, 0);
2988 if (!SUB_CHAR_TABLE_P (elt
))
2990 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2991 return XCHAR_TABLE (elt
)->defalt
;
2992 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2993 *idx
= MAKE_CHAR (charset
, c1
, 0);
2994 if (!SUB_CHAR_TABLE_P (elt
))
2996 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2997 return XCHAR_TABLE (elt
)->defalt
;
2999 return XCHAR_TABLE (elt
)->contents
[c2
];
3009 Lisp_Object args
[2];
3012 return Fnconc (2, args
);
3014 return Fnconc (2, &s1
);
3015 #endif /* NO_ARG_ARRAY */
3018 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
3019 doc
: /* Concatenate any number of lists by altering them.
3020 Only the last argument is not altered, and need not be a list.
3021 usage: (nconc &rest LISTS) */)
3026 register int argnum
;
3027 register Lisp_Object tail
, tem
, val
;
3031 for (argnum
= 0; argnum
< nargs
; argnum
++)
3034 if (NILP (tem
)) continue;
3039 if (argnum
+ 1 == nargs
) break;
3042 tem
= wrong_type_argument (Qlistp
, tem
);
3051 tem
= args
[argnum
+ 1];
3052 Fsetcdr (tail
, tem
);
3054 args
[argnum
+ 1] = tail
;
3060 /* This is the guts of all mapping functions.
3061 Apply FN to each element of SEQ, one by one,
3062 storing the results into elements of VALS, a C vector of Lisp_Objects.
3063 LENI is the length of VALS, which should also be the length of SEQ. */
3066 mapcar1 (leni
, vals
, fn
, seq
)
3069 Lisp_Object fn
, seq
;
3071 register Lisp_Object tail
;
3074 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3078 /* Don't let vals contain any garbage when GC happens. */
3079 for (i
= 0; i
< leni
; i
++)
3082 GCPRO3 (dummy
, fn
, seq
);
3084 gcpro1
.nvars
= leni
;
3088 /* We need not explicitly protect `tail' because it is used only on lists, and
3089 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
3093 for (i
= 0; i
< leni
; i
++)
3095 dummy
= XVECTOR (seq
)->contents
[i
];
3096 dummy
= call1 (fn
, dummy
);
3101 else if (BOOL_VECTOR_P (seq
))
3103 for (i
= 0; i
< leni
; i
++)
3106 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
3107 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
3112 dummy
= call1 (fn
, dummy
);
3117 else if (STRINGP (seq
))
3121 for (i
= 0, i_byte
= 0; i
< leni
;)
3126 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3127 XSETFASTINT (dummy
, c
);
3128 dummy
= call1 (fn
, dummy
);
3130 vals
[i_before
] = dummy
;
3133 else /* Must be a list, since Flength did not get an error */
3136 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
3138 dummy
= call1 (fn
, XCAR (tail
));
3148 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3149 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3150 In between each pair of results, stick in SEPARATOR. Thus, " " as
3151 SEPARATOR results in spaces between the values returned by FUNCTION.
3152 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3153 (function
, sequence
, separator
)
3154 Lisp_Object function
, sequence
, separator
;
3159 register Lisp_Object
*args
;
3161 struct gcpro gcpro1
;
3165 len
= Flength (sequence
);
3167 nargs
= leni
+ leni
- 1;
3168 if (nargs
< 0) return build_string ("");
3170 SAFE_ALLOCA_LISP (args
, nargs
);
3173 mapcar1 (leni
, args
, function
, sequence
);
3176 for (i
= leni
- 1; i
> 0; i
--)
3177 args
[i
+ i
] = args
[i
];
3179 for (i
= 1; i
< nargs
; i
+= 2)
3180 args
[i
] = separator
;
3182 ret
= Fconcat (nargs
, args
);
3188 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3189 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3190 The result is a list just as long as SEQUENCE.
3191 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3192 (function
, sequence
)
3193 Lisp_Object function
, sequence
;
3195 register Lisp_Object len
;
3197 register Lisp_Object
*args
;
3201 len
= Flength (sequence
);
3202 leni
= XFASTINT (len
);
3204 SAFE_ALLOCA_LISP (args
, leni
);
3206 mapcar1 (leni
, args
, function
, sequence
);
3208 ret
= Flist (leni
, args
);
3214 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3215 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3216 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3217 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3218 (function
, sequence
)
3219 Lisp_Object function
, sequence
;
3223 leni
= XFASTINT (Flength (sequence
));
3224 mapcar1 (leni
, 0, function
, sequence
);
3229 /* Anything that calls this function must protect from GC! */
3231 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3232 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3233 Takes one argument, which is the string to display to ask the question.
3234 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3235 No confirmation of the answer is requested; a single character is enough.
3236 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3237 the bindings in `query-replace-map'; see the documentation of that variable
3238 for more information. In this case, the useful bindings are `act', `skip',
3239 `recenter', and `quit'.\)
3241 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3242 is nil and `use-dialog-box' is non-nil. */)
3246 register Lisp_Object obj
, key
, def
, map
;
3247 register int answer
;
3248 Lisp_Object xprompt
;
3249 Lisp_Object args
[2];
3250 struct gcpro gcpro1
, gcpro2
;
3251 int count
= SPECPDL_INDEX ();
3253 specbind (Qcursor_in_echo_area
, Qt
);
3255 map
= Fsymbol_value (intern ("query-replace-map"));
3257 CHECK_STRING (prompt
);
3259 GCPRO2 (prompt
, xprompt
);
3261 #ifdef HAVE_X_WINDOWS
3262 if (display_hourglass_p
)
3263 cancel_hourglass ();
3270 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3274 Lisp_Object pane
, menu
;
3275 redisplay_preserve_echo_area (3);
3276 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3277 Fcons (Fcons (build_string ("No"), Qnil
),
3279 menu
= Fcons (prompt
, pane
);
3280 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3281 answer
= !NILP (obj
);
3284 #endif /* HAVE_MENUS */
3285 cursor_in_echo_area
= 1;
3286 choose_minibuf_frame ();
3289 Lisp_Object pargs
[3];
3291 /* Colorize prompt according to `minibuffer-prompt' face. */
3292 pargs
[0] = build_string ("%s(y or n) ");
3293 pargs
[1] = intern ("face");
3294 pargs
[2] = intern ("minibuffer-prompt");
3295 args
[0] = Fpropertize (3, pargs
);
3300 if (minibuffer_auto_raise
)
3302 Lisp_Object mini_frame
;
3304 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3306 Fraise_frame (mini_frame
);
3309 obj
= read_filtered_event (1, 0, 0, 0);
3310 cursor_in_echo_area
= 0;
3311 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3314 key
= Fmake_vector (make_number (1), obj
);
3315 def
= Flookup_key (map
, key
, Qt
);
3317 if (EQ (def
, intern ("skip")))
3322 else if (EQ (def
, intern ("act")))
3327 else if (EQ (def
, intern ("recenter")))
3333 else if (EQ (def
, intern ("quit")))
3335 /* We want to exit this command for exit-prefix,
3336 and this is the only way to do it. */
3337 else if (EQ (def
, intern ("exit-prefix")))
3342 /* If we don't clear this, then the next call to read_char will
3343 return quit_char again, and we'll enter an infinite loop. */
3348 if (EQ (xprompt
, prompt
))
3350 args
[0] = build_string ("Please answer y or n. ");
3352 xprompt
= Fconcat (2, args
);
3357 if (! noninteractive
)
3359 cursor_in_echo_area
= -1;
3360 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3364 unbind_to (count
, Qnil
);
3365 return answer
? Qt
: Qnil
;
3368 /* This is how C code calls `yes-or-no-p' and allows the user
3371 Anything that calls this function must protect from GC! */
3374 do_yes_or_no_p (prompt
)
3377 return call1 (intern ("yes-or-no-p"), prompt
);
3380 /* Anything that calls this function must protect from GC! */
3382 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3383 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3384 Takes one argument, which is the string to display to ask the question.
3385 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3386 The user must confirm the answer with RET,
3387 and can edit it until it has been confirmed.
3389 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3390 is nil, and `use-dialog-box' is non-nil. */)
3394 register Lisp_Object ans
;
3395 Lisp_Object args
[2];
3396 struct gcpro gcpro1
;
3398 CHECK_STRING (prompt
);
3401 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3405 Lisp_Object pane
, menu
, obj
;
3406 redisplay_preserve_echo_area (4);
3407 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3408 Fcons (Fcons (build_string ("No"), Qnil
),
3411 menu
= Fcons (prompt
, pane
);
3412 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3416 #endif /* HAVE_MENUS */
3419 args
[1] = build_string ("(yes or no) ");
3420 prompt
= Fconcat (2, args
);
3426 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3427 Qyes_or_no_p_history
, Qnil
,
3429 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3434 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3442 message ("Please answer yes or no.");
3443 Fsleep_for (make_number (2), Qnil
);
3447 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3448 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3450 Each of the three load averages is multiplied by 100, then converted
3453 When USE-FLOATS is non-nil, floats will be used instead of integers.
3454 These floats are not multiplied by 100.
3456 If the 5-minute or 15-minute load averages are not available, return a
3457 shortened list, containing only those averages which are available.
3459 An error is thrown if the load average can't be obtained. In some
3460 cases making it work would require Emacs being installed setuid or
3461 setgid so that it can read kernel information, and that usually isn't
3464 Lisp_Object use_floats
;
3467 int loads
= getloadavg (load_ave
, 3);
3468 Lisp_Object ret
= Qnil
;
3471 error ("load-average not implemented for this operating system");
3475 Lisp_Object load
= (NILP (use_floats
) ?
3476 make_number ((int) (100.0 * load_ave
[loads
]))
3477 : make_float (load_ave
[loads
]));
3478 ret
= Fcons (load
, ret
);
3484 Lisp_Object Vfeatures
, Qsubfeatures
;
3485 extern Lisp_Object Vafter_load_alist
;
3487 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3488 doc
: /* Returns t if FEATURE is present in this Emacs.
3490 Use this to conditionalize execution of lisp code based on the
3491 presence or absence of emacs or environment extensions.
3492 Use `provide' to declare that a feature is available. This function
3493 looks at the value of the variable `features'. The optional argument
3494 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3495 (feature
, subfeature
)
3496 Lisp_Object feature
, subfeature
;
3498 register Lisp_Object tem
;
3499 CHECK_SYMBOL (feature
);
3500 tem
= Fmemq (feature
, Vfeatures
);
3501 if (!NILP (tem
) && !NILP (subfeature
))
3502 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3503 return (NILP (tem
)) ? Qnil
: Qt
;
3506 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3507 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3508 The optional argument SUBFEATURES should be a list of symbols listing
3509 particular subfeatures supported in this version of FEATURE. */)
3510 (feature
, subfeatures
)
3511 Lisp_Object feature
, subfeatures
;
3513 register Lisp_Object tem
;
3514 CHECK_SYMBOL (feature
);
3515 CHECK_LIST (subfeatures
);
3516 if (!NILP (Vautoload_queue
))
3517 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3518 tem
= Fmemq (feature
, Vfeatures
);
3520 Vfeatures
= Fcons (feature
, Vfeatures
);
3521 if (!NILP (subfeatures
))
3522 Fput (feature
, Qsubfeatures
, subfeatures
);
3523 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3525 /* Run any load-hooks for this file. */
3526 tem
= Fassq (feature
, Vafter_load_alist
);
3528 Fprogn (XCDR (tem
));
3533 /* `require' and its subroutines. */
3535 /* List of features currently being require'd, innermost first. */
3537 Lisp_Object require_nesting_list
;
3540 require_unwind (old_value
)
3541 Lisp_Object old_value
;
3543 return require_nesting_list
= old_value
;
3546 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3547 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3548 If FEATURE is not a member of the list `features', then the feature
3549 is not loaded; so load the file FILENAME.
3550 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3551 and `load' will try to load this name appended with the suffix `.elc' or
3552 `.el', in that order. The name without appended suffix will not be used.
3553 If the optional third argument NOERROR is non-nil,
3554 then return nil if the file is not found instead of signaling an error.
3555 Normally the return value is FEATURE.
3556 The normal messages at start and end of loading FILENAME are suppressed. */)
3557 (feature
, filename
, noerror
)
3558 Lisp_Object feature
, filename
, noerror
;
3560 register Lisp_Object tem
;
3561 struct gcpro gcpro1
, gcpro2
;
3562 int from_file
= load_in_progress
;
3564 CHECK_SYMBOL (feature
);
3566 /* Record the presence of `require' in this file
3567 even if the feature specified is already loaded.
3568 But not more than once in any file,
3569 and not when we aren't loading or reading from a file. */
3571 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
3572 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
3577 tem
= Fcons (Qrequire
, feature
);
3578 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3579 LOADHIST_ATTACH (tem
);
3581 tem
= Fmemq (feature
, Vfeatures
);
3585 int count
= SPECPDL_INDEX ();
3588 /* This is to make sure that loadup.el gives a clear picture
3589 of what files are preloaded and when. */
3590 if (! NILP (Vpurify_flag
))
3591 error ("(require %s) while preparing to dump",
3592 SDATA (SYMBOL_NAME (feature
)));
3594 /* A certain amount of recursive `require' is legitimate,
3595 but if we require the same feature recursively 3 times,
3597 tem
= require_nesting_list
;
3598 while (! NILP (tem
))
3600 if (! NILP (Fequal (feature
, XCAR (tem
))))
3605 error ("Recursive `require' for feature `%s'",
3606 SDATA (SYMBOL_NAME (feature
)));
3608 /* Update the list for any nested `require's that occur. */
3609 record_unwind_protect (require_unwind
, require_nesting_list
);
3610 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3612 /* Value saved here is to be restored into Vautoload_queue */
3613 record_unwind_protect (un_autoload
, Vautoload_queue
);
3614 Vautoload_queue
= Qt
;
3616 /* Load the file. */
3617 GCPRO2 (feature
, filename
);
3618 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3619 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3622 /* If load failed entirely, return nil. */
3624 return unbind_to (count
, Qnil
);
3626 tem
= Fmemq (feature
, Vfeatures
);
3628 error ("Required feature `%s' was not provided",
3629 SDATA (SYMBOL_NAME (feature
)));
3631 /* Once loading finishes, don't undo it. */
3632 Vautoload_queue
= Qt
;
3633 feature
= unbind_to (count
, feature
);
3639 /* Primitives for work of the "widget" library.
3640 In an ideal world, this section would not have been necessary.
3641 However, lisp function calls being as slow as they are, it turns
3642 out that some functions in the widget library (wid-edit.el) are the
3643 bottleneck of Widget operation. Here is their translation to C,
3644 for the sole reason of efficiency. */
3646 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3647 doc
: /* Return non-nil if PLIST has the property PROP.
3648 PLIST is a property list, which is a list of the form
3649 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3650 Unlike `plist-get', this allows you to distinguish between a missing
3651 property and a property with the value nil.
3652 The value is actually the tail of PLIST whose car is PROP. */)
3654 Lisp_Object plist
, prop
;
3656 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3659 plist
= XCDR (plist
);
3660 plist
= CDR (plist
);
3665 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3666 doc
: /* In WIDGET, set PROPERTY to VALUE.
3667 The value can later be retrieved with `widget-get'. */)
3668 (widget
, property
, value
)
3669 Lisp_Object widget
, property
, value
;
3671 CHECK_CONS (widget
);
3672 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3676 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3677 doc
: /* In WIDGET, get the value of PROPERTY.
3678 The value could either be specified when the widget was created, or
3679 later with `widget-put'. */)
3681 Lisp_Object widget
, property
;
3689 CHECK_CONS (widget
);
3690 tmp
= Fplist_member (XCDR (widget
), property
);
3696 tmp
= XCAR (widget
);
3699 widget
= Fget (tmp
, Qwidget_type
);
3703 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3704 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3705 ARGS are passed as extra arguments to the function.
3706 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3711 /* This function can GC. */
3712 Lisp_Object newargs
[3];
3713 struct gcpro gcpro1
, gcpro2
;
3716 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3717 newargs
[1] = args
[0];
3718 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3719 GCPRO2 (newargs
[0], newargs
[2]);
3720 result
= Fapply (3, newargs
);
3725 #ifdef HAVE_LANGINFO_CODESET
3726 #include <langinfo.h>
3729 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3730 doc
: /* Access locale data ITEM for the current C locale, if available.
3731 ITEM should be one of the following:
3733 `codeset', returning the character set as a string (locale item CODESET);
3735 `days', returning a 7-element vector of day names (locale items DAY_n);
3737 `months', returning a 12-element vector of month names (locale items MON_n);
3739 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3740 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3742 If the system can't provide such information through a call to
3743 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3745 See also Info node `(libc)Locales'.
3747 The data read from the system are decoded using `locale-coding-system'. */)
3752 #ifdef HAVE_LANGINFO_CODESET
3754 if (EQ (item
, Qcodeset
))
3756 str
= nl_langinfo (CODESET
);
3757 return build_string (str
);
3760 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3762 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3763 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3765 synchronize_system_time_locale ();
3766 for (i
= 0; i
< 7; i
++)
3768 str
= nl_langinfo (days
[i
]);
3769 val
= make_unibyte_string (str
, strlen (str
));
3770 /* Fixme: Is this coding system necessarily right, even if
3771 it is consistent with CODESET? If not, what to do? */
3772 Faset (v
, make_number (i
),
3773 code_convert_string_norecord (val
, Vlocale_coding_system
,
3780 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3782 struct Lisp_Vector
*p
= allocate_vector (12);
3783 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3784 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3786 synchronize_system_time_locale ();
3787 for (i
= 0; i
< 12; i
++)
3789 str
= nl_langinfo (months
[i
]);
3790 val
= make_unibyte_string (str
, strlen (str
));
3792 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3794 XSETVECTOR (val
, p
);
3798 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3799 but is in the locale files. This could be used by ps-print. */
3801 else if (EQ (item
, Qpaper
))
3803 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3804 make_number (nl_langinfo (PAPER_HEIGHT
)));
3806 #endif /* PAPER_WIDTH */
3807 #endif /* HAVE_LANGINFO_CODESET*/
3811 /* base64 encode/decode functions (RFC 2045).
3812 Based on code from GNU recode. */
3814 #define MIME_LINE_LENGTH 76
3816 #define IS_ASCII(Character) \
3818 #define IS_BASE64(Character) \
3819 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3820 #define IS_BASE64_IGNORABLE(Character) \
3821 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3822 || (Character) == '\f' || (Character) == '\r')
3824 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3825 character or return retval if there are no characters left to
3827 #define READ_QUADRUPLET_BYTE(retval) \
3832 if (nchars_return) \
3833 *nchars_return = nchars; \
3838 while (IS_BASE64_IGNORABLE (c))
3840 /* Table of characters coding the 64 values. */
3841 static char base64_value_to_char
[64] =
3843 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3844 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3845 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3846 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3847 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3848 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3849 '8', '9', '+', '/' /* 60-63 */
3852 /* Table of base64 values for first 128 characters. */
3853 static short base64_char_to_value
[128] =
3855 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3856 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3857 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3858 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3859 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3860 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3861 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3862 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3863 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3864 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3865 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3866 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3867 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3870 /* The following diagram shows the logical steps by which three octets
3871 get transformed into four base64 characters.
3873 .--------. .--------. .--------.
3874 |aaaaaabb| |bbbbcccc| |ccdddddd|
3875 `--------' `--------' `--------'
3877 .--------+--------+--------+--------.
3878 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3879 `--------+--------+--------+--------'
3881 .--------+--------+--------+--------.
3882 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3883 `--------+--------+--------+--------'
3885 The octets are divided into 6 bit chunks, which are then encoded into
3886 base64 characters. */
3889 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3890 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3892 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3894 doc
: /* Base64-encode the region between BEG and END.
3895 Return the length of the encoded text.
3896 Optional third argument NO-LINE-BREAK means do not break long lines
3897 into shorter lines. */)
3898 (beg
, end
, no_line_break
)
3899 Lisp_Object beg
, end
, no_line_break
;
3902 int allength
, length
;
3903 int ibeg
, iend
, encoded_length
;
3907 validate_region (&beg
, &end
);
3909 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3910 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3911 move_gap_both (XFASTINT (beg
), ibeg
);
3913 /* We need to allocate enough room for encoding the text.
3914 We need 33 1/3% more space, plus a newline every 76
3915 characters, and then we round up. */
3916 length
= iend
- ibeg
;
3917 allength
= length
+ length
/3 + 1;
3918 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3920 SAFE_ALLOCA (encoded
, char *, allength
);
3921 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3922 NILP (no_line_break
),
3923 !NILP (current_buffer
->enable_multibyte_characters
));
3924 if (encoded_length
> allength
)
3927 if (encoded_length
< 0)
3929 /* The encoding wasn't possible. */
3931 error ("Multibyte character in data for base64 encoding");
3934 /* Now we have encoded the region, so we insert the new contents
3935 and delete the old. (Insert first in order to preserve markers.) */
3936 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3937 insert (encoded
, encoded_length
);
3939 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3941 /* If point was outside of the region, restore it exactly; else just
3942 move to the beginning of the region. */
3943 if (old_pos
>= XFASTINT (end
))
3944 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3945 else if (old_pos
> XFASTINT (beg
))
3946 old_pos
= XFASTINT (beg
);
3949 /* We return the length of the encoded text. */
3950 return make_number (encoded_length
);
3953 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3955 doc
: /* Base64-encode STRING and return the result.
3956 Optional second argument NO-LINE-BREAK means do not break long lines
3957 into shorter lines. */)
3958 (string
, no_line_break
)
3959 Lisp_Object string
, no_line_break
;
3961 int allength
, length
, encoded_length
;
3963 Lisp_Object encoded_string
;
3966 CHECK_STRING (string
);
3968 /* We need to allocate enough room for encoding the text.
3969 We need 33 1/3% more space, plus a newline every 76
3970 characters, and then we round up. */
3971 length
= SBYTES (string
);
3972 allength
= length
+ length
/3 + 1;
3973 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3975 /* We need to allocate enough room for decoding the text. */
3976 SAFE_ALLOCA (encoded
, char *, allength
);
3978 encoded_length
= base64_encode_1 (SDATA (string
),
3979 encoded
, length
, NILP (no_line_break
),
3980 STRING_MULTIBYTE (string
));
3981 if (encoded_length
> allength
)
3984 if (encoded_length
< 0)
3986 /* The encoding wasn't possible. */
3988 error ("Multibyte character in data for base64 encoding");
3991 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3994 return encoded_string
;
3998 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
4005 int counter
= 0, i
= 0;
4015 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4023 /* Wrap line every 76 characters. */
4027 if (counter
< MIME_LINE_LENGTH
/ 4)
4036 /* Process first byte of a triplet. */
4038 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
4039 value
= (0x03 & c
) << 4;
4041 /* Process second byte of a triplet. */
4045 *e
++ = base64_value_to_char
[value
];
4053 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4061 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
4062 value
= (0x0f & c
) << 2;
4064 /* Process third byte of a triplet. */
4068 *e
++ = base64_value_to_char
[value
];
4075 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4083 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
4084 *e
++ = base64_value_to_char
[0x3f & c
];
4091 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
4093 doc
: /* Base64-decode the region between BEG and END.
4094 Return the length of the decoded text.
4095 If the region can't be decoded, signal an error and don't modify the buffer. */)
4097 Lisp_Object beg
, end
;
4099 int ibeg
, iend
, length
, allength
;
4104 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
4107 validate_region (&beg
, &end
);
4109 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
4110 iend
= CHAR_TO_BYTE (XFASTINT (end
));
4112 length
= iend
- ibeg
;
4114 /* We need to allocate enough room for decoding the text. If we are
4115 working on a multibyte buffer, each decoded code may occupy at
4117 allength
= multibyte
? length
* 2 : length
;
4118 SAFE_ALLOCA (decoded
, char *, allength
);
4120 move_gap_both (XFASTINT (beg
), ibeg
);
4121 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
4122 multibyte
, &inserted_chars
);
4123 if (decoded_length
> allength
)
4126 if (decoded_length
< 0)
4128 /* The decoding wasn't possible. */
4130 error ("Invalid base64 data");
4133 /* Now we have decoded the region, so we insert the new contents
4134 and delete the old. (Insert first in order to preserve markers.) */
4135 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4136 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4139 /* Delete the original text. */
4140 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4141 iend
+ decoded_length
, 1);
4143 /* If point was outside of the region, restore it exactly; else just
4144 move to the beginning of the region. */
4145 if (old_pos
>= XFASTINT (end
))
4146 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4147 else if (old_pos
> XFASTINT (beg
))
4148 old_pos
= XFASTINT (beg
);
4149 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4151 return make_number (inserted_chars
);
4154 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4156 doc
: /* Base64-decode STRING and return the result. */)
4161 int length
, decoded_length
;
4162 Lisp_Object decoded_string
;
4165 CHECK_STRING (string
);
4167 length
= SBYTES (string
);
4168 /* We need to allocate enough room for decoding the text. */
4169 SAFE_ALLOCA (decoded
, char *, length
);
4171 /* The decoded result should be unibyte. */
4172 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4174 if (decoded_length
> length
)
4176 else if (decoded_length
>= 0)
4177 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4179 decoded_string
= Qnil
;
4182 if (!STRINGP (decoded_string
))
4183 error ("Invalid base64 data");
4185 return decoded_string
;
4188 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4189 MULTIBYTE is nonzero, the decoded result should be in multibyte
4190 form. If NCHARS_RETRUN is not NULL, store the number of produced
4191 characters in *NCHARS_RETURN. */
4194 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4204 unsigned long value
;
4209 /* Process first byte of a quadruplet. */
4211 READ_QUADRUPLET_BYTE (e
-to
);
4215 value
= base64_char_to_value
[c
] << 18;
4217 /* Process second byte of a quadruplet. */
4219 READ_QUADRUPLET_BYTE (-1);
4223 value
|= base64_char_to_value
[c
] << 12;
4225 c
= (unsigned char) (value
>> 16);
4227 e
+= CHAR_STRING (c
, e
);
4232 /* Process third byte of a quadruplet. */
4234 READ_QUADRUPLET_BYTE (-1);
4238 READ_QUADRUPLET_BYTE (-1);
4247 value
|= base64_char_to_value
[c
] << 6;
4249 c
= (unsigned char) (0xff & value
>> 8);
4251 e
+= CHAR_STRING (c
, e
);
4256 /* Process fourth byte of a quadruplet. */
4258 READ_QUADRUPLET_BYTE (-1);
4265 value
|= base64_char_to_value
[c
];
4267 c
= (unsigned char) (0xff & value
);
4269 e
+= CHAR_STRING (c
, e
);
4278 /***********************************************************************
4280 ***** Hash Tables *****
4282 ***********************************************************************/
4284 /* Implemented by gerd@gnu.org. This hash table implementation was
4285 inspired by CMUCL hash tables. */
4289 1. For small tables, association lists are probably faster than
4290 hash tables because they have lower overhead.
4292 For uses of hash tables where the O(1) behavior of table
4293 operations is not a requirement, it might therefore be a good idea
4294 not to hash. Instead, we could just do a linear search in the
4295 key_and_value vector of the hash table. This could be done
4296 if a `:linear-search t' argument is given to make-hash-table. */
4299 /* The list of all weak hash tables. Don't staticpro this one. */
4301 Lisp_Object Vweak_hash_tables
;
4303 /* Various symbols. */
4305 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4306 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4307 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4309 /* Function prototypes. */
4311 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4312 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4313 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4314 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4315 Lisp_Object
, unsigned));
4316 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4317 Lisp_Object
, unsigned));
4318 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4319 unsigned, Lisp_Object
, unsigned));
4320 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4321 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4322 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4323 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4325 static unsigned sxhash_string
P_ ((unsigned char *, int));
4326 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4327 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4328 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4329 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4333 /***********************************************************************
4335 ***********************************************************************/
4337 /* If OBJ is a Lisp hash table, return a pointer to its struct
4338 Lisp_Hash_Table. Otherwise, signal an error. */
4340 static struct Lisp_Hash_Table
*
4341 check_hash_table (obj
)
4344 CHECK_HASH_TABLE (obj
);
4345 return XHASH_TABLE (obj
);
4349 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4353 next_almost_prime (n
)
4366 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4367 which USED[I] is non-zero. If found at index I in ARGS, set
4368 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4369 -1. This function is used to extract a keyword/argument pair from
4370 a DEFUN parameter list. */
4373 get_key_arg (key
, nargs
, args
, used
)
4381 for (i
= 0; i
< nargs
- 1; ++i
)
4382 if (!used
[i
] && EQ (args
[i
], key
))
4397 /* Return a Lisp vector which has the same contents as VEC but has
4398 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4399 vector that are not copied from VEC are set to INIT. */
4402 larger_vector (vec
, new_size
, init
)
4407 struct Lisp_Vector
*v
;
4410 xassert (VECTORP (vec
));
4411 old_size
= XVECTOR (vec
)->size
;
4412 xassert (new_size
>= old_size
);
4414 v
= allocate_vector (new_size
);
4415 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4416 old_size
* sizeof *v
->contents
);
4417 for (i
= old_size
; i
< new_size
; ++i
)
4418 v
->contents
[i
] = init
;
4419 XSETVECTOR (vec
, v
);
4424 /***********************************************************************
4426 ***********************************************************************/
4428 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4429 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4430 KEY2 are the same. */
4433 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4434 struct Lisp_Hash_Table
*h
;
4435 Lisp_Object key1
, key2
;
4436 unsigned hash1
, hash2
;
4438 return (FLOATP (key1
)
4440 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4444 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4445 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4446 KEY2 are the same. */
4449 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4450 struct Lisp_Hash_Table
*h
;
4451 Lisp_Object key1
, key2
;
4452 unsigned hash1
, hash2
;
4454 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4458 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4459 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4460 if KEY1 and KEY2 are the same. */
4463 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4464 struct Lisp_Hash_Table
*h
;
4465 Lisp_Object key1
, key2
;
4466 unsigned hash1
, hash2
;
4470 Lisp_Object args
[3];
4472 args
[0] = h
->user_cmp_function
;
4475 return !NILP (Ffuncall (3, args
));
4482 /* Value is a hash code for KEY for use in hash table H which uses
4483 `eq' to compare keys. The hash code returned is guaranteed to fit
4484 in a Lisp integer. */
4488 struct Lisp_Hash_Table
*h
;
4491 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4492 xassert ((hash
& ~INTMASK
) == 0);
4497 /* Value is a hash code for KEY for use in hash table H which uses
4498 `eql' to compare keys. The hash code returned is guaranteed to fit
4499 in a Lisp integer. */
4503 struct Lisp_Hash_Table
*h
;
4508 hash
= sxhash (key
, 0);
4510 hash
= XUINT (key
) ^ XGCTYPE (key
);
4511 xassert ((hash
& ~INTMASK
) == 0);
4516 /* Value is a hash code for KEY for use in hash table H which uses
4517 `equal' to compare keys. The hash code returned is guaranteed to fit
4518 in a Lisp integer. */
4521 hashfn_equal (h
, key
)
4522 struct Lisp_Hash_Table
*h
;
4525 unsigned hash
= sxhash (key
, 0);
4526 xassert ((hash
& ~INTMASK
) == 0);
4531 /* Value is a hash code for KEY for use in hash table H which uses as
4532 user-defined function to compare keys. The hash code returned is
4533 guaranteed to fit in a Lisp integer. */
4536 hashfn_user_defined (h
, key
)
4537 struct Lisp_Hash_Table
*h
;
4540 Lisp_Object args
[2], hash
;
4542 args
[0] = h
->user_hash_function
;
4544 hash
= Ffuncall (2, args
);
4545 if (!INTEGERP (hash
))
4547 list2 (build_string ("Invalid hash code returned from \
4548 user-supplied hash function"),
4550 return XUINT (hash
);
4554 /* Create and initialize a new hash table.
4556 TEST specifies the test the hash table will use to compare keys.
4557 It must be either one of the predefined tests `eq', `eql' or
4558 `equal' or a symbol denoting a user-defined test named TEST with
4559 test and hash functions USER_TEST and USER_HASH.
4561 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4563 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4564 new size when it becomes full is computed by adding REHASH_SIZE to
4565 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4566 table's new size is computed by multiplying its old size with
4569 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4570 be resized when the ratio of (number of entries in the table) /
4571 (table size) is >= REHASH_THRESHOLD.
4573 WEAK specifies the weakness of the table. If non-nil, it must be
4574 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4577 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4578 user_test
, user_hash
)
4579 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4580 Lisp_Object user_test
, user_hash
;
4582 struct Lisp_Hash_Table
*h
;
4584 int index_size
, i
, sz
;
4586 /* Preconditions. */
4587 xassert (SYMBOLP (test
));
4588 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4589 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4590 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4591 xassert (FLOATP (rehash_threshold
)
4592 && XFLOATINT (rehash_threshold
) > 0
4593 && XFLOATINT (rehash_threshold
) <= 1.0);
4595 if (XFASTINT (size
) == 0)
4596 size
= make_number (1);
4598 /* Allocate a table and initialize it. */
4599 h
= allocate_hash_table ();
4601 /* Initialize hash table slots. */
4602 sz
= XFASTINT (size
);
4605 if (EQ (test
, Qeql
))
4607 h
->cmpfn
= cmpfn_eql
;
4608 h
->hashfn
= hashfn_eql
;
4610 else if (EQ (test
, Qeq
))
4613 h
->hashfn
= hashfn_eq
;
4615 else if (EQ (test
, Qequal
))
4617 h
->cmpfn
= cmpfn_equal
;
4618 h
->hashfn
= hashfn_equal
;
4622 h
->user_cmp_function
= user_test
;
4623 h
->user_hash_function
= user_hash
;
4624 h
->cmpfn
= cmpfn_user_defined
;
4625 h
->hashfn
= hashfn_user_defined
;
4629 h
->rehash_threshold
= rehash_threshold
;
4630 h
->rehash_size
= rehash_size
;
4631 h
->count
= make_number (0);
4632 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4633 h
->hash
= Fmake_vector (size
, Qnil
);
4634 h
->next
= Fmake_vector (size
, Qnil
);
4635 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4636 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4637 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4639 /* Set up the free list. */
4640 for (i
= 0; i
< sz
- 1; ++i
)
4641 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4642 h
->next_free
= make_number (0);
4644 XSET_HASH_TABLE (table
, h
);
4645 xassert (HASH_TABLE_P (table
));
4646 xassert (XHASH_TABLE (table
) == h
);
4648 /* Maybe add this hash table to the list of all weak hash tables. */
4650 h
->next_weak
= Qnil
;
4653 h
->next_weak
= Vweak_hash_tables
;
4654 Vweak_hash_tables
= table
;
4661 /* Return a copy of hash table H1. Keys and values are not copied,
4662 only the table itself is. */
4665 copy_hash_table (h1
)
4666 struct Lisp_Hash_Table
*h1
;
4669 struct Lisp_Hash_Table
*h2
;
4670 struct Lisp_Vector
*next
;
4672 h2
= allocate_hash_table ();
4673 next
= h2
->vec_next
;
4674 bcopy (h1
, h2
, sizeof *h2
);
4675 h2
->vec_next
= next
;
4676 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4677 h2
->hash
= Fcopy_sequence (h1
->hash
);
4678 h2
->next
= Fcopy_sequence (h1
->next
);
4679 h2
->index
= Fcopy_sequence (h1
->index
);
4680 XSET_HASH_TABLE (table
, h2
);
4682 /* Maybe add this hash table to the list of all weak hash tables. */
4683 if (!NILP (h2
->weak
))
4685 h2
->next_weak
= Vweak_hash_tables
;
4686 Vweak_hash_tables
= table
;
4693 /* Resize hash table H if it's too full. If H cannot be resized
4694 because it's already too large, throw an error. */
4697 maybe_resize_hash_table (h
)
4698 struct Lisp_Hash_Table
*h
;
4700 if (NILP (h
->next_free
))
4702 int old_size
= HASH_TABLE_SIZE (h
);
4703 int i
, new_size
, index_size
;
4705 if (INTEGERP (h
->rehash_size
))
4706 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4708 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4709 new_size
= max (old_size
+ 1, new_size
);
4710 index_size
= next_almost_prime ((int)
4712 / XFLOATINT (h
->rehash_threshold
)));
4713 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4714 error ("Hash table too large to resize");
4716 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4717 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4718 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4719 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4721 /* Update the free list. Do it so that new entries are added at
4722 the end of the free list. This makes some operations like
4724 for (i
= old_size
; i
< new_size
- 1; ++i
)
4725 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4727 if (!NILP (h
->next_free
))
4729 Lisp_Object last
, next
;
4731 last
= h
->next_free
;
4732 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4736 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4739 XSETFASTINT (h
->next_free
, old_size
);
4742 for (i
= 0; i
< old_size
; ++i
)
4743 if (!NILP (HASH_HASH (h
, i
)))
4745 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4746 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4747 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4748 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4754 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4755 the hash code of KEY. Value is the index of the entry in H
4756 matching KEY, or -1 if not found. */
4759 hash_lookup (h
, key
, hash
)
4760 struct Lisp_Hash_Table
*h
;
4765 int start_of_bucket
;
4768 hash_code
= h
->hashfn (h
, key
);
4772 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4773 idx
= HASH_INDEX (h
, start_of_bucket
);
4775 /* We need not gcpro idx since it's either an integer or nil. */
4778 int i
= XFASTINT (idx
);
4779 if (EQ (key
, HASH_KEY (h
, i
))
4781 && h
->cmpfn (h
, key
, hash_code
,
4782 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4784 idx
= HASH_NEXT (h
, i
);
4787 return NILP (idx
) ? -1 : XFASTINT (idx
);
4791 /* Put an entry into hash table H that associates KEY with VALUE.
4792 HASH is a previously computed hash code of KEY.
4793 Value is the index of the entry in H matching KEY. */
4796 hash_put (h
, key
, value
, hash
)
4797 struct Lisp_Hash_Table
*h
;
4798 Lisp_Object key
, value
;
4801 int start_of_bucket
, i
;
4803 xassert ((hash
& ~INTMASK
) == 0);
4805 /* Increment count after resizing because resizing may fail. */
4806 maybe_resize_hash_table (h
);
4807 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4809 /* Store key/value in the key_and_value vector. */
4810 i
= XFASTINT (h
->next_free
);
4811 h
->next_free
= HASH_NEXT (h
, i
);
4812 HASH_KEY (h
, i
) = key
;
4813 HASH_VALUE (h
, i
) = value
;
4815 /* Remember its hash code. */
4816 HASH_HASH (h
, i
) = make_number (hash
);
4818 /* Add new entry to its collision chain. */
4819 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4820 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4821 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4826 /* Remove the entry matching KEY from hash table H, if there is one. */
4829 hash_remove (h
, key
)
4830 struct Lisp_Hash_Table
*h
;
4834 int start_of_bucket
;
4835 Lisp_Object idx
, prev
;
4837 hash_code
= h
->hashfn (h
, key
);
4838 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4839 idx
= HASH_INDEX (h
, start_of_bucket
);
4842 /* We need not gcpro idx, prev since they're either integers or nil. */
4845 int i
= XFASTINT (idx
);
4847 if (EQ (key
, HASH_KEY (h
, i
))
4849 && h
->cmpfn (h
, key
, hash_code
,
4850 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4852 /* Take entry out of collision chain. */
4854 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4856 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4858 /* Clear slots in key_and_value and add the slots to
4860 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4861 HASH_NEXT (h
, i
) = h
->next_free
;
4862 h
->next_free
= make_number (i
);
4863 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4864 xassert (XINT (h
->count
) >= 0);
4870 idx
= HASH_NEXT (h
, i
);
4876 /* Clear hash table H. */
4880 struct Lisp_Hash_Table
*h
;
4882 if (XFASTINT (h
->count
) > 0)
4884 int i
, size
= HASH_TABLE_SIZE (h
);
4886 for (i
= 0; i
< size
; ++i
)
4888 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4889 HASH_KEY (h
, i
) = Qnil
;
4890 HASH_VALUE (h
, i
) = Qnil
;
4891 HASH_HASH (h
, i
) = Qnil
;
4894 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4895 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4897 h
->next_free
= make_number (0);
4898 h
->count
= make_number (0);
4904 /************************************************************************
4906 ************************************************************************/
4908 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4909 entries from the table that don't survive the current GC.
4910 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4911 non-zero if anything was marked. */
4914 sweep_weak_table (h
, remove_entries_p
)
4915 struct Lisp_Hash_Table
*h
;
4916 int remove_entries_p
;
4918 int bucket
, n
, marked
;
4920 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4923 for (bucket
= 0; bucket
< n
; ++bucket
)
4925 Lisp_Object idx
, next
, prev
;
4927 /* Follow collision chain, removing entries that
4928 don't survive this garbage collection. */
4930 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4932 int i
= XFASTINT (idx
);
4933 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4934 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4937 if (EQ (h
->weak
, Qkey
))
4938 remove_p
= !key_known_to_survive_p
;
4939 else if (EQ (h
->weak
, Qvalue
))
4940 remove_p
= !value_known_to_survive_p
;
4941 else if (EQ (h
->weak
, Qkey_or_value
))
4942 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4943 else if (EQ (h
->weak
, Qkey_and_value
))
4944 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4948 next
= HASH_NEXT (h
, i
);
4950 if (remove_entries_p
)
4954 /* Take out of collision chain. */
4956 HASH_INDEX (h
, bucket
) = next
;
4958 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4960 /* Add to free list. */
4961 HASH_NEXT (h
, i
) = h
->next_free
;
4964 /* Clear key, value, and hash. */
4965 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4966 HASH_HASH (h
, i
) = Qnil
;
4968 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4979 /* Make sure key and value survive. */
4980 if (!key_known_to_survive_p
)
4982 mark_object (HASH_KEY (h
, i
));
4986 if (!value_known_to_survive_p
)
4988 mark_object (HASH_VALUE (h
, i
));
4999 /* Remove elements from weak hash tables that don't survive the
5000 current garbage collection. Remove weak tables that don't survive
5001 from Vweak_hash_tables. Called from gc_sweep. */
5004 sweep_weak_hash_tables ()
5006 Lisp_Object table
, used
, next
;
5007 struct Lisp_Hash_Table
*h
;
5010 /* Mark all keys and values that are in use. Keep on marking until
5011 there is no more change. This is necessary for cases like
5012 value-weak table A containing an entry X -> Y, where Y is used in a
5013 key-weak table B, Z -> Y. If B comes after A in the list of weak
5014 tables, X -> Y might be removed from A, although when looking at B
5015 one finds that it shouldn't. */
5019 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
5021 h
= XHASH_TABLE (table
);
5022 if (h
->size
& ARRAY_MARK_FLAG
)
5023 marked
|= sweep_weak_table (h
, 0);
5028 /* Remove tables and entries that aren't used. */
5029 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
5031 h
= XHASH_TABLE (table
);
5032 next
= h
->next_weak
;
5034 if (h
->size
& ARRAY_MARK_FLAG
)
5036 /* TABLE is marked as used. Sweep its contents. */
5037 if (XFASTINT (h
->count
) > 0)
5038 sweep_weak_table (h
, 1);
5040 /* Add table to the list of used weak hash tables. */
5041 h
->next_weak
= used
;
5046 Vweak_hash_tables
= used
;
5051 /***********************************************************************
5052 Hash Code Computation
5053 ***********************************************************************/
5055 /* Maximum depth up to which to dive into Lisp structures. */
5057 #define SXHASH_MAX_DEPTH 3
5059 /* Maximum length up to which to take list and vector elements into
5062 #define SXHASH_MAX_LEN 7
5064 /* Combine two integers X and Y for hashing. */
5066 #define SXHASH_COMBINE(X, Y) \
5067 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
5071 /* Return a hash for string PTR which has length LEN. The hash
5072 code returned is guaranteed to fit in a Lisp integer. */
5075 sxhash_string (ptr
, len
)
5079 unsigned char *p
= ptr
;
5080 unsigned char *end
= p
+ len
;
5089 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
5092 return hash
& INTMASK
;
5096 /* Return a hash for list LIST. DEPTH is the current depth in the
5097 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
5100 sxhash_list (list
, depth
)
5107 if (depth
< SXHASH_MAX_DEPTH
)
5109 CONSP (list
) && i
< SXHASH_MAX_LEN
;
5110 list
= XCDR (list
), ++i
)
5112 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
5113 hash
= SXHASH_COMBINE (hash
, hash2
);
5120 /* Return a hash for vector VECTOR. DEPTH is the current depth in
5121 the Lisp structure. */
5124 sxhash_vector (vec
, depth
)
5128 unsigned hash
= XVECTOR (vec
)->size
;
5131 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5132 for (i
= 0; i
< n
; ++i
)
5134 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5135 hash
= SXHASH_COMBINE (hash
, hash2
);
5142 /* Return a hash for bool-vector VECTOR. */
5145 sxhash_bool_vector (vec
)
5148 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5151 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5152 for (i
= 0; i
< n
; ++i
)
5153 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5159 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5160 structure. Value is an unsigned integer clipped to INTMASK. */
5169 if (depth
> SXHASH_MAX_DEPTH
)
5172 switch (XTYPE (obj
))
5183 obj
= SYMBOL_NAME (obj
);
5187 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5190 /* This can be everything from a vector to an overlay. */
5191 case Lisp_Vectorlike
:
5193 /* According to the CL HyperSpec, two arrays are equal only if
5194 they are `eq', except for strings and bit-vectors. In
5195 Emacs, this works differently. We have to compare element
5197 hash
= sxhash_vector (obj
, depth
);
5198 else if (BOOL_VECTOR_P (obj
))
5199 hash
= sxhash_bool_vector (obj
);
5201 /* Others are `equal' if they are `eq', so let's take their
5207 hash
= sxhash_list (obj
, depth
);
5212 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5213 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5214 for (hash
= 0; p
< e
; ++p
)
5215 hash
= SXHASH_COMBINE (hash
, *p
);
5223 return hash
& INTMASK
;
5228 /***********************************************************************
5230 ***********************************************************************/
5233 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5234 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5238 unsigned hash
= sxhash (obj
, 0);;
5239 return make_number (hash
);
5243 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5244 doc
: /* Create and return a new hash table.
5246 Arguments are specified as keyword/argument pairs. The following
5247 arguments are defined:
5249 :test TEST -- TEST must be a symbol that specifies how to compare
5250 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5251 `equal'. User-supplied test and hash functions can be specified via
5252 `define-hash-table-test'.
5254 :size SIZE -- A hint as to how many elements will be put in the table.
5257 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5258 fills up. If REHASH-SIZE is an integer, add that many space. If it
5259 is a float, it must be > 1.0, and the new size is computed by
5260 multiplying the old size with that factor. Default is 1.5.
5262 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5263 Resize the hash table when ratio of the number of entries in the
5264 table. Default is 0.8.
5266 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5267 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5268 returned is a weak table. Key/value pairs are removed from a weak
5269 hash table when there are no non-weak references pointing to their
5270 key, value, one of key or value, or both key and value, depending on
5271 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5274 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5279 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5280 Lisp_Object user_test
, user_hash
;
5284 /* The vector `used' is used to keep track of arguments that
5285 have been consumed. */
5286 used
= (char *) alloca (nargs
* sizeof *used
);
5287 bzero (used
, nargs
* sizeof *used
);
5289 /* See if there's a `:test TEST' among the arguments. */
5290 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5291 test
= i
< 0 ? Qeql
: args
[i
];
5292 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5294 /* See if it is a user-defined test. */
5297 prop
= Fget (test
, Qhash_table_test
);
5298 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5299 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5301 user_test
= XCAR (prop
);
5302 user_hash
= XCAR (XCDR (prop
));
5305 user_test
= user_hash
= Qnil
;
5307 /* See if there's a `:size SIZE' argument. */
5308 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5309 size
= i
< 0 ? Qnil
: args
[i
];
5311 size
= make_number (DEFAULT_HASH_SIZE
);
5312 else if (!INTEGERP (size
) || XINT (size
) < 0)
5314 list2 (build_string ("Invalid hash table size"),
5317 /* Look for `:rehash-size SIZE'. */
5318 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5319 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5320 if (!NUMBERP (rehash_size
)
5321 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5322 || XFLOATINT (rehash_size
) <= 1.0)
5324 list2 (build_string ("Invalid hash table rehash size"),
5327 /* Look for `:rehash-threshold THRESHOLD'. */
5328 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5329 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5330 if (!FLOATP (rehash_threshold
)
5331 || XFLOATINT (rehash_threshold
) <= 0.0
5332 || XFLOATINT (rehash_threshold
) > 1.0)
5334 list2 (build_string ("Invalid hash table rehash threshold"),
5337 /* Look for `:weakness WEAK'. */
5338 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5339 weak
= i
< 0 ? Qnil
: args
[i
];
5341 weak
= Qkey_and_value
;
5344 && !EQ (weak
, Qvalue
)
5345 && !EQ (weak
, Qkey_or_value
)
5346 && !EQ (weak
, Qkey_and_value
))
5347 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5350 /* Now, all args should have been used up, or there's a problem. */
5351 for (i
= 0; i
< nargs
; ++i
)
5354 list2 (build_string ("Invalid argument list"), args
[i
]));
5356 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5357 user_test
, user_hash
);
5361 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5362 doc
: /* Return a copy of hash table TABLE. */)
5366 return copy_hash_table (check_hash_table (table
));
5370 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5371 doc
: /* Return the number of elements in TABLE. */)
5375 return check_hash_table (table
)->count
;
5379 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5380 Shash_table_rehash_size
, 1, 1, 0,
5381 doc
: /* Return the current rehash size of TABLE. */)
5385 return check_hash_table (table
)->rehash_size
;
5389 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5390 Shash_table_rehash_threshold
, 1, 1, 0,
5391 doc
: /* Return the current rehash threshold of TABLE. */)
5395 return check_hash_table (table
)->rehash_threshold
;
5399 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5400 doc
: /* Return the size of TABLE.
5401 The size can be used as an argument to `make-hash-table' to create
5402 a hash table than can hold as many elements of TABLE holds
5403 without need for resizing. */)
5407 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5408 return make_number (HASH_TABLE_SIZE (h
));
5412 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5413 doc
: /* Return the test TABLE uses. */)
5417 return check_hash_table (table
)->test
;
5421 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5423 doc
: /* Return the weakness of TABLE. */)
5427 return check_hash_table (table
)->weak
;
5431 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5432 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5436 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5440 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5441 doc
: /* Clear hash table TABLE. */)
5445 hash_clear (check_hash_table (table
));
5450 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5451 doc
: /* Look up KEY in TABLE and return its associated value.
5452 If KEY is not found, return DFLT which defaults to nil. */)
5454 Lisp_Object key
, table
, dflt
;
5456 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5457 int i
= hash_lookup (h
, key
, NULL
);
5458 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5462 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5463 doc
: /* Associate KEY with VALUE in hash table TABLE.
5464 If KEY is already present in table, replace its current value with
5467 Lisp_Object key
, value
, table
;
5469 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5473 i
= hash_lookup (h
, key
, &hash
);
5475 HASH_VALUE (h
, i
) = value
;
5477 hash_put (h
, key
, value
, hash
);
5483 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5484 doc
: /* Remove KEY from TABLE. */)
5486 Lisp_Object key
, table
;
5488 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5489 hash_remove (h
, key
);
5494 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5495 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5496 FUNCTION is called with two arguments, KEY and VALUE. */)
5498 Lisp_Object function
, table
;
5500 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5501 Lisp_Object args
[3];
5504 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5505 if (!NILP (HASH_HASH (h
, i
)))
5508 args
[1] = HASH_KEY (h
, i
);
5509 args
[2] = HASH_VALUE (h
, i
);
5517 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5518 Sdefine_hash_table_test
, 3, 3, 0,
5519 doc
: /* Define a new hash table test with name NAME, a symbol.
5521 In hash tables created with NAME specified as test, use TEST to
5522 compare keys, and HASH for computing hash codes of keys.
5524 TEST must be a function taking two arguments and returning non-nil if
5525 both arguments are the same. HASH must be a function taking one
5526 argument and return an integer that is the hash code of the argument.
5527 Hash code computation should use the whole value range of integers,
5528 including negative integers. */)
5530 Lisp_Object name
, test
, hash
;
5532 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5537 /************************************************************************
5539 ************************************************************************/
5544 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5545 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5547 A message digest is a cryptographic checksum of a document, and the
5548 algorithm to calculate it is defined in RFC 1321.
5550 The two optional arguments START and END are character positions
5551 specifying for which part of OBJECT the message digest should be
5552 computed. If nil or omitted, the digest is computed for the whole
5555 The MD5 message digest is computed from the result of encoding the
5556 text in a coding system, not directly from the internal Emacs form of
5557 the text. The optional fourth argument CODING-SYSTEM specifies which
5558 coding system to encode the text with. It should be the same coding
5559 system that you used or will use when actually writing the text into a
5562 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5563 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5564 system would be chosen by default for writing this text into a file.
5566 If OBJECT is a string, the most preferred coding system (see the
5567 command `prefer-coding-system') is used.
5569 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5570 guesswork fails. Normally, an error is signaled in such case. */)
5571 (object
, start
, end
, coding_system
, noerror
)
5572 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5574 unsigned char digest
[16];
5575 unsigned char value
[33];
5579 int start_char
= 0, end_char
= 0;
5580 int start_byte
= 0, end_byte
= 0;
5582 register struct buffer
*bp
;
5585 if (STRINGP (object
))
5587 if (NILP (coding_system
))
5589 /* Decide the coding-system to encode the data with. */
5591 if (STRING_MULTIBYTE (object
))
5592 /* use default, we can't guess correct value */
5593 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5595 coding_system
= Qraw_text
;
5598 if (NILP (Fcoding_system_p (coding_system
)))
5600 /* Invalid coding system. */
5602 if (!NILP (noerror
))
5603 coding_system
= Qraw_text
;
5606 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5609 if (STRING_MULTIBYTE (object
))
5610 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5612 size
= SCHARS (object
);
5613 size_byte
= SBYTES (object
);
5617 CHECK_NUMBER (start
);
5619 start_char
= XINT (start
);
5624 start_byte
= string_char_to_byte (object
, start_char
);
5630 end_byte
= size_byte
;
5636 end_char
= XINT (end
);
5641 end_byte
= string_char_to_byte (object
, end_char
);
5644 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5645 args_out_of_range_3 (object
, make_number (start_char
),
5646 make_number (end_char
));
5650 struct buffer
*prev
= current_buffer
;
5652 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5654 CHECK_BUFFER (object
);
5656 bp
= XBUFFER (object
);
5657 if (bp
!= current_buffer
)
5658 set_buffer_internal (bp
);
5664 CHECK_NUMBER_COERCE_MARKER (start
);
5672 CHECK_NUMBER_COERCE_MARKER (end
);
5677 temp
= b
, b
= e
, e
= temp
;
5679 if (!(BEGV
<= b
&& e
<= ZV
))
5680 args_out_of_range (start
, end
);
5682 if (NILP (coding_system
))
5684 /* Decide the coding-system to encode the data with.
5685 See fileio.c:Fwrite-region */
5687 if (!NILP (Vcoding_system_for_write
))
5688 coding_system
= Vcoding_system_for_write
;
5691 int force_raw_text
= 0;
5693 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5694 if (NILP (coding_system
)
5695 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5697 coding_system
= Qnil
;
5698 if (NILP (current_buffer
->enable_multibyte_characters
))
5702 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5704 /* Check file-coding-system-alist. */
5705 Lisp_Object args
[4], val
;
5707 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5708 args
[3] = Fbuffer_file_name(object
);
5709 val
= Ffind_operation_coding_system (4, args
);
5710 if (CONSP (val
) && !NILP (XCDR (val
)))
5711 coding_system
= XCDR (val
);
5714 if (NILP (coding_system
)
5715 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5717 /* If we still have not decided a coding system, use the
5718 default value of buffer-file-coding-system. */
5719 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5723 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5724 /* Confirm that VAL can surely encode the current region. */
5725 coding_system
= call4 (Vselect_safe_coding_system_function
,
5726 make_number (b
), make_number (e
),
5727 coding_system
, Qnil
);
5730 coding_system
= Qraw_text
;
5733 if (NILP (Fcoding_system_p (coding_system
)))
5735 /* Invalid coding system. */
5737 if (!NILP (noerror
))
5738 coding_system
= Qraw_text
;
5741 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5745 object
= make_buffer_string (b
, e
, 0);
5746 if (prev
!= current_buffer
)
5747 set_buffer_internal (prev
);
5748 /* Discard the unwind protect for recovering the current
5752 if (STRING_MULTIBYTE (object
))
5753 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5756 md5_buffer (SDATA (object
) + start_byte
,
5757 SBYTES (object
) - (size_byte
- end_byte
),
5760 for (i
= 0; i
< 16; i
++)
5761 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5764 return make_string (value
, 32);
5771 /* Hash table stuff. */
5772 Qhash_table_p
= intern ("hash-table-p");
5773 staticpro (&Qhash_table_p
);
5774 Qeq
= intern ("eq");
5776 Qeql
= intern ("eql");
5778 Qequal
= intern ("equal");
5779 staticpro (&Qequal
);
5780 QCtest
= intern (":test");
5781 staticpro (&QCtest
);
5782 QCsize
= intern (":size");
5783 staticpro (&QCsize
);
5784 QCrehash_size
= intern (":rehash-size");
5785 staticpro (&QCrehash_size
);
5786 QCrehash_threshold
= intern (":rehash-threshold");
5787 staticpro (&QCrehash_threshold
);
5788 QCweakness
= intern (":weakness");
5789 staticpro (&QCweakness
);
5790 Qkey
= intern ("key");
5792 Qvalue
= intern ("value");
5793 staticpro (&Qvalue
);
5794 Qhash_table_test
= intern ("hash-table-test");
5795 staticpro (&Qhash_table_test
);
5796 Qkey_or_value
= intern ("key-or-value");
5797 staticpro (&Qkey_or_value
);
5798 Qkey_and_value
= intern ("key-and-value");
5799 staticpro (&Qkey_and_value
);
5802 defsubr (&Smake_hash_table
);
5803 defsubr (&Scopy_hash_table
);
5804 defsubr (&Shash_table_count
);
5805 defsubr (&Shash_table_rehash_size
);
5806 defsubr (&Shash_table_rehash_threshold
);
5807 defsubr (&Shash_table_size
);
5808 defsubr (&Shash_table_test
);
5809 defsubr (&Shash_table_weakness
);
5810 defsubr (&Shash_table_p
);
5811 defsubr (&Sclrhash
);
5812 defsubr (&Sgethash
);
5813 defsubr (&Sputhash
);
5814 defsubr (&Sremhash
);
5815 defsubr (&Smaphash
);
5816 defsubr (&Sdefine_hash_table_test
);
5818 Qstring_lessp
= intern ("string-lessp");
5819 staticpro (&Qstring_lessp
);
5820 Qprovide
= intern ("provide");
5821 staticpro (&Qprovide
);
5822 Qrequire
= intern ("require");
5823 staticpro (&Qrequire
);
5824 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5825 staticpro (&Qyes_or_no_p_history
);
5826 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5827 staticpro (&Qcursor_in_echo_area
);
5828 Qwidget_type
= intern ("widget-type");
5829 staticpro (&Qwidget_type
);
5831 staticpro (&string_char_byte_cache_string
);
5832 string_char_byte_cache_string
= Qnil
;
5834 require_nesting_list
= Qnil
;
5835 staticpro (&require_nesting_list
);
5837 Fset (Qyes_or_no_p_history
, Qnil
);
5839 DEFVAR_LISP ("features", &Vfeatures
,
5840 doc
: /* A list of symbols which are the features of the executing emacs.
5841 Used by `featurep' and `require', and altered by `provide'. */);
5842 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5843 Qsubfeatures
= intern ("subfeatures");
5844 staticpro (&Qsubfeatures
);
5846 #ifdef HAVE_LANGINFO_CODESET
5847 Qcodeset
= intern ("codeset");
5848 staticpro (&Qcodeset
);
5849 Qdays
= intern ("days");
5851 Qmonths
= intern ("months");
5852 staticpro (&Qmonths
);
5853 Qpaper
= intern ("paper");
5854 staticpro (&Qpaper
);
5855 #endif /* HAVE_LANGINFO_CODESET */
5857 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5858 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5859 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5860 invoked by mouse clicks and mouse menu items. */);
5863 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5864 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5865 This applies to commands from menus and tool bar buttons. The value of
5866 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5867 used if both `use-dialog-box' and this variable are non-nil. */);
5868 use_file_dialog
= 1;
5870 defsubr (&Sidentity
);
5873 defsubr (&Ssafe_length
);
5874 defsubr (&Sstring_bytes
);
5875 defsubr (&Sstring_equal
);
5876 defsubr (&Scompare_strings
);
5877 defsubr (&Sstring_lessp
);
5880 defsubr (&Svconcat
);
5881 defsubr (&Scopy_sequence
);
5882 defsubr (&Sstring_make_multibyte
);
5883 defsubr (&Sstring_make_unibyte
);
5884 defsubr (&Sstring_as_multibyte
);
5885 defsubr (&Sstring_as_unibyte
);
5886 defsubr (&Sstring_to_multibyte
);
5887 defsubr (&Scopy_alist
);
5888 defsubr (&Ssubstring
);
5889 defsubr (&Ssubstring_no_properties
);
5901 defsubr (&Snreverse
);
5902 defsubr (&Sreverse
);
5904 defsubr (&Splist_get
);
5906 defsubr (&Splist_put
);
5908 defsubr (&Slax_plist_get
);
5909 defsubr (&Slax_plist_put
);
5912 defsubr (&Sequal_including_properties
);
5913 defsubr (&Sfillarray
);
5914 defsubr (&Sclear_string
);
5915 defsubr (&Schar_table_subtype
);
5916 defsubr (&Schar_table_parent
);
5917 defsubr (&Sset_char_table_parent
);
5918 defsubr (&Schar_table_extra_slot
);
5919 defsubr (&Sset_char_table_extra_slot
);
5920 defsubr (&Schar_table_range
);
5921 defsubr (&Sset_char_table_range
);
5922 defsubr (&Sset_char_table_default
);
5923 defsubr (&Soptimize_char_table
);
5924 defsubr (&Smap_char_table
);
5928 defsubr (&Smapconcat
);
5929 defsubr (&Sy_or_n_p
);
5930 defsubr (&Syes_or_no_p
);
5931 defsubr (&Sload_average
);
5932 defsubr (&Sfeaturep
);
5933 defsubr (&Srequire
);
5934 defsubr (&Sprovide
);
5935 defsubr (&Splist_member
);
5936 defsubr (&Swidget_put
);
5937 defsubr (&Swidget_get
);
5938 defsubr (&Swidget_apply
);
5939 defsubr (&Sbase64_encode_region
);
5940 defsubr (&Sbase64_decode_region
);
5941 defsubr (&Sbase64_encode_string
);
5942 defsubr (&Sbase64_decode_string
);
5944 defsubr (&Slocale_info
);
5951 Vweak_hash_tables
= Qnil
;
5954 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5955 (do not change this comment) */