1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006 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"
52 #if defined (HAVE_X_WINDOWS)
54 #elif defined (MAC_OS)
60 #define NULL ((POINTER_TYPE *)0)
63 /* Nonzero enables use of dialog boxes for questions
64 asked by mouse commands. */
67 /* Nonzero enables use of a file dialog for file name
68 questions asked by mouse commands. */
71 extern int minibuffer_auto_raise
;
72 extern Lisp_Object minibuf_window
;
73 extern Lisp_Object Vlocale_coding_system
;
74 extern int load_in_progress
;
76 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
77 Lisp_Object Qyes_or_no_p_history
;
78 Lisp_Object Qcursor_in_echo_area
;
79 Lisp_Object Qwidget_type
;
80 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
82 extern Lisp_Object Qinput_method_function
;
84 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
86 extern long get_random ();
87 extern void seed_random
P_ ((long));
93 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
94 doc
: /* Return the argument unchanged. */)
101 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
102 doc
: /* Return a pseudo-random number.
103 All integers representable in Lisp are equally likely.
104 On most systems, this is 29 bits' worth.
105 With positive integer argument N, return random number in interval [0,N).
106 With argument t, set the random number seed from the current time and pid. */)
111 Lisp_Object lispy_val
;
112 unsigned long denominator
;
115 seed_random (getpid () + time (NULL
));
116 if (NATNUMP (n
) && XFASTINT (n
) != 0)
118 /* Try to take our random number from the higher bits of VAL,
119 not the lower, since (says Gentzel) the low bits of `random'
120 are less random than the higher ones. We do this by using the
121 quotient rather than the remainder. At the high end of the RNG
122 it's possible to get a quotient larger than n; discarding
123 these values eliminates the bias that would otherwise appear
124 when using a large n. */
125 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
127 val
= get_random () / denominator
;
128 while (val
>= XFASTINT (n
));
132 XSETINT (lispy_val
, val
);
136 /* Random data-structure functions */
138 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
139 doc
: /* Return the length of vector, list or string SEQUENCE.
140 A byte-code function object is also allowed.
141 If the string contains multibyte characters, this is not necessarily
142 the number of bytes in the string; it is the number of characters.
143 To get the number of bytes, use `string-bytes'. */)
145 register Lisp_Object sequence
;
147 register Lisp_Object val
;
151 if (STRINGP (sequence
))
152 XSETFASTINT (val
, SCHARS (sequence
));
153 else if (VECTORP (sequence
))
154 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
155 else if (SUB_CHAR_TABLE_P (sequence
))
156 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
157 else if (CHAR_TABLE_P (sequence
))
158 XSETFASTINT (val
, MAX_CHAR
);
159 else if (BOOL_VECTOR_P (sequence
))
160 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
161 else if (COMPILEDP (sequence
))
162 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
163 else if (CONSP (sequence
))
166 while (CONSP (sequence
))
168 sequence
= XCDR (sequence
);
171 if (!CONSP (sequence
))
174 sequence
= XCDR (sequence
);
179 if (!NILP (sequence
))
180 wrong_type_argument (Qlistp
, sequence
);
182 val
= make_number (i
);
184 else if (NILP (sequence
))
185 XSETFASTINT (val
, 0);
188 sequence
= wrong_type_argument (Qsequencep
, sequence
);
194 /* This does not check for quits. That is safe since it must terminate. */
196 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
197 doc
: /* Return the length of a list, but avoid error or infinite loop.
198 This function never gets an error. If LIST is not really a list,
199 it returns 0. If LIST is circular, it returns a finite value
200 which is at least the number of distinct elements. */)
204 Lisp_Object tail
, halftail
, length
;
207 /* halftail is used to detect circular lists. */
209 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
211 if (EQ (tail
, halftail
) && len
!= 0)
215 halftail
= XCDR (halftail
);
218 XSETINT (length
, len
);
222 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
223 doc
: /* Return the number of bytes in STRING.
224 If STRING is a multibyte string, this is greater than the length of STRING. */)
228 CHECK_STRING (string
);
229 return make_number (SBYTES (string
));
232 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
233 doc
: /* Return t if two strings have identical contents.
234 Case is significant, but text properties are ignored.
235 Symbols are also allowed; their print names are used instead. */)
237 register Lisp_Object s1
, s2
;
240 s1
= SYMBOL_NAME (s1
);
242 s2
= SYMBOL_NAME (s2
);
246 if (SCHARS (s1
) != SCHARS (s2
)
247 || SBYTES (s1
) != SBYTES (s2
)
248 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
253 DEFUN ("compare-strings", Fcompare_strings
,
254 Scompare_strings
, 6, 7, 0,
255 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
256 In string STR1, skip the first START1 characters and stop at END1.
257 In string STR2, skip the first START2 characters and stop at END2.
258 END1 and END2 default to the full lengths of the respective strings.
260 Case is significant in this comparison if IGNORE-CASE is nil.
261 Unibyte strings are converted to multibyte for comparison.
263 The value is t if the strings (or specified portions) match.
264 If string STR1 is less, the value is a negative number N;
265 - 1 - N is the number of characters that match at the beginning.
266 If string STR1 is greater, the value is a positive number N;
267 N - 1 is the number of characters that match at the beginning. */)
268 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
269 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
271 register int end1_char
, end2_char
;
272 register int i1
, i1_byte
, i2
, i2_byte
;
277 start1
= make_number (0);
279 start2
= make_number (0);
280 CHECK_NATNUM (start1
);
281 CHECK_NATNUM (start2
);
290 i1_byte
= string_char_to_byte (str1
, i1
);
291 i2_byte
= string_char_to_byte (str2
, i2
);
293 end1_char
= SCHARS (str1
);
294 if (! NILP (end1
) && end1_char
> XINT (end1
))
295 end1_char
= XINT (end1
);
297 end2_char
= SCHARS (str2
);
298 if (! NILP (end2
) && end2_char
> XINT (end2
))
299 end2_char
= XINT (end2
);
301 while (i1
< end1_char
&& i2
< end2_char
)
303 /* When we find a mismatch, we must compare the
304 characters, not just the bytes. */
307 if (STRING_MULTIBYTE (str1
))
308 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
311 c1
= SREF (str1
, i1
++);
312 c1
= unibyte_char_to_multibyte (c1
);
315 if (STRING_MULTIBYTE (str2
))
316 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
319 c2
= SREF (str2
, i2
++);
320 c2
= unibyte_char_to_multibyte (c2
);
326 if (! NILP (ignore_case
))
330 tem
= Fupcase (make_number (c1
));
332 tem
= Fupcase (make_number (c2
));
339 /* Note that I1 has already been incremented
340 past the character that we are comparing;
341 hence we don't add or subtract 1 here. */
343 return make_number (- i1
+ XINT (start1
));
345 return make_number (i1
- XINT (start1
));
349 return make_number (i1
- XINT (start1
) + 1);
351 return make_number (- i1
+ XINT (start1
) - 1);
356 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
357 doc
: /* Return t if first arg string is less than second in lexicographic order.
359 Symbols are also allowed; their print names are used instead. */)
361 register Lisp_Object s1
, s2
;
364 register int i1
, i1_byte
, i2
, i2_byte
;
367 s1
= SYMBOL_NAME (s1
);
369 s2
= SYMBOL_NAME (s2
);
373 i1
= i1_byte
= i2
= i2_byte
= 0;
376 if (end
> SCHARS (s2
))
381 /* When we find a mismatch, we must compare the
382 characters, not just the bytes. */
385 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
386 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
389 return c1
< c2
? Qt
: Qnil
;
391 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
394 static Lisp_Object
concat ();
405 return concat (2, args
, Lisp_String
, 0);
407 return concat (2, &s1
, Lisp_String
, 0);
408 #endif /* NO_ARG_ARRAY */
414 Lisp_Object s1
, s2
, s3
;
421 return concat (3, args
, Lisp_String
, 0);
423 return concat (3, &s1
, Lisp_String
, 0);
424 #endif /* NO_ARG_ARRAY */
427 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
428 doc
: /* Concatenate all the arguments and make the result a list.
429 The result is a list whose elements are the elements of all the arguments.
430 Each argument may be a list, vector or string.
431 The last argument is not copied, just used as the tail of the new list.
432 usage: (append &rest SEQUENCES) */)
437 return concat (nargs
, args
, Lisp_Cons
, 1);
440 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
441 doc
: /* Concatenate all the arguments and make the result a string.
442 The result is a string whose elements are the elements of all the arguments.
443 Each argument may be a string or a list or vector of characters (integers).
444 usage: (concat &rest SEQUENCES) */)
449 return concat (nargs
, args
, Lisp_String
, 0);
452 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
453 doc
: /* Concatenate all the arguments and make the result a vector.
454 The result is a vector whose elements are the elements of all the arguments.
455 Each argument may be a list, vector or string.
456 usage: (vconcat &rest SEQUENCES) */)
461 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
464 /* Return a copy of a sub char table ARG. The elements except for a
465 nested sub char table are not copied. */
467 copy_sub_char_table (arg
)
470 Lisp_Object copy
= make_sub_char_table (Qnil
);
473 XCHAR_TABLE (copy
)->defalt
= XCHAR_TABLE (arg
)->defalt
;
474 /* Copy all the contents. */
475 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
476 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
477 /* Recursively copy any sub char-tables in the ordinary slots. */
478 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
479 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
480 XCHAR_TABLE (copy
)->contents
[i
]
481 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
487 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
488 doc
: /* Return a copy of a list, vector, string or char-table.
489 The elements of a list or vector are not copied; they are shared
490 with the original. */)
494 if (NILP (arg
)) return arg
;
496 if (CHAR_TABLE_P (arg
))
501 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
502 /* Copy all the slots, including the extra ones. */
503 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
504 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
505 * sizeof (Lisp_Object
)));
507 /* Recursively copy any sub char tables in the ordinary slots
508 for multibyte characters. */
509 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
510 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
511 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
512 XCHAR_TABLE (copy
)->contents
[i
]
513 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
518 if (BOOL_VECTOR_P (arg
))
522 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
523 / BOOL_VECTOR_BITS_PER_CHAR
);
525 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
526 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
531 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
532 arg
= wrong_type_argument (Qsequencep
, arg
);
533 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
536 /* This structure holds information of an argument of `concat' that is
537 a string and has text properties to be copied. */
540 int argnum
; /* refer to ARGS (arguments of `concat') */
541 int from
; /* refer to ARGS[argnum] (argument string) */
542 int to
; /* refer to VAL (the target string) */
546 concat (nargs
, args
, target_type
, last_special
)
549 enum Lisp_Type target_type
;
553 register Lisp_Object tail
;
554 register Lisp_Object
this;
556 int toindex_byte
= 0;
557 register int result_len
;
558 register int result_len_byte
;
560 Lisp_Object last_tail
;
563 /* When we make a multibyte string, we can't copy text properties
564 while concatinating each string because the length of resulting
565 string can't be decided until we finish the whole concatination.
566 So, we record strings that have text properties to be copied
567 here, and copy the text properties after the concatination. */
568 struct textprop_rec
*textprops
= NULL
;
569 /* Number of elments in textprops. */
570 int num_textprops
= 0;
575 /* In append, the last arg isn't treated like the others */
576 if (last_special
&& nargs
> 0)
579 last_tail
= args
[nargs
];
584 /* Canonicalize each argument. */
585 for (argnum
= 0; argnum
< nargs
; argnum
++)
588 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
589 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
591 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
595 /* Compute total length in chars of arguments in RESULT_LEN.
596 If desired output is a string, also compute length in bytes
597 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
598 whether the result should be a multibyte string. */
602 for (argnum
= 0; argnum
< nargs
; argnum
++)
606 len
= XFASTINT (Flength (this));
607 if (target_type
== Lisp_String
)
609 /* We must count the number of bytes needed in the string
610 as well as the number of characters. */
616 for (i
= 0; i
< len
; i
++)
618 ch
= XVECTOR (this)->contents
[i
];
620 wrong_type_argument (Qintegerp
, ch
);
621 this_len_byte
= CHAR_BYTES (XINT (ch
));
622 result_len_byte
+= this_len_byte
;
623 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
626 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
627 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
628 else if (CONSP (this))
629 for (; CONSP (this); this = XCDR (this))
633 wrong_type_argument (Qintegerp
, ch
);
634 this_len_byte
= CHAR_BYTES (XINT (ch
));
635 result_len_byte
+= this_len_byte
;
636 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
639 else if (STRINGP (this))
641 if (STRING_MULTIBYTE (this))
644 result_len_byte
+= SBYTES (this);
647 result_len_byte
+= count_size_as_multibyte (SDATA (this),
655 if (! some_multibyte
)
656 result_len_byte
= result_len
;
658 /* Create the output object. */
659 if (target_type
== Lisp_Cons
)
660 val
= Fmake_list (make_number (result_len
), Qnil
);
661 else if (target_type
== Lisp_Vectorlike
)
662 val
= Fmake_vector (make_number (result_len
), Qnil
);
663 else if (some_multibyte
)
664 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
666 val
= make_uninit_string (result_len
);
668 /* In `append', if all but last arg are nil, return last arg. */
669 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
672 /* Copy the contents of the args into the result. */
674 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
676 toindex
= 0, toindex_byte
= 0;
680 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
682 for (argnum
= 0; argnum
< nargs
; argnum
++)
686 register unsigned int thisindex
= 0;
687 register unsigned int thisindex_byte
= 0;
691 thislen
= Flength (this), thisleni
= XINT (thislen
);
693 /* Between strings of the same kind, copy fast. */
694 if (STRINGP (this) && STRINGP (val
)
695 && STRING_MULTIBYTE (this) == some_multibyte
)
697 int thislen_byte
= SBYTES (this);
699 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
701 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
703 textprops
[num_textprops
].argnum
= argnum
;
704 textprops
[num_textprops
].from
= 0;
705 textprops
[num_textprops
++].to
= toindex
;
707 toindex_byte
+= thislen_byte
;
709 STRING_SET_CHARS (val
, SCHARS (val
));
711 /* Copy a single-byte string to a multibyte string. */
712 else if (STRINGP (this) && STRINGP (val
))
714 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
716 textprops
[num_textprops
].argnum
= argnum
;
717 textprops
[num_textprops
].from
= 0;
718 textprops
[num_textprops
++].to
= toindex
;
720 toindex_byte
+= copy_text (SDATA (this),
721 SDATA (val
) + toindex_byte
,
722 SCHARS (this), 0, 1);
726 /* Copy element by element. */
729 register Lisp_Object elt
;
731 /* Fetch next element of `this' arg into `elt', or break if
732 `this' is exhausted. */
733 if (NILP (this)) break;
735 elt
= XCAR (this), this = XCDR (this);
736 else if (thisindex
>= thisleni
)
738 else if (STRINGP (this))
741 if (STRING_MULTIBYTE (this))
743 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
746 XSETFASTINT (elt
, c
);
750 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
752 && (XINT (elt
) >= 0240
753 || (XINT (elt
) >= 0200
754 && ! NILP (Vnonascii_translation_table
)))
755 && XINT (elt
) < 0400)
757 c
= unibyte_char_to_multibyte (XINT (elt
));
762 else if (BOOL_VECTOR_P (this))
765 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
766 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
773 elt
= XVECTOR (this)->contents
[thisindex
++];
775 /* Store this element into the result. */
782 else if (VECTORP (val
))
783 XVECTOR (val
)->contents
[toindex
++] = elt
;
787 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
791 += CHAR_STRING (XINT (elt
),
792 SDATA (val
) + toindex_byte
);
794 SSET (val
, toindex_byte
++, XINT (elt
));
798 /* If we have any multibyte characters,
799 we already decided to make a multibyte string. */
802 /* P exists as a variable
803 to avoid a bug on the Masscomp C compiler. */
804 unsigned char *p
= SDATA (val
) + toindex_byte
;
806 toindex_byte
+= CHAR_STRING (c
, p
);
813 XSETCDR (prev
, last_tail
);
815 if (num_textprops
> 0)
818 int last_to_end
= -1;
820 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
822 this = args
[textprops
[argnum
].argnum
];
823 props
= text_property_list (this,
825 make_number (SCHARS (this)),
827 /* If successive arguments have properites, be sure that the
828 value of `composition' property be the copy. */
829 if (last_to_end
== textprops
[argnum
].to
)
830 make_composition_value_copy (props
);
831 add_text_properties_from_list (val
, props
,
832 make_number (textprops
[argnum
].to
));
833 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
841 static Lisp_Object string_char_byte_cache_string
;
842 static int string_char_byte_cache_charpos
;
843 static int string_char_byte_cache_bytepos
;
846 clear_string_char_byte_cache ()
848 string_char_byte_cache_string
= Qnil
;
851 /* Return the character index corresponding to CHAR_INDEX in STRING. */
854 string_char_to_byte (string
, char_index
)
859 int best_below
, best_below_byte
;
860 int best_above
, best_above_byte
;
862 best_below
= best_below_byte
= 0;
863 best_above
= SCHARS (string
);
864 best_above_byte
= SBYTES (string
);
865 if (best_above
== best_above_byte
)
868 if (EQ (string
, string_char_byte_cache_string
))
870 if (string_char_byte_cache_charpos
< char_index
)
872 best_below
= string_char_byte_cache_charpos
;
873 best_below_byte
= string_char_byte_cache_bytepos
;
877 best_above
= string_char_byte_cache_charpos
;
878 best_above_byte
= string_char_byte_cache_bytepos
;
882 if (char_index
- best_below
< best_above
- char_index
)
884 while (best_below
< char_index
)
887 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
888 best_below
, best_below_byte
);
891 i_byte
= best_below_byte
;
895 while (best_above
> char_index
)
897 unsigned char *pend
= SDATA (string
) + best_above_byte
;
898 unsigned char *pbeg
= pend
- best_above_byte
;
899 unsigned char *p
= pend
- 1;
902 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
903 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
904 if (bytes
== pend
- p
)
905 best_above_byte
-= bytes
;
906 else if (bytes
> pend
- p
)
907 best_above_byte
-= (pend
- p
);
913 i_byte
= best_above_byte
;
916 string_char_byte_cache_bytepos
= i_byte
;
917 string_char_byte_cache_charpos
= i
;
918 string_char_byte_cache_string
= string
;
923 /* Return the character index corresponding to BYTE_INDEX in STRING. */
926 string_byte_to_char (string
, byte_index
)
931 int best_below
, best_below_byte
;
932 int best_above
, best_above_byte
;
934 best_below
= best_below_byte
= 0;
935 best_above
= SCHARS (string
);
936 best_above_byte
= SBYTES (string
);
937 if (best_above
== best_above_byte
)
940 if (EQ (string
, string_char_byte_cache_string
))
942 if (string_char_byte_cache_bytepos
< byte_index
)
944 best_below
= string_char_byte_cache_charpos
;
945 best_below_byte
= string_char_byte_cache_bytepos
;
949 best_above
= string_char_byte_cache_charpos
;
950 best_above_byte
= string_char_byte_cache_bytepos
;
954 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
956 while (best_below_byte
< byte_index
)
959 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
960 best_below
, best_below_byte
);
963 i_byte
= best_below_byte
;
967 while (best_above_byte
> byte_index
)
969 unsigned char *pend
= SDATA (string
) + best_above_byte
;
970 unsigned char *pbeg
= pend
- best_above_byte
;
971 unsigned char *p
= pend
- 1;
974 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
975 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
976 if (bytes
== pend
- p
)
977 best_above_byte
-= bytes
;
978 else if (bytes
> pend
- p
)
979 best_above_byte
-= (pend
- p
);
985 i_byte
= best_above_byte
;
988 string_char_byte_cache_bytepos
= i_byte
;
989 string_char_byte_cache_charpos
= i
;
990 string_char_byte_cache_string
= string
;
995 /* Convert STRING to a multibyte string.
996 Single-byte characters 0240 through 0377 are converted
997 by adding nonascii_insert_offset to each. */
1000 string_make_multibyte (string
)
1008 if (STRING_MULTIBYTE (string
))
1011 nbytes
= count_size_as_multibyte (SDATA (string
),
1013 /* If all the chars are ASCII, they won't need any more bytes
1014 once converted. In that case, we can return STRING itself. */
1015 if (nbytes
== SBYTES (string
))
1018 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1019 copy_text (SDATA (string
), buf
, SBYTES (string
),
1022 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1029 /* Convert STRING to a multibyte string without changing each
1030 character codes. Thus, characters 0200 trough 0237 are converted
1031 to eight-bit-control characters, and characters 0240 through 0377
1032 are converted eight-bit-graphic characters. */
1035 string_to_multibyte (string
)
1043 if (STRING_MULTIBYTE (string
))
1046 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1047 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1048 any more bytes once converted. */
1049 if (nbytes
== SBYTES (string
))
1050 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1052 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1053 bcopy (SDATA (string
), buf
, SBYTES (string
));
1054 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1056 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1063 /* Convert STRING to a single-byte string. */
1066 string_make_unibyte (string
)
1074 if (! STRING_MULTIBYTE (string
))
1077 nchars
= SCHARS (string
);
1079 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1080 copy_text (SDATA (string
), buf
, SBYTES (string
),
1083 ret
= make_unibyte_string (buf
, nchars
);
1089 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1091 doc
: /* Return the multibyte equivalent of STRING.
1092 If STRING is unibyte and contains non-ASCII characters, the function
1093 `unibyte-char-to-multibyte' is used to convert each unibyte character
1094 to a multibyte character. In this case, the returned string is a
1095 newly created string with no text properties. If STRING is multibyte
1096 or entirely ASCII, it is returned unchanged. In particular, when
1097 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1098 \(When the characters are all ASCII, Emacs primitives will treat the
1099 string the same way whether it is unibyte or multibyte.) */)
1103 CHECK_STRING (string
);
1105 return string_make_multibyte (string
);
1108 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1110 doc
: /* Return the unibyte equivalent of STRING.
1111 Multibyte character codes are converted to unibyte according to
1112 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1113 If the lookup in the translation table fails, this function takes just
1114 the low 8 bits of each character. */)
1118 CHECK_STRING (string
);
1120 return string_make_unibyte (string
);
1123 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1125 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1126 If STRING is unibyte, the result is STRING itself.
1127 Otherwise it is a newly created string, with no text properties.
1128 If STRING is multibyte and contains a character of charset
1129 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1130 corresponding single byte. */)
1134 CHECK_STRING (string
);
1136 if (STRING_MULTIBYTE (string
))
1138 int bytes
= SBYTES (string
);
1139 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1141 bcopy (SDATA (string
), str
, bytes
);
1142 bytes
= str_as_unibyte (str
, bytes
);
1143 string
= make_unibyte_string (str
, bytes
);
1149 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1151 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1152 If STRING is multibyte, the result is STRING itself.
1153 Otherwise it is a newly created string, with no text properties.
1154 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1155 part of a multibyte form), it is converted to the corresponding
1156 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.
1157 Beware, this often doesn't really do what you think it does.
1158 It is similar to (decode-coding-string STRING 'emacs-mule-unix).
1159 If you're not sure, whether to use `string-as-multibyte' or
1160 `string-to-multibyte', use `string-to-multibyte'. Beware:
1161 (aref (string-as-multibyte "\\201") 0) -> 129 (aka ?\\201)
1162 (aref (string-as-multibyte "\\300") 0) -> 192 (aka ?\\300)
1163 (aref (string-as-multibyte "\\300\\201") 0) -> 192 (aka ?\\300)
1164 (aref (string-as-multibyte "\\300\\201") 1) -> 129 (aka ?\\201)
1166 (aref (string-as-multibyte "\\201\\300") 0) -> 2240
1167 (aref (string-as-multibyte "\\201\\300") 1) -> <error> */)
1171 CHECK_STRING (string
);
1173 if (! STRING_MULTIBYTE (string
))
1175 Lisp_Object new_string
;
1178 parse_str_as_multibyte (SDATA (string
),
1181 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1182 bcopy (SDATA (string
), SDATA (new_string
),
1184 if (nbytes
!= SBYTES (string
))
1185 str_as_multibyte (SDATA (new_string
), nbytes
,
1186 SBYTES (string
), NULL
);
1187 string
= new_string
;
1188 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1193 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1195 doc
: /* Return a multibyte string with the same individual chars as STRING.
1196 If STRING is multibyte, the result is STRING itself.
1197 Otherwise it is a newly created string, with no text properties.
1198 Characters 0200 through 0237 are converted to eight-bit-control
1199 characters of the same character code. Characters 0240 through 0377
1200 are converted to eight-bit-graphic characters of the same character
1202 This is similar to (decode-coding-string STRING 'binary) */)
1206 CHECK_STRING (string
);
1208 return string_to_multibyte (string
);
1212 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1213 doc
: /* Return a copy of ALIST.
1214 This is an alist which represents the same mapping from objects to objects,
1215 but does not share the alist structure with ALIST.
1216 The objects mapped (cars and cdrs of elements of the alist)
1217 are shared, however.
1218 Elements of ALIST that are not conses are also shared. */)
1222 register Lisp_Object tem
;
1227 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1228 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1230 register Lisp_Object car
;
1234 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1239 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1240 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1241 TO may be nil or omitted; then the substring runs to the end of STRING.
1242 FROM and TO start at 0. If either is negative, it counts from the end.
1244 This function allows vectors as well as strings. */)
1247 register Lisp_Object from
, to
;
1252 int from_char
, to_char
;
1253 int from_byte
= 0, to_byte
= 0;
1255 if (! (STRINGP (string
) || VECTORP (string
)))
1256 wrong_type_argument (Qarrayp
, string
);
1258 CHECK_NUMBER (from
);
1260 if (STRINGP (string
))
1262 size
= SCHARS (string
);
1263 size_byte
= SBYTES (string
);
1266 size
= XVECTOR (string
)->size
;
1271 to_byte
= size_byte
;
1277 to_char
= XINT (to
);
1281 if (STRINGP (string
))
1282 to_byte
= string_char_to_byte (string
, to_char
);
1285 from_char
= XINT (from
);
1288 if (STRINGP (string
))
1289 from_byte
= string_char_to_byte (string
, from_char
);
1291 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1292 args_out_of_range_3 (string
, make_number (from_char
),
1293 make_number (to_char
));
1295 if (STRINGP (string
))
1297 res
= make_specified_string (SDATA (string
) + from_byte
,
1298 to_char
- from_char
, to_byte
- from_byte
,
1299 STRING_MULTIBYTE (string
));
1300 copy_text_properties (make_number (from_char
), make_number (to_char
),
1301 string
, make_number (0), res
, Qnil
);
1304 res
= Fvector (to_char
- from_char
,
1305 XVECTOR (string
)->contents
+ from_char
);
1311 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1312 doc
: /* Return a substring of STRING, without text properties.
1313 It starts at index FROM and ending before TO.
1314 TO may be nil or omitted; then the substring runs to the end of STRING.
1315 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1316 If FROM or TO is negative, it counts from the end.
1318 With one argument, just copy STRING without its properties. */)
1321 register Lisp_Object from
, to
;
1323 int size
, size_byte
;
1324 int from_char
, to_char
;
1325 int from_byte
, to_byte
;
1327 CHECK_STRING (string
);
1329 size
= SCHARS (string
);
1330 size_byte
= SBYTES (string
);
1333 from_char
= from_byte
= 0;
1336 CHECK_NUMBER (from
);
1337 from_char
= XINT (from
);
1341 from_byte
= string_char_to_byte (string
, from_char
);
1347 to_byte
= size_byte
;
1353 to_char
= XINT (to
);
1357 to_byte
= string_char_to_byte (string
, to_char
);
1360 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1361 args_out_of_range_3 (string
, make_number (from_char
),
1362 make_number (to_char
));
1364 return make_specified_string (SDATA (string
) + from_byte
,
1365 to_char
- from_char
, to_byte
- from_byte
,
1366 STRING_MULTIBYTE (string
));
1369 /* Extract a substring of STRING, giving start and end positions
1370 both in characters and in bytes. */
1373 substring_both (string
, from
, from_byte
, to
, to_byte
)
1375 int from
, from_byte
, to
, to_byte
;
1381 if (! (STRINGP (string
) || VECTORP (string
)))
1382 wrong_type_argument (Qarrayp
, string
);
1384 if (STRINGP (string
))
1386 size
= SCHARS (string
);
1387 size_byte
= SBYTES (string
);
1390 size
= XVECTOR (string
)->size
;
1392 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1393 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1395 if (STRINGP (string
))
1397 res
= make_specified_string (SDATA (string
) + from_byte
,
1398 to
- from
, to_byte
- from_byte
,
1399 STRING_MULTIBYTE (string
));
1400 copy_text_properties (make_number (from
), make_number (to
),
1401 string
, make_number (0), res
, Qnil
);
1404 res
= Fvector (to
- from
,
1405 XVECTOR (string
)->contents
+ from
);
1410 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1411 doc
: /* Take cdr N times on LIST, returns the result. */)
1414 register Lisp_Object list
;
1416 register int i
, num
;
1419 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1423 wrong_type_argument (Qlistp
, list
);
1429 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1430 doc
: /* Return the Nth element of LIST.
1431 N counts from zero. If LIST is not that long, nil is returned. */)
1433 Lisp_Object n
, list
;
1435 return Fcar (Fnthcdr (n
, list
));
1438 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1439 doc
: /* Return element of SEQUENCE at index N. */)
1441 register Lisp_Object sequence
, n
;
1446 if (CONSP (sequence
) || NILP (sequence
))
1447 return Fcar (Fnthcdr (n
, sequence
));
1448 else if (STRINGP (sequence
) || VECTORP (sequence
)
1449 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1450 return Faref (sequence
, n
);
1452 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1456 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1457 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1458 The value is actually the tail of LIST whose car is ELT. */)
1460 register Lisp_Object elt
;
1463 register Lisp_Object tail
;
1464 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1466 register Lisp_Object tem
;
1468 wrong_type_argument (Qlistp
, list
);
1470 if (! NILP (Fequal (elt
, tem
)))
1477 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1478 doc
: /* Return non-nil if ELT is an element of LIST.
1479 Comparison done with `eq'. The value is actually the tail of LIST
1480 whose car is ELT. */)
1482 Lisp_Object elt
, list
;
1486 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1490 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1494 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1501 if (!CONSP (list
) && !NILP (list
))
1502 list
= wrong_type_argument (Qlistp
, list
);
1507 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1508 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1509 The value is actually the first element of LIST whose car is KEY.
1510 Elements of LIST that are not conses are ignored. */)
1512 Lisp_Object key
, list
;
1519 || (CONSP (XCAR (list
))
1520 && EQ (XCAR (XCAR (list
)), key
)))
1525 || (CONSP (XCAR (list
))
1526 && EQ (XCAR (XCAR (list
)), key
)))
1531 || (CONSP (XCAR (list
))
1532 && EQ (XCAR (XCAR (list
)), key
)))
1540 result
= XCAR (list
);
1541 else if (NILP (list
))
1544 result
= wrong_type_argument (Qlistp
, list
);
1549 /* Like Fassq but never report an error and do not allow quits.
1550 Use only on lists known never to be circular. */
1553 assq_no_quit (key
, list
)
1554 Lisp_Object key
, list
;
1557 && (!CONSP (XCAR (list
))
1558 || !EQ (XCAR (XCAR (list
)), key
)))
1561 return CONSP (list
) ? XCAR (list
) : Qnil
;
1564 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1565 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1566 The value is actually the first element of LIST whose car equals KEY. */)
1568 Lisp_Object key
, list
;
1570 Lisp_Object result
, car
;
1575 || (CONSP (XCAR (list
))
1576 && (car
= XCAR (XCAR (list
)),
1577 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1582 || (CONSP (XCAR (list
))
1583 && (car
= XCAR (XCAR (list
)),
1584 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1589 || (CONSP (XCAR (list
))
1590 && (car
= XCAR (XCAR (list
)),
1591 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1599 result
= XCAR (list
);
1600 else if (NILP (list
))
1603 result
= wrong_type_argument (Qlistp
, list
);
1608 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1609 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1610 The value is actually the first element of LIST whose cdr is KEY. */)
1612 register Lisp_Object key
;
1620 || (CONSP (XCAR (list
))
1621 && EQ (XCDR (XCAR (list
)), key
)))
1626 || (CONSP (XCAR (list
))
1627 && EQ (XCDR (XCAR (list
)), key
)))
1632 || (CONSP (XCAR (list
))
1633 && EQ (XCDR (XCAR (list
)), key
)))
1642 else if (CONSP (list
))
1643 result
= XCAR (list
);
1645 result
= wrong_type_argument (Qlistp
, list
);
1650 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1651 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1652 The value is actually the first element of LIST whose cdr equals KEY. */)
1654 Lisp_Object key
, list
;
1656 Lisp_Object result
, cdr
;
1661 || (CONSP (XCAR (list
))
1662 && (cdr
= XCDR (XCAR (list
)),
1663 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1668 || (CONSP (XCAR (list
))
1669 && (cdr
= XCDR (XCAR (list
)),
1670 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1675 || (CONSP (XCAR (list
))
1676 && (cdr
= XCDR (XCAR (list
)),
1677 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1685 result
= XCAR (list
);
1686 else if (NILP (list
))
1689 result
= wrong_type_argument (Qlistp
, list
);
1694 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1695 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1696 The modified LIST is returned. Comparison is done with `eq'.
1697 If the first member of LIST is ELT, there is no way to remove it by side effect;
1698 therefore, write `(setq foo (delq element foo))'
1699 to be sure of changing the value of `foo'. */)
1701 register Lisp_Object elt
;
1704 register Lisp_Object tail
, prev
;
1705 register Lisp_Object tem
;
1709 while (!NILP (tail
))
1712 wrong_type_argument (Qlistp
, list
);
1719 Fsetcdr (prev
, XCDR (tail
));
1729 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1730 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1731 SEQ must be a list, a vector, or a string.
1732 The modified SEQ is returned. Comparison is done with `equal'.
1733 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1734 is not a side effect; it is simply using a different sequence.
1735 Therefore, write `(setq foo (delete element foo))'
1736 to be sure of changing the value of `foo'. */)
1738 Lisp_Object elt
, seq
;
1744 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1745 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1748 if (n
!= ASIZE (seq
))
1750 struct Lisp_Vector
*p
= allocate_vector (n
);
1752 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1753 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1754 p
->contents
[n
++] = AREF (seq
, i
);
1756 XSETVECTOR (seq
, p
);
1759 else if (STRINGP (seq
))
1761 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1764 for (i
= nchars
= nbytes
= ibyte
= 0;
1766 ++i
, ibyte
+= cbytes
)
1768 if (STRING_MULTIBYTE (seq
))
1770 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1771 SBYTES (seq
) - ibyte
);
1772 cbytes
= CHAR_BYTES (c
);
1780 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1787 if (nchars
!= SCHARS (seq
))
1791 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1792 if (!STRING_MULTIBYTE (seq
))
1793 STRING_SET_UNIBYTE (tem
);
1795 for (i
= nchars
= nbytes
= ibyte
= 0;
1797 ++i
, ibyte
+= cbytes
)
1799 if (STRING_MULTIBYTE (seq
))
1801 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1802 SBYTES (seq
) - ibyte
);
1803 cbytes
= CHAR_BYTES (c
);
1811 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1813 unsigned char *from
= SDATA (seq
) + ibyte
;
1814 unsigned char *to
= SDATA (tem
) + nbytes
;
1820 for (n
= cbytes
; n
--; )
1830 Lisp_Object tail
, prev
;
1832 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1835 wrong_type_argument (Qlistp
, seq
);
1837 if (!NILP (Fequal (elt
, XCAR (tail
))))
1842 Fsetcdr (prev
, XCDR (tail
));
1853 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1854 doc
: /* Reverse LIST by modifying cdr pointers.
1855 Return the reversed list. */)
1859 register Lisp_Object prev
, tail
, next
;
1861 if (NILP (list
)) return list
;
1864 while (!NILP (tail
))
1868 wrong_type_argument (Qlistp
, list
);
1870 Fsetcdr (tail
, prev
);
1877 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1878 doc
: /* Reverse LIST, copying. Return the reversed list.
1879 See also the function `nreverse', which is used more often. */)
1885 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1888 new = Fcons (XCAR (list
), new);
1891 wrong_type_argument (Qconsp
, list
);
1895 Lisp_Object
merge ();
1897 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1898 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1899 Returns the sorted list. LIST is modified by side effects.
1900 PREDICATE is called with two elements of LIST, and should return non-nil
1901 if the first element should sort before the second. */)
1903 Lisp_Object list
, predicate
;
1905 Lisp_Object front
, back
;
1906 register Lisp_Object len
, tem
;
1907 struct gcpro gcpro1
, gcpro2
;
1908 register int length
;
1911 len
= Flength (list
);
1912 length
= XINT (len
);
1916 XSETINT (len
, (length
/ 2) - 1);
1917 tem
= Fnthcdr (len
, list
);
1919 Fsetcdr (tem
, Qnil
);
1921 GCPRO2 (front
, back
);
1922 front
= Fsort (front
, predicate
);
1923 back
= Fsort (back
, predicate
);
1925 return merge (front
, back
, predicate
);
1929 merge (org_l1
, org_l2
, pred
)
1930 Lisp_Object org_l1
, org_l2
;
1934 register Lisp_Object tail
;
1936 register Lisp_Object l1
, l2
;
1937 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1944 /* It is sufficient to protect org_l1 and org_l2.
1945 When l1 and l2 are updated, we copy the new values
1946 back into the org_ vars. */
1947 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1967 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1983 Fsetcdr (tail
, tem
);
1989 #if 0 /* Unsafe version. */
1990 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1991 doc
: /* Extract a value from a property list.
1992 PLIST is a property list, which is a list of the form
1993 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1994 corresponding to the given PROP, or nil if PROP is not
1995 one of the properties on the list. */)
2003 CONSP (tail
) && CONSP (XCDR (tail
));
2004 tail
= XCDR (XCDR (tail
)))
2006 if (EQ (prop
, XCAR (tail
)))
2007 return XCAR (XCDR (tail
));
2009 /* This function can be called asynchronously
2010 (setup_coding_system). Don't QUIT in that case. */
2011 if (!interrupt_input_blocked
)
2016 wrong_type_argument (Qlistp
, prop
);
2022 /* This does not check for quits. That is safe since it must terminate. */
2024 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2025 doc
: /* Extract a value from a property list.
2026 PLIST is a property list, which is a list of the form
2027 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2028 corresponding to the given PROP, or nil if PROP is not one of the
2029 properties on the list. This function never signals an error. */)
2034 Lisp_Object tail
, halftail
;
2036 /* halftail is used to detect circular lists. */
2037 tail
= halftail
= plist
;
2038 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2040 if (EQ (prop
, XCAR (tail
)))
2041 return XCAR (XCDR (tail
));
2043 tail
= XCDR (XCDR (tail
));
2044 halftail
= XCDR (halftail
);
2045 if (EQ (tail
, halftail
))
2052 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2053 doc
: /* Return the value of SYMBOL's PROPNAME property.
2054 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2056 Lisp_Object symbol
, propname
;
2058 CHECK_SYMBOL (symbol
);
2059 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2062 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2063 doc
: /* Change value in PLIST of PROP to VAL.
2064 PLIST is a property list, which is a list of the form
2065 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2066 If PROP is already a property on the list, its value is set to VAL,
2067 otherwise the new PROP VAL pair is added. The new plist is returned;
2068 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2069 The PLIST is modified by side effects. */)
2072 register Lisp_Object prop
;
2075 register Lisp_Object tail
, prev
;
2076 Lisp_Object newcell
;
2078 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2079 tail
= XCDR (XCDR (tail
)))
2081 if (EQ (prop
, XCAR (tail
)))
2083 Fsetcar (XCDR (tail
), val
);
2090 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2094 Fsetcdr (XCDR (prev
), newcell
);
2098 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2099 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2100 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2101 (symbol
, propname
, value
)
2102 Lisp_Object symbol
, propname
, value
;
2104 CHECK_SYMBOL (symbol
);
2105 XSYMBOL (symbol
)->plist
2106 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2110 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2111 doc
: /* Extract a value from a property list, comparing with `equal'.
2112 PLIST is a property list, which is a list of the form
2113 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2114 corresponding to the given PROP, or nil if PROP is not
2115 one of the properties on the list. */)
2123 CONSP (tail
) && CONSP (XCDR (tail
));
2124 tail
= XCDR (XCDR (tail
)))
2126 if (! NILP (Fequal (prop
, XCAR (tail
))))
2127 return XCAR (XCDR (tail
));
2133 wrong_type_argument (Qlistp
, prop
);
2138 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2139 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2140 PLIST is a property list, which is a list of the form
2141 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2142 If PROP is already a property on the list, its value is set to VAL,
2143 otherwise the new PROP VAL pair is added. The new plist is returned;
2144 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2145 The PLIST is modified by side effects. */)
2148 register Lisp_Object prop
;
2151 register Lisp_Object tail
, prev
;
2152 Lisp_Object newcell
;
2154 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2155 tail
= XCDR (XCDR (tail
)))
2157 if (! NILP (Fequal (prop
, XCAR (tail
))))
2159 Fsetcar (XCDR (tail
), val
);
2166 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2170 Fsetcdr (XCDR (prev
), newcell
);
2174 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2175 doc
: /* Return t if the two args are the same Lisp object.
2176 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2178 Lisp_Object obj1
, obj2
;
2181 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2183 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2186 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2187 doc
: /* Return t if two Lisp objects have similar structure and contents.
2188 They must have the same data type.
2189 Conses are compared by comparing the cars and the cdrs.
2190 Vectors and strings are compared element by element.
2191 Numbers are compared by value, but integers cannot equal floats.
2192 (Use `=' if you want integers and floats to be able to be equal.)
2193 Symbols must match exactly. */)
2195 register Lisp_Object o1
, o2
;
2197 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2200 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2201 doc
: /* Return t if two Lisp objects have similar structure and contents.
2202 This is like `equal' except that it compares the text properties
2203 of strings. (`equal' ignores text properties.) */)
2205 register Lisp_Object o1
, o2
;
2207 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2210 /* DEPTH is current depth of recursion. Signal an error if it
2212 PROPS, if non-nil, means compare string text properties too. */
2215 internal_equal (o1
, o2
, depth
, props
)
2216 register Lisp_Object o1
, o2
;
2220 error ("Stack overflow in equal");
2226 if (XTYPE (o1
) != XTYPE (o2
))
2235 d1
= extract_float (o1
);
2236 d2
= extract_float (o2
);
2237 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2238 though they are not =. */
2239 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2243 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2250 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2254 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2256 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2259 o1
= XOVERLAY (o1
)->plist
;
2260 o2
= XOVERLAY (o2
)->plist
;
2265 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2266 && (XMARKER (o1
)->buffer
== 0
2267 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2271 case Lisp_Vectorlike
:
2274 EMACS_INT size
= XVECTOR (o1
)->size
;
2275 /* Pseudovectors have the type encoded in the size field, so this test
2276 actually checks that the objects have the same type as well as the
2278 if (XVECTOR (o2
)->size
!= size
)
2280 /* Boolvectors are compared much like strings. */
2281 if (BOOL_VECTOR_P (o1
))
2284 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2285 / BOOL_VECTOR_BITS_PER_CHAR
);
2287 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2289 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2294 if (WINDOW_CONFIGURATIONP (o1
))
2295 return compare_window_configurations (o1
, o2
, 0);
2297 /* Aside from them, only true vectors, char-tables, and compiled
2298 functions are sensible to compare, so eliminate the others now. */
2299 if (size
& PSEUDOVECTOR_FLAG
)
2301 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2303 size
&= PSEUDOVECTOR_SIZE_MASK
;
2305 for (i
= 0; i
< size
; i
++)
2308 v1
= XVECTOR (o1
)->contents
[i
];
2309 v2
= XVECTOR (o2
)->contents
[i
];
2310 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2318 if (SCHARS (o1
) != SCHARS (o2
))
2320 if (SBYTES (o1
) != SBYTES (o2
))
2322 if (bcmp (SDATA (o1
), SDATA (o2
),
2325 if (props
&& !compare_string_intervals (o1
, o2
))
2331 case Lisp_Type_Limit
:
2338 extern Lisp_Object
Fmake_char_internal ();
2340 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2341 doc
: /* Store each element of ARRAY with ITEM.
2342 ARRAY is a vector, string, char-table, or bool-vector. */)
2344 Lisp_Object array
, item
;
2346 register int size
, index
, charval
;
2348 if (VECTORP (array
))
2350 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2351 size
= XVECTOR (array
)->size
;
2352 for (index
= 0; index
< size
; index
++)
2355 else if (CHAR_TABLE_P (array
))
2357 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2358 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2359 for (index
= 0; index
< size
; index
++)
2361 XCHAR_TABLE (array
)->defalt
= Qnil
;
2363 else if (STRINGP (array
))
2365 register unsigned char *p
= SDATA (array
);
2366 CHECK_NUMBER (item
);
2367 charval
= XINT (item
);
2368 size
= SCHARS (array
);
2369 if (STRING_MULTIBYTE (array
))
2371 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2372 int len
= CHAR_STRING (charval
, str
);
2373 int size_byte
= SBYTES (array
);
2374 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2377 if (size
!= size_byte
)
2380 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2381 if (len
!= this_len
)
2382 error ("Attempt to change byte length of a string");
2385 for (i
= 0; i
< size_byte
; i
++)
2386 *p
++ = str
[i
% len
];
2389 for (index
= 0; index
< size
; index
++)
2392 else if (BOOL_VECTOR_P (array
))
2394 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2396 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2397 / BOOL_VECTOR_BITS_PER_CHAR
);
2399 charval
= (! NILP (item
) ? -1 : 0);
2400 for (index
= 0; index
< size_in_chars
- 1; index
++)
2402 if (index
< size_in_chars
)
2404 /* Mask out bits beyond the vector size. */
2405 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2406 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2412 array
= wrong_type_argument (Qarrayp
, array
);
2418 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2420 doc
: /* Clear the contents of STRING.
2421 This makes STRING unibyte and may change its length. */)
2426 CHECK_STRING (string
);
2427 len
= SBYTES (string
);
2428 bzero (SDATA (string
), len
);
2429 STRING_SET_CHARS (string
, len
);
2430 STRING_SET_UNIBYTE (string
);
2434 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2436 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2438 Lisp_Object char_table
;
2440 CHECK_CHAR_TABLE (char_table
);
2442 return XCHAR_TABLE (char_table
)->purpose
;
2445 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2447 doc
: /* Return the parent char-table of CHAR-TABLE.
2448 The value is either nil or another char-table.
2449 If CHAR-TABLE holds nil for a given character,
2450 then the actual applicable value is inherited from the parent char-table
2451 \(or from its parents, if necessary). */)
2453 Lisp_Object char_table
;
2455 CHECK_CHAR_TABLE (char_table
);
2457 return XCHAR_TABLE (char_table
)->parent
;
2460 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2462 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2463 Return PARENT. PARENT must be either nil or another char-table. */)
2464 (char_table
, parent
)
2465 Lisp_Object char_table
, parent
;
2469 CHECK_CHAR_TABLE (char_table
);
2473 CHECK_CHAR_TABLE (parent
);
2475 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2476 if (EQ (temp
, char_table
))
2477 error ("Attempt to make a chartable be its own parent");
2480 XCHAR_TABLE (char_table
)->parent
= parent
;
2485 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2487 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2489 Lisp_Object char_table
, n
;
2491 CHECK_CHAR_TABLE (char_table
);
2494 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2495 args_out_of_range (char_table
, n
);
2497 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2500 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2501 Sset_char_table_extra_slot
,
2503 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2504 (char_table
, n
, value
)
2505 Lisp_Object char_table
, n
, value
;
2507 CHECK_CHAR_TABLE (char_table
);
2510 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2511 args_out_of_range (char_table
, n
);
2513 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2517 char_table_range (table
, from
, to
, defalt
)
2524 if (! NILP (XCHAR_TABLE (table
)->defalt
))
2525 defalt
= XCHAR_TABLE (table
)->defalt
;
2526 val
= XCHAR_TABLE (table
)->contents
[from
];
2527 if (SUB_CHAR_TABLE_P (val
))
2528 val
= char_table_range (val
, 32, 127, defalt
);
2529 else if (NILP (val
))
2531 for (from
++; from
<= to
; from
++)
2533 Lisp_Object this_val
;
2535 this_val
= XCHAR_TABLE (table
)->contents
[from
];
2536 if (SUB_CHAR_TABLE_P (this_val
))
2537 this_val
= char_table_range (this_val
, 32, 127, defalt
);
2538 else if (NILP (this_val
))
2540 if (! EQ (val
, this_val
))
2541 error ("Characters in the range have inconsistent values");
2547 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2549 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2550 RANGE should be nil (for the default value),
2551 a vector which identifies a character set or a row of a character set,
2552 a character set name, or a character code.
2553 If the characters in the specified range have different values,
2554 an error is signaled.
2556 Note that this function doesn't check the parent of CHAR-TABLE. */)
2558 Lisp_Object char_table
, range
;
2560 int charset_id
, c1
= 0, c2
= 0;
2562 Lisp_Object ch
, val
, current_default
;
2564 CHECK_CHAR_TABLE (char_table
);
2566 if (EQ (range
, Qnil
))
2567 return XCHAR_TABLE (char_table
)->defalt
;
2568 if (INTEGERP (range
))
2570 int c
= XINT (range
);
2571 if (! CHAR_VALID_P (c
, 0))
2572 error ("Invalid character code: %d", c
);
2574 SPLIT_CHAR (c
, charset_id
, c1
, c2
);
2576 else if (SYMBOLP (range
))
2578 Lisp_Object charset_info
;
2580 charset_info
= Fget (range
, Qcharset
);
2581 CHECK_VECTOR (charset_info
);
2582 charset_id
= XINT (XVECTOR (charset_info
)->contents
[0]);
2583 ch
= Fmake_char_internal (make_number (charset_id
),
2584 make_number (0), make_number (0));
2586 else if (VECTORP (range
))
2588 size
= ASIZE (range
);
2590 args_out_of_range (range
, make_number (0));
2591 CHECK_NUMBER (AREF (range
, 0));
2592 charset_id
= XINT (AREF (range
, 0));
2595 CHECK_NUMBER (AREF (range
, 1));
2596 c1
= XINT (AREF (range
, 1));
2599 CHECK_NUMBER (AREF (range
, 2));
2600 c2
= XINT (AREF (range
, 2));
2604 /* This checks if charset_id, c0, and c1 are all valid or not. */
2605 ch
= Fmake_char_internal (make_number (charset_id
),
2606 make_number (c1
), make_number (c2
));
2609 error ("Invalid RANGE argument to `char-table-range'");
2611 if (c1
> 0 && (CHARSET_DIMENSION (charset_id
) == 1 || c2
> 0))
2613 /* Fully specified character. */
2614 Lisp_Object parent
= XCHAR_TABLE (char_table
)->parent
;
2616 XCHAR_TABLE (char_table
)->parent
= Qnil
;
2617 val
= Faref (char_table
, ch
);
2618 XCHAR_TABLE (char_table
)->parent
= parent
;
2622 current_default
= XCHAR_TABLE (char_table
)->defalt
;
2623 if (charset_id
== CHARSET_ASCII
2624 || charset_id
== CHARSET_8_BIT_CONTROL
2625 || charset_id
== CHARSET_8_BIT_GRAPHIC
)
2627 int from
, to
, defalt
;
2629 if (charset_id
== CHARSET_ASCII
)
2630 from
= 0, to
= 127, defalt
= CHAR_TABLE_DEFAULT_SLOT_ASCII
;
2631 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2632 from
= 128, to
= 159, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
;
2634 from
= 160, to
= 255, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
;
2635 if (! NILP (XCHAR_TABLE (char_table
)->contents
[defalt
]))
2636 current_default
= XCHAR_TABLE (char_table
)->contents
[defalt
];
2637 return char_table_range (char_table
, from
, to
, current_default
);
2640 val
= XCHAR_TABLE (char_table
)->contents
[128 + charset_id
];
2641 if (! SUB_CHAR_TABLE_P (val
))
2642 return (NILP (val
) ? current_default
: val
);
2643 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2644 current_default
= XCHAR_TABLE (val
)->defalt
;
2646 return char_table_range (val
, 32, 127, current_default
);
2647 val
= XCHAR_TABLE (val
)->contents
[c1
];
2648 if (! SUB_CHAR_TABLE_P (val
))
2649 return (NILP (val
) ? current_default
: val
);
2650 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2651 current_default
= XCHAR_TABLE (val
)->defalt
;
2652 return char_table_range (val
, 32, 127, current_default
);
2655 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2657 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2658 RANGE should be t (for all characters), nil (for the default value),
2659 a character set, a vector which identifies a character set, a row of a
2660 character set, or a character code. Return VALUE. */)
2661 (char_table
, range
, value
)
2662 Lisp_Object char_table
, range
, value
;
2666 CHECK_CHAR_TABLE (char_table
);
2669 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2671 /* Don't set these special slots used for default values of
2672 ascii, eight-bit-control, and eight-bit-graphic. */
2673 if (i
!= CHAR_TABLE_DEFAULT_SLOT_ASCII
2674 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2675 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
)
2676 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2678 else if (EQ (range
, Qnil
))
2679 XCHAR_TABLE (char_table
)->defalt
= value
;
2680 else if (SYMBOLP (range
))
2682 Lisp_Object charset_info
;
2685 charset_info
= Fget (range
, Qcharset
);
2686 if (! VECTORP (charset_info
)
2687 || ! NATNUMP (AREF (charset_info
, 0))
2688 || (charset_id
= XINT (AREF (charset_info
, 0)),
2689 ! CHARSET_DEFINED_P (charset_id
)))
2690 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2692 if (charset_id
== CHARSET_ASCII
)
2693 for (i
= 0; i
< 128; i
++)
2694 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2695 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2696 for (i
= 128; i
< 160; i
++)
2697 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2698 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2699 for (i
= 160; i
< 256; i
++)
2700 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2702 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2704 else if (INTEGERP (range
))
2705 Faset (char_table
, range
, value
);
2706 else if (VECTORP (range
))
2708 int size
= XVECTOR (range
)->size
;
2709 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2710 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2711 size
<= 1 ? Qnil
: val
[1],
2712 size
<= 2 ? Qnil
: val
[2]);
2713 Faset (char_table
, ch
, value
);
2716 error ("Invalid RANGE argument to `set-char-table-range'");
2721 DEFUN ("set-char-table-default", Fset_char_table_default
,
2722 Sset_char_table_default
, 3, 3, 0,
2723 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2724 The generic character specifies the group of characters.
2725 If CH is a normal character, set the default value for a group of
2726 characters to which CH belongs.
2727 See also the documentation of `make-char'. */)
2728 (char_table
, ch
, value
)
2729 Lisp_Object char_table
, ch
, value
;
2731 int c
, charset
, code1
, code2
;
2734 CHECK_CHAR_TABLE (char_table
);
2738 SPLIT_CHAR (c
, charset
, code1
, code2
);
2740 /* Since we may want to set the default value for a character set
2741 not yet defined, we check only if the character set is in the
2742 valid range or not, instead of it is already defined or not. */
2743 if (! CHARSET_VALID_P (charset
))
2744 invalid_character (c
);
2746 if (SINGLE_BYTE_CHAR_P (c
))
2748 /* We use special slots for the default values of single byte
2751 = (c
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2752 : c
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2753 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2755 return (XCHAR_TABLE (char_table
)->contents
[default_slot
] = value
);
2758 /* Even if C is not a generic char, we had better behave as if a
2759 generic char is specified. */
2760 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2762 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2763 if (! SUB_CHAR_TABLE_P (temp
))
2765 temp
= make_sub_char_table (temp
);
2766 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = temp
;
2770 XCHAR_TABLE (temp
)->defalt
= value
;
2774 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2775 if (SUB_CHAR_TABLE_P (temp
))
2776 XCHAR_TABLE (temp
)->defalt
= value
;
2778 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2782 /* Look up the element in TABLE at index CH,
2783 and return it as an integer.
2784 If the element is nil, return CH itself.
2785 (Actually we do that for any non-integer.) */
2788 char_table_translate (table
, ch
)
2793 value
= Faref (table
, make_number (ch
));
2794 if (! INTEGERP (value
))
2796 return XINT (value
);
2800 optimize_sub_char_table (table
, chars
)
2808 from
= 33, to
= 127;
2810 from
= 32, to
= 128;
2812 if (!SUB_CHAR_TABLE_P (*table
))
2814 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2815 for (; from
< to
; from
++)
2816 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2821 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2822 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2830 CHECK_CHAR_TABLE (table
);
2832 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2834 elt
= XCHAR_TABLE (table
)->contents
[i
];
2835 if (!SUB_CHAR_TABLE_P (elt
))
2837 dim
= CHARSET_DIMENSION (i
- 128);
2839 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2840 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2841 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2847 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2848 character or group of characters that share a value.
2849 DEPTH is the current depth in the originally specified
2850 chartable, and INDICES contains the vector indices
2851 for the levels our callers have descended.
2853 ARG is passed to C_FUNCTION when that is called. */
2856 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2857 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2858 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2862 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2864 GCPRO4 (arg
, table
, subtable
, function
);
2868 /* At first, handle ASCII and 8-bit European characters. */
2869 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2871 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2873 elt
= XCHAR_TABLE (subtable
)->defalt
;
2875 elt
= Faref (subtable
, make_number (i
));
2877 (*c_function
) (arg
, make_number (i
), elt
);
2879 call2 (function
, make_number (i
), elt
);
2881 #if 0 /* If the char table has entries for higher characters,
2882 we should report them. */
2883 if (NILP (current_buffer
->enable_multibyte_characters
))
2889 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2893 int charset
= XFASTINT (indices
[0]) - 128;
2896 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2897 if (CHARSET_CHARS (charset
) == 94)
2906 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2907 XSETFASTINT (indices
[depth
], i
);
2908 charset
= XFASTINT (indices
[0]) - 128;
2910 && (!CHARSET_DEFINED_P (charset
)
2911 || charset
== CHARSET_8_BIT_CONTROL
2912 || charset
== CHARSET_8_BIT_GRAPHIC
))
2915 if (SUB_CHAR_TABLE_P (elt
))
2918 error ("Too deep char table");
2919 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2925 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2926 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2927 c
= MAKE_CHAR (charset
, c1
, c2
);
2930 elt
= XCHAR_TABLE (subtable
)->defalt
;
2932 elt
= Faref (table
, make_number (c
));
2935 (*c_function
) (arg
, make_number (c
), elt
);
2937 call2 (function
, make_number (c
), elt
);
2943 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2945 void_call2 (a
, b
, c
)
2946 Lisp_Object a
, b
, c
;
2951 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2953 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2954 FUNCTION is called with two arguments--a key and a value.
2955 The key is always a possible IDX argument to `aref'. */)
2956 (function
, char_table
)
2957 Lisp_Object function
, char_table
;
2959 /* The depth of char table is at most 3. */
2960 Lisp_Object indices
[3];
2962 CHECK_CHAR_TABLE (char_table
);
2964 /* When Lisp_Object is represented as a union, `call2' cannot directly
2965 be passed to map_char_table because it returns a Lisp_Object rather
2966 than returning nothing.
2967 Casting leads to crashes on some architectures. -stef */
2968 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2972 /* Return a value for character C in char-table TABLE. Store the
2973 actual index for that value in *IDX. Ignore the default value of
2977 char_table_ref_and_index (table
, c
, idx
)
2981 int charset
, c1
, c2
;
2984 if (SINGLE_BYTE_CHAR_P (c
))
2987 return XCHAR_TABLE (table
)->contents
[c
];
2989 SPLIT_CHAR (c
, charset
, c1
, c2
);
2990 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2991 *idx
= MAKE_CHAR (charset
, 0, 0);
2992 if (!SUB_CHAR_TABLE_P (elt
))
2994 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2995 return XCHAR_TABLE (elt
)->defalt
;
2996 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2997 *idx
= MAKE_CHAR (charset
, c1
, 0);
2998 if (!SUB_CHAR_TABLE_P (elt
))
3000 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
3001 return XCHAR_TABLE (elt
)->defalt
;
3003 return XCHAR_TABLE (elt
)->contents
[c2
];
3013 Lisp_Object args
[2];
3016 return Fnconc (2, args
);
3018 return Fnconc (2, &s1
);
3019 #endif /* NO_ARG_ARRAY */
3022 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
3023 doc
: /* Concatenate any number of lists by altering them.
3024 Only the last argument is not altered, and need not be a list.
3025 usage: (nconc &rest LISTS) */)
3030 register int argnum
;
3031 register Lisp_Object tail
, tem
, val
;
3035 for (argnum
= 0; argnum
< nargs
; argnum
++)
3038 if (NILP (tem
)) continue;
3043 if (argnum
+ 1 == nargs
) break;
3046 tem
= wrong_type_argument (Qlistp
, tem
);
3055 tem
= args
[argnum
+ 1];
3056 Fsetcdr (tail
, tem
);
3058 args
[argnum
+ 1] = tail
;
3064 /* This is the guts of all mapping functions.
3065 Apply FN to each element of SEQ, one by one,
3066 storing the results into elements of VALS, a C vector of Lisp_Objects.
3067 LENI is the length of VALS, which should also be the length of SEQ. */
3070 mapcar1 (leni
, vals
, fn
, seq
)
3073 Lisp_Object fn
, seq
;
3075 register Lisp_Object tail
;
3078 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3082 /* Don't let vals contain any garbage when GC happens. */
3083 for (i
= 0; i
< leni
; i
++)
3086 GCPRO3 (dummy
, fn
, seq
);
3088 gcpro1
.nvars
= leni
;
3092 /* We need not explicitly protect `tail' because it is used only on lists, and
3093 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
3097 for (i
= 0; i
< leni
; i
++)
3099 dummy
= XVECTOR (seq
)->contents
[i
];
3100 dummy
= call1 (fn
, dummy
);
3105 else if (BOOL_VECTOR_P (seq
))
3107 for (i
= 0; i
< leni
; i
++)
3110 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
3111 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
3116 dummy
= call1 (fn
, dummy
);
3121 else if (STRINGP (seq
))
3125 for (i
= 0, i_byte
= 0; i
< leni
;)
3130 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3131 XSETFASTINT (dummy
, c
);
3132 dummy
= call1 (fn
, dummy
);
3134 vals
[i_before
] = dummy
;
3137 else /* Must be a list, since Flength did not get an error */
3140 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
3142 dummy
= call1 (fn
, XCAR (tail
));
3152 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3153 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3154 In between each pair of results, stick in SEPARATOR. Thus, " " as
3155 SEPARATOR results in spaces between the values returned by FUNCTION.
3156 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3157 (function
, sequence
, separator
)
3158 Lisp_Object function
, sequence
, separator
;
3163 register Lisp_Object
*args
;
3165 struct gcpro gcpro1
;
3169 len
= Flength (sequence
);
3171 nargs
= leni
+ leni
- 1;
3172 if (nargs
< 0) return build_string ("");
3174 SAFE_ALLOCA_LISP (args
, nargs
);
3177 mapcar1 (leni
, args
, function
, sequence
);
3180 for (i
= leni
- 1; i
> 0; i
--)
3181 args
[i
+ i
] = args
[i
];
3183 for (i
= 1; i
< nargs
; i
+= 2)
3184 args
[i
] = separator
;
3186 ret
= Fconcat (nargs
, args
);
3192 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3193 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3194 The result is a list just as long as SEQUENCE.
3195 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3196 (function
, sequence
)
3197 Lisp_Object function
, sequence
;
3199 register Lisp_Object len
;
3201 register Lisp_Object
*args
;
3205 len
= Flength (sequence
);
3206 leni
= XFASTINT (len
);
3208 SAFE_ALLOCA_LISP (args
, leni
);
3210 mapcar1 (leni
, args
, function
, sequence
);
3212 ret
= Flist (leni
, args
);
3218 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3219 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3220 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3221 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3222 (function
, sequence
)
3223 Lisp_Object function
, sequence
;
3227 leni
= XFASTINT (Flength (sequence
));
3228 mapcar1 (leni
, 0, function
, sequence
);
3233 /* Anything that calls this function must protect from GC! */
3235 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3236 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3237 Takes one argument, which is the string to display to ask the question.
3238 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3239 No confirmation of the answer is requested; a single character is enough.
3240 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3241 the bindings in `query-replace-map'; see the documentation of that variable
3242 for more information. In this case, the useful bindings are `act', `skip',
3243 `recenter', and `quit'.\)
3245 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3246 is nil and `use-dialog-box' is non-nil. */)
3250 register Lisp_Object obj
, key
, def
, map
;
3251 register int answer
;
3252 Lisp_Object xprompt
;
3253 Lisp_Object args
[2];
3254 struct gcpro gcpro1
, gcpro2
;
3255 int count
= SPECPDL_INDEX ();
3257 specbind (Qcursor_in_echo_area
, Qt
);
3259 map
= Fsymbol_value (intern ("query-replace-map"));
3261 CHECK_STRING (prompt
);
3263 GCPRO2 (prompt
, xprompt
);
3265 #ifdef HAVE_X_WINDOWS
3266 if (display_hourglass_p
)
3267 cancel_hourglass ();
3274 if (FRAME_WINDOW_P (SELECTED_FRAME ())
3275 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3279 Lisp_Object pane
, menu
;
3280 redisplay_preserve_echo_area (3);
3281 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3282 Fcons (Fcons (build_string ("No"), Qnil
),
3284 menu
= Fcons (prompt
, pane
);
3285 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3286 answer
= !NILP (obj
);
3289 #endif /* HAVE_MENUS */
3290 cursor_in_echo_area
= 1;
3291 choose_minibuf_frame ();
3294 Lisp_Object pargs
[3];
3296 /* Colorize prompt according to `minibuffer-prompt' face. */
3297 pargs
[0] = build_string ("%s(y or n) ");
3298 pargs
[1] = intern ("face");
3299 pargs
[2] = intern ("minibuffer-prompt");
3300 args
[0] = Fpropertize (3, pargs
);
3305 if (minibuffer_auto_raise
)
3307 Lisp_Object mini_frame
;
3309 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3311 Fraise_frame (mini_frame
);
3314 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
3315 obj
= read_filtered_event (1, 0, 0, 0);
3317 cursor_in_echo_area
= 0;
3318 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3321 key
= Fmake_vector (make_number (1), obj
);
3322 def
= Flookup_key (map
, key
, Qt
);
3324 if (EQ (def
, intern ("skip")))
3329 else if (EQ (def
, intern ("act")))
3334 else if (EQ (def
, intern ("recenter")))
3340 else if (EQ (def
, intern ("quit")))
3342 /* We want to exit this command for exit-prefix,
3343 and this is the only way to do it. */
3344 else if (EQ (def
, intern ("exit-prefix")))
3349 /* If we don't clear this, then the next call to read_char will
3350 return quit_char again, and we'll enter an infinite loop. */
3355 if (EQ (xprompt
, prompt
))
3357 args
[0] = build_string ("Please answer y or n. ");
3359 xprompt
= Fconcat (2, args
);
3364 if (! noninteractive
)
3366 cursor_in_echo_area
= -1;
3367 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3371 unbind_to (count
, Qnil
);
3372 return answer
? Qt
: Qnil
;
3375 /* This is how C code calls `yes-or-no-p' and allows the user
3378 Anything that calls this function must protect from GC! */
3381 do_yes_or_no_p (prompt
)
3384 return call1 (intern ("yes-or-no-p"), prompt
);
3387 /* Anything that calls this function must protect from GC! */
3389 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3390 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3391 Takes one argument, which is the string to display to ask the question.
3392 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3393 The user must confirm the answer with RET,
3394 and can edit it until it has been confirmed.
3396 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3397 is nil, and `use-dialog-box' is non-nil. */)
3401 register Lisp_Object ans
;
3402 Lisp_Object args
[2];
3403 struct gcpro gcpro1
;
3405 CHECK_STRING (prompt
);
3408 if (FRAME_WINDOW_P (SELECTED_FRAME ())
3409 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3413 Lisp_Object pane
, menu
, obj
;
3414 redisplay_preserve_echo_area (4);
3415 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3416 Fcons (Fcons (build_string ("No"), Qnil
),
3419 menu
= Fcons (prompt
, pane
);
3420 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3424 #endif /* HAVE_MENUS */
3427 args
[1] = build_string ("(yes or no) ");
3428 prompt
= Fconcat (2, args
);
3434 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3435 Qyes_or_no_p_history
, Qnil
,
3437 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3442 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3450 message ("Please answer yes or no.");
3451 Fsleep_for (make_number (2), Qnil
);
3455 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3456 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3458 Each of the three load averages is multiplied by 100, then converted
3461 When USE-FLOATS is non-nil, floats will be used instead of integers.
3462 These floats are not multiplied by 100.
3464 If the 5-minute or 15-minute load averages are not available, return a
3465 shortened list, containing only those averages which are available.
3467 An error is thrown if the load average can't be obtained. In some
3468 cases making it work would require Emacs being installed setuid or
3469 setgid so that it can read kernel information, and that usually isn't
3472 Lisp_Object use_floats
;
3475 int loads
= getloadavg (load_ave
, 3);
3476 Lisp_Object ret
= Qnil
;
3479 error ("load-average not implemented for this operating system");
3483 Lisp_Object load
= (NILP (use_floats
) ?
3484 make_number ((int) (100.0 * load_ave
[loads
]))
3485 : make_float (load_ave
[loads
]));
3486 ret
= Fcons (load
, ret
);
3492 Lisp_Object Vfeatures
, Qsubfeatures
;
3493 extern Lisp_Object Vafter_load_alist
;
3495 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3496 doc
: /* Returns t if FEATURE is present in this Emacs.
3498 Use this to conditionalize execution of lisp code based on the
3499 presence or absence of emacs or environment extensions.
3500 Use `provide' to declare that a feature is available. This function
3501 looks at the value of the variable `features'. The optional argument
3502 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3503 (feature
, subfeature
)
3504 Lisp_Object feature
, subfeature
;
3506 register Lisp_Object tem
;
3507 CHECK_SYMBOL (feature
);
3508 tem
= Fmemq (feature
, Vfeatures
);
3509 if (!NILP (tem
) && !NILP (subfeature
))
3510 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3511 return (NILP (tem
)) ? Qnil
: Qt
;
3514 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3515 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3516 The optional argument SUBFEATURES should be a list of symbols listing
3517 particular subfeatures supported in this version of FEATURE. */)
3518 (feature
, subfeatures
)
3519 Lisp_Object feature
, subfeatures
;
3521 register Lisp_Object tem
;
3522 CHECK_SYMBOL (feature
);
3523 CHECK_LIST (subfeatures
);
3524 if (!NILP (Vautoload_queue
))
3525 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
3527 tem
= Fmemq (feature
, Vfeatures
);
3529 Vfeatures
= Fcons (feature
, Vfeatures
);
3530 if (!NILP (subfeatures
))
3531 Fput (feature
, Qsubfeatures
, subfeatures
);
3532 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3534 /* Run any load-hooks for this file. */
3535 tem
= Fassq (feature
, Vafter_load_alist
);
3537 Fprogn (XCDR (tem
));
3542 /* `require' and its subroutines. */
3544 /* List of features currently being require'd, innermost first. */
3546 Lisp_Object require_nesting_list
;
3549 require_unwind (old_value
)
3550 Lisp_Object old_value
;
3552 return require_nesting_list
= old_value
;
3555 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3556 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3557 If FEATURE is not a member of the list `features', then the feature
3558 is not loaded; so load the file FILENAME.
3559 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3560 and `load' will try to load this name appended with the suffix `.elc' or
3561 `.el', in that order. The name without appended suffix will not be used.
3562 If the optional third argument NOERROR is non-nil,
3563 then return nil if the file is not found instead of signaling an error.
3564 Normally the return value is FEATURE.
3565 The normal messages at start and end of loading FILENAME are suppressed. */)
3566 (feature
, filename
, noerror
)
3567 Lisp_Object feature
, filename
, noerror
;
3569 register Lisp_Object tem
;
3570 struct gcpro gcpro1
, gcpro2
;
3571 int from_file
= load_in_progress
;
3573 CHECK_SYMBOL (feature
);
3575 /* Record the presence of `require' in this file
3576 even if the feature specified is already loaded.
3577 But not more than once in any file,
3578 and not when we aren't loading or reading from a file. */
3580 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
3581 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
3586 tem
= Fcons (Qrequire
, feature
);
3587 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3588 LOADHIST_ATTACH (tem
);
3590 tem
= Fmemq (feature
, Vfeatures
);
3594 int count
= SPECPDL_INDEX ();
3597 /* This is to make sure that loadup.el gives a clear picture
3598 of what files are preloaded and when. */
3599 if (! NILP (Vpurify_flag
))
3600 error ("(require %s) while preparing to dump",
3601 SDATA (SYMBOL_NAME (feature
)));
3603 /* A certain amount of recursive `require' is legitimate,
3604 but if we require the same feature recursively 3 times,
3606 tem
= require_nesting_list
;
3607 while (! NILP (tem
))
3609 if (! NILP (Fequal (feature
, XCAR (tem
))))
3614 error ("Recursive `require' for feature `%s'",
3615 SDATA (SYMBOL_NAME (feature
)));
3617 /* Update the list for any nested `require's that occur. */
3618 record_unwind_protect (require_unwind
, require_nesting_list
);
3619 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3621 /* Value saved here is to be restored into Vautoload_queue */
3622 record_unwind_protect (un_autoload
, Vautoload_queue
);
3623 Vautoload_queue
= Qt
;
3625 /* Load the file. */
3626 GCPRO2 (feature
, filename
);
3627 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3628 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3631 /* If load failed entirely, return nil. */
3633 return unbind_to (count
, Qnil
);
3635 tem
= Fmemq (feature
, Vfeatures
);
3637 error ("Required feature `%s' was not provided",
3638 SDATA (SYMBOL_NAME (feature
)));
3640 /* Once loading finishes, don't undo it. */
3641 Vautoload_queue
= Qt
;
3642 feature
= unbind_to (count
, feature
);
3648 /* Primitives for work of the "widget" library.
3649 In an ideal world, this section would not have been necessary.
3650 However, lisp function calls being as slow as they are, it turns
3651 out that some functions in the widget library (wid-edit.el) are the
3652 bottleneck of Widget operation. Here is their translation to C,
3653 for the sole reason of efficiency. */
3655 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3656 doc
: /* Return non-nil if PLIST has the property PROP.
3657 PLIST is a property list, which is a list of the form
3658 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3659 Unlike `plist-get', this allows you to distinguish between a missing
3660 property and a property with the value nil.
3661 The value is actually the tail of PLIST whose car is PROP. */)
3663 Lisp_Object plist
, prop
;
3665 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3668 plist
= XCDR (plist
);
3669 plist
= CDR (plist
);
3674 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3675 doc
: /* In WIDGET, set PROPERTY to VALUE.
3676 The value can later be retrieved with `widget-get'. */)
3677 (widget
, property
, value
)
3678 Lisp_Object widget
, property
, value
;
3680 CHECK_CONS (widget
);
3681 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3685 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3686 doc
: /* In WIDGET, get the value of PROPERTY.
3687 The value could either be specified when the widget was created, or
3688 later with `widget-put'. */)
3690 Lisp_Object widget
, property
;
3698 CHECK_CONS (widget
);
3699 tmp
= Fplist_member (XCDR (widget
), property
);
3705 tmp
= XCAR (widget
);
3708 widget
= Fget (tmp
, Qwidget_type
);
3712 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3713 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3714 ARGS are passed as extra arguments to the function.
3715 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3720 /* This function can GC. */
3721 Lisp_Object newargs
[3];
3722 struct gcpro gcpro1
, gcpro2
;
3725 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3726 newargs
[1] = args
[0];
3727 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3728 GCPRO2 (newargs
[0], newargs
[2]);
3729 result
= Fapply (3, newargs
);
3734 #ifdef HAVE_LANGINFO_CODESET
3735 #include <langinfo.h>
3738 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3739 doc
: /* Access locale data ITEM for the current C locale, if available.
3740 ITEM should be one of the following:
3742 `codeset', returning the character set as a string (locale item CODESET);
3744 `days', returning a 7-element vector of day names (locale items DAY_n);
3746 `months', returning a 12-element vector of month names (locale items MON_n);
3748 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3749 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3751 If the system can't provide such information through a call to
3752 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3754 See also Info node `(libc)Locales'.
3756 The data read from the system are decoded using `locale-coding-system'. */)
3761 #ifdef HAVE_LANGINFO_CODESET
3763 if (EQ (item
, Qcodeset
))
3765 str
= nl_langinfo (CODESET
);
3766 return build_string (str
);
3769 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3771 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3772 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3774 synchronize_system_time_locale ();
3775 for (i
= 0; i
< 7; i
++)
3777 str
= nl_langinfo (days
[i
]);
3778 val
= make_unibyte_string (str
, strlen (str
));
3779 /* Fixme: Is this coding system necessarily right, even if
3780 it is consistent with CODESET? If not, what to do? */
3781 Faset (v
, make_number (i
),
3782 code_convert_string_norecord (val
, Vlocale_coding_system
,
3789 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3791 struct Lisp_Vector
*p
= allocate_vector (12);
3792 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3793 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3795 synchronize_system_time_locale ();
3796 for (i
= 0; i
< 12; i
++)
3798 str
= nl_langinfo (months
[i
]);
3799 val
= make_unibyte_string (str
, strlen (str
));
3801 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3803 XSETVECTOR (val
, p
);
3807 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3808 but is in the locale files. This could be used by ps-print. */
3810 else if (EQ (item
, Qpaper
))
3812 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3813 make_number (nl_langinfo (PAPER_HEIGHT
)));
3815 #endif /* PAPER_WIDTH */
3816 #endif /* HAVE_LANGINFO_CODESET*/
3820 /* base64 encode/decode functions (RFC 2045).
3821 Based on code from GNU recode. */
3823 #define MIME_LINE_LENGTH 76
3825 #define IS_ASCII(Character) \
3827 #define IS_BASE64(Character) \
3828 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3829 #define IS_BASE64_IGNORABLE(Character) \
3830 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3831 || (Character) == '\f' || (Character) == '\r')
3833 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3834 character or return retval if there are no characters left to
3836 #define READ_QUADRUPLET_BYTE(retval) \
3841 if (nchars_return) \
3842 *nchars_return = nchars; \
3847 while (IS_BASE64_IGNORABLE (c))
3849 /* Table of characters coding the 64 values. */
3850 static char base64_value_to_char
[64] =
3852 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3853 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3854 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3855 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3856 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3857 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3858 '8', '9', '+', '/' /* 60-63 */
3861 /* Table of base64 values for first 128 characters. */
3862 static short base64_char_to_value
[128] =
3864 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3865 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3866 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3867 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3868 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3869 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3870 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3871 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3872 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3873 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3874 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3875 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3876 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3879 /* The following diagram shows the logical steps by which three octets
3880 get transformed into four base64 characters.
3882 .--------. .--------. .--------.
3883 |aaaaaabb| |bbbbcccc| |ccdddddd|
3884 `--------' `--------' `--------'
3886 .--------+--------+--------+--------.
3887 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3888 `--------+--------+--------+--------'
3890 .--------+--------+--------+--------.
3891 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3892 `--------+--------+--------+--------'
3894 The octets are divided into 6 bit chunks, which are then encoded into
3895 base64 characters. */
3898 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3899 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3901 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3903 doc
: /* Base64-encode the region between BEG and END.
3904 Return the length of the encoded text.
3905 Optional third argument NO-LINE-BREAK means do not break long lines
3906 into shorter lines. */)
3907 (beg
, end
, no_line_break
)
3908 Lisp_Object beg
, end
, no_line_break
;
3911 int allength
, length
;
3912 int ibeg
, iend
, encoded_length
;
3916 validate_region (&beg
, &end
);
3918 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3919 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3920 move_gap_both (XFASTINT (beg
), ibeg
);
3922 /* We need to allocate enough room for encoding the text.
3923 We need 33 1/3% more space, plus a newline every 76
3924 characters, and then we round up. */
3925 length
= iend
- ibeg
;
3926 allength
= length
+ length
/3 + 1;
3927 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3929 SAFE_ALLOCA (encoded
, char *, allength
);
3930 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3931 NILP (no_line_break
),
3932 !NILP (current_buffer
->enable_multibyte_characters
));
3933 if (encoded_length
> allength
)
3936 if (encoded_length
< 0)
3938 /* The encoding wasn't possible. */
3940 error ("Multibyte character in data for base64 encoding");
3943 /* Now we have encoded the region, so we insert the new contents
3944 and delete the old. (Insert first in order to preserve markers.) */
3945 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3946 insert (encoded
, encoded_length
);
3948 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3950 /* If point was outside of the region, restore it exactly; else just
3951 move to the beginning of the region. */
3952 if (old_pos
>= XFASTINT (end
))
3953 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3954 else if (old_pos
> XFASTINT (beg
))
3955 old_pos
= XFASTINT (beg
);
3958 /* We return the length of the encoded text. */
3959 return make_number (encoded_length
);
3962 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3964 doc
: /* Base64-encode STRING and return the result.
3965 Optional second argument NO-LINE-BREAK means do not break long lines
3966 into shorter lines. */)
3967 (string
, no_line_break
)
3968 Lisp_Object string
, no_line_break
;
3970 int allength
, length
, encoded_length
;
3972 Lisp_Object encoded_string
;
3975 CHECK_STRING (string
);
3977 /* We need to allocate enough room for encoding the text.
3978 We need 33 1/3% more space, plus a newline every 76
3979 characters, and then we round up. */
3980 length
= SBYTES (string
);
3981 allength
= length
+ length
/3 + 1;
3982 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3984 /* We need to allocate enough room for decoding the text. */
3985 SAFE_ALLOCA (encoded
, char *, allength
);
3987 encoded_length
= base64_encode_1 (SDATA (string
),
3988 encoded
, length
, NILP (no_line_break
),
3989 STRING_MULTIBYTE (string
));
3990 if (encoded_length
> allength
)
3993 if (encoded_length
< 0)
3995 /* The encoding wasn't possible. */
3997 error ("Multibyte character in data for base64 encoding");
4000 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
4003 return encoded_string
;
4007 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
4014 int counter
= 0, i
= 0;
4024 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4032 /* Wrap line every 76 characters. */
4036 if (counter
< MIME_LINE_LENGTH
/ 4)
4045 /* Process first byte of a triplet. */
4047 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
4048 value
= (0x03 & c
) << 4;
4050 /* Process second byte of a triplet. */
4054 *e
++ = base64_value_to_char
[value
];
4062 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4070 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
4071 value
= (0x0f & c
) << 2;
4073 /* Process third byte of a triplet. */
4077 *e
++ = base64_value_to_char
[value
];
4084 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4092 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
4093 *e
++ = base64_value_to_char
[0x3f & c
];
4100 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
4102 doc
: /* Base64-decode the region between BEG and END.
4103 Return the length of the decoded text.
4104 If the region can't be decoded, signal an error and don't modify the buffer. */)
4106 Lisp_Object beg
, end
;
4108 int ibeg
, iend
, length
, allength
;
4113 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
4116 validate_region (&beg
, &end
);
4118 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
4119 iend
= CHAR_TO_BYTE (XFASTINT (end
));
4121 length
= iend
- ibeg
;
4123 /* We need to allocate enough room for decoding the text. If we are
4124 working on a multibyte buffer, each decoded code may occupy at
4126 allength
= multibyte
? length
* 2 : length
;
4127 SAFE_ALLOCA (decoded
, char *, allength
);
4129 move_gap_both (XFASTINT (beg
), ibeg
);
4130 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
4131 multibyte
, &inserted_chars
);
4132 if (decoded_length
> allength
)
4135 if (decoded_length
< 0)
4137 /* The decoding wasn't possible. */
4139 error ("Invalid base64 data");
4142 /* Now we have decoded the region, so we insert the new contents
4143 and delete the old. (Insert first in order to preserve markers.) */
4144 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4145 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4148 /* Delete the original text. */
4149 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4150 iend
+ decoded_length
, 1);
4152 /* If point was outside of the region, restore it exactly; else just
4153 move to the beginning of the region. */
4154 if (old_pos
>= XFASTINT (end
))
4155 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4156 else if (old_pos
> XFASTINT (beg
))
4157 old_pos
= XFASTINT (beg
);
4158 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4160 return make_number (inserted_chars
);
4163 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4165 doc
: /* Base64-decode STRING and return the result. */)
4170 int length
, decoded_length
;
4171 Lisp_Object decoded_string
;
4174 CHECK_STRING (string
);
4176 length
= SBYTES (string
);
4177 /* We need to allocate enough room for decoding the text. */
4178 SAFE_ALLOCA (decoded
, char *, length
);
4180 /* The decoded result should be unibyte. */
4181 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4183 if (decoded_length
> length
)
4185 else if (decoded_length
>= 0)
4186 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4188 decoded_string
= Qnil
;
4191 if (!STRINGP (decoded_string
))
4192 error ("Invalid base64 data");
4194 return decoded_string
;
4197 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4198 MULTIBYTE is nonzero, the decoded result should be in multibyte
4199 form. If NCHARS_RETRUN is not NULL, store the number of produced
4200 characters in *NCHARS_RETURN. */
4203 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4213 unsigned long value
;
4218 /* Process first byte of a quadruplet. */
4220 READ_QUADRUPLET_BYTE (e
-to
);
4224 value
= base64_char_to_value
[c
] << 18;
4226 /* Process second byte of a quadruplet. */
4228 READ_QUADRUPLET_BYTE (-1);
4232 value
|= base64_char_to_value
[c
] << 12;
4234 c
= (unsigned char) (value
>> 16);
4236 e
+= CHAR_STRING (c
, e
);
4241 /* Process third byte of a quadruplet. */
4243 READ_QUADRUPLET_BYTE (-1);
4247 READ_QUADRUPLET_BYTE (-1);
4256 value
|= base64_char_to_value
[c
] << 6;
4258 c
= (unsigned char) (0xff & value
>> 8);
4260 e
+= CHAR_STRING (c
, e
);
4265 /* Process fourth byte of a quadruplet. */
4267 READ_QUADRUPLET_BYTE (-1);
4274 value
|= base64_char_to_value
[c
];
4276 c
= (unsigned char) (0xff & value
);
4278 e
+= CHAR_STRING (c
, e
);
4287 /***********************************************************************
4289 ***** Hash Tables *****
4291 ***********************************************************************/
4293 /* Implemented by gerd@gnu.org. This hash table implementation was
4294 inspired by CMUCL hash tables. */
4298 1. For small tables, association lists are probably faster than
4299 hash tables because they have lower overhead.
4301 For uses of hash tables where the O(1) behavior of table
4302 operations is not a requirement, it might therefore be a good idea
4303 not to hash. Instead, we could just do a linear search in the
4304 key_and_value vector of the hash table. This could be done
4305 if a `:linear-search t' argument is given to make-hash-table. */
4308 /* The list of all weak hash tables. Don't staticpro this one. */
4310 Lisp_Object Vweak_hash_tables
;
4312 /* Various symbols. */
4314 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4315 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4316 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4318 /* Function prototypes. */
4320 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4321 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4322 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4323 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4324 Lisp_Object
, unsigned));
4325 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4326 Lisp_Object
, unsigned));
4327 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4328 unsigned, Lisp_Object
, unsigned));
4329 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4330 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4331 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4332 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4334 static unsigned sxhash_string
P_ ((unsigned char *, int));
4335 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4336 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4337 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4338 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4342 /***********************************************************************
4344 ***********************************************************************/
4346 /* If OBJ is a Lisp hash table, return a pointer to its struct
4347 Lisp_Hash_Table. Otherwise, signal an error. */
4349 static struct Lisp_Hash_Table
*
4350 check_hash_table (obj
)
4353 CHECK_HASH_TABLE (obj
);
4354 return XHASH_TABLE (obj
);
4358 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4362 next_almost_prime (n
)
4375 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4376 which USED[I] is non-zero. If found at index I in ARGS, set
4377 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4378 -1. This function is used to extract a keyword/argument pair from
4379 a DEFUN parameter list. */
4382 get_key_arg (key
, nargs
, args
, used
)
4390 for (i
= 0; i
< nargs
- 1; ++i
)
4391 if (!used
[i
] && EQ (args
[i
], key
))
4406 /* Return a Lisp vector which has the same contents as VEC but has
4407 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4408 vector that are not copied from VEC are set to INIT. */
4411 larger_vector (vec
, new_size
, init
)
4416 struct Lisp_Vector
*v
;
4419 xassert (VECTORP (vec
));
4420 old_size
= XVECTOR (vec
)->size
;
4421 xassert (new_size
>= old_size
);
4423 v
= allocate_vector (new_size
);
4424 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4425 old_size
* sizeof *v
->contents
);
4426 for (i
= old_size
; i
< new_size
; ++i
)
4427 v
->contents
[i
] = init
;
4428 XSETVECTOR (vec
, v
);
4433 /***********************************************************************
4435 ***********************************************************************/
4437 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4438 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4439 KEY2 are the same. */
4442 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4443 struct Lisp_Hash_Table
*h
;
4444 Lisp_Object key1
, key2
;
4445 unsigned hash1
, hash2
;
4447 return (FLOATP (key1
)
4449 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4453 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4454 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4455 KEY2 are the same. */
4458 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4459 struct Lisp_Hash_Table
*h
;
4460 Lisp_Object key1
, key2
;
4461 unsigned hash1
, hash2
;
4463 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4467 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4468 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4469 if KEY1 and KEY2 are the same. */
4472 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4473 struct Lisp_Hash_Table
*h
;
4474 Lisp_Object key1
, key2
;
4475 unsigned hash1
, hash2
;
4479 Lisp_Object args
[3];
4481 args
[0] = h
->user_cmp_function
;
4484 return !NILP (Ffuncall (3, args
));
4491 /* Value is a hash code for KEY for use in hash table H which uses
4492 `eq' to compare keys. The hash code returned is guaranteed to fit
4493 in a Lisp integer. */
4497 struct Lisp_Hash_Table
*h
;
4500 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4501 xassert ((hash
& ~INTMASK
) == 0);
4506 /* Value is a hash code for KEY for use in hash table H which uses
4507 `eql' to compare keys. The hash code returned is guaranteed to fit
4508 in a Lisp integer. */
4512 struct Lisp_Hash_Table
*h
;
4517 hash
= sxhash (key
, 0);
4519 hash
= XUINT (key
) ^ XGCTYPE (key
);
4520 xassert ((hash
& ~INTMASK
) == 0);
4525 /* Value is a hash code for KEY for use in hash table H which uses
4526 `equal' to compare keys. The hash code returned is guaranteed to fit
4527 in a Lisp integer. */
4530 hashfn_equal (h
, key
)
4531 struct Lisp_Hash_Table
*h
;
4534 unsigned hash
= sxhash (key
, 0);
4535 xassert ((hash
& ~INTMASK
) == 0);
4540 /* Value is a hash code for KEY for use in hash table H which uses as
4541 user-defined function to compare keys. The hash code returned is
4542 guaranteed to fit in a Lisp integer. */
4545 hashfn_user_defined (h
, key
)
4546 struct Lisp_Hash_Table
*h
;
4549 Lisp_Object args
[2], hash
;
4551 args
[0] = h
->user_hash_function
;
4553 hash
= Ffuncall (2, args
);
4554 if (!INTEGERP (hash
))
4556 list2 (build_string ("Invalid hash code returned from \
4557 user-supplied hash function"),
4559 return XUINT (hash
);
4563 /* Create and initialize a new hash table.
4565 TEST specifies the test the hash table will use to compare keys.
4566 It must be either one of the predefined tests `eq', `eql' or
4567 `equal' or a symbol denoting a user-defined test named TEST with
4568 test and hash functions USER_TEST and USER_HASH.
4570 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4572 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4573 new size when it becomes full is computed by adding REHASH_SIZE to
4574 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4575 table's new size is computed by multiplying its old size with
4578 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4579 be resized when the ratio of (number of entries in the table) /
4580 (table size) is >= REHASH_THRESHOLD.
4582 WEAK specifies the weakness of the table. If non-nil, it must be
4583 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4586 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4587 user_test
, user_hash
)
4588 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4589 Lisp_Object user_test
, user_hash
;
4591 struct Lisp_Hash_Table
*h
;
4593 int index_size
, i
, sz
;
4595 /* Preconditions. */
4596 xassert (SYMBOLP (test
));
4597 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4598 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4599 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4600 xassert (FLOATP (rehash_threshold
)
4601 && XFLOATINT (rehash_threshold
) > 0
4602 && XFLOATINT (rehash_threshold
) <= 1.0);
4604 if (XFASTINT (size
) == 0)
4605 size
= make_number (1);
4607 /* Allocate a table and initialize it. */
4608 h
= allocate_hash_table ();
4610 /* Initialize hash table slots. */
4611 sz
= XFASTINT (size
);
4614 if (EQ (test
, Qeql
))
4616 h
->cmpfn
= cmpfn_eql
;
4617 h
->hashfn
= hashfn_eql
;
4619 else if (EQ (test
, Qeq
))
4622 h
->hashfn
= hashfn_eq
;
4624 else if (EQ (test
, Qequal
))
4626 h
->cmpfn
= cmpfn_equal
;
4627 h
->hashfn
= hashfn_equal
;
4631 h
->user_cmp_function
= user_test
;
4632 h
->user_hash_function
= user_hash
;
4633 h
->cmpfn
= cmpfn_user_defined
;
4634 h
->hashfn
= hashfn_user_defined
;
4638 h
->rehash_threshold
= rehash_threshold
;
4639 h
->rehash_size
= rehash_size
;
4640 h
->count
= make_number (0);
4641 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4642 h
->hash
= Fmake_vector (size
, Qnil
);
4643 h
->next
= Fmake_vector (size
, Qnil
);
4644 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4645 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4646 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4648 /* Set up the free list. */
4649 for (i
= 0; i
< sz
- 1; ++i
)
4650 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4651 h
->next_free
= make_number (0);
4653 XSET_HASH_TABLE (table
, h
);
4654 xassert (HASH_TABLE_P (table
));
4655 xassert (XHASH_TABLE (table
) == h
);
4657 /* Maybe add this hash table to the list of all weak hash tables. */
4659 h
->next_weak
= Qnil
;
4662 h
->next_weak
= Vweak_hash_tables
;
4663 Vweak_hash_tables
= table
;
4670 /* Return a copy of hash table H1. Keys and values are not copied,
4671 only the table itself is. */
4674 copy_hash_table (h1
)
4675 struct Lisp_Hash_Table
*h1
;
4678 struct Lisp_Hash_Table
*h2
;
4679 struct Lisp_Vector
*next
;
4681 h2
= allocate_hash_table ();
4682 next
= h2
->vec_next
;
4683 bcopy (h1
, h2
, sizeof *h2
);
4684 h2
->vec_next
= next
;
4685 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4686 h2
->hash
= Fcopy_sequence (h1
->hash
);
4687 h2
->next
= Fcopy_sequence (h1
->next
);
4688 h2
->index
= Fcopy_sequence (h1
->index
);
4689 XSET_HASH_TABLE (table
, h2
);
4691 /* Maybe add this hash table to the list of all weak hash tables. */
4692 if (!NILP (h2
->weak
))
4694 h2
->next_weak
= Vweak_hash_tables
;
4695 Vweak_hash_tables
= table
;
4702 /* Resize hash table H if it's too full. If H cannot be resized
4703 because it's already too large, throw an error. */
4706 maybe_resize_hash_table (h
)
4707 struct Lisp_Hash_Table
*h
;
4709 if (NILP (h
->next_free
))
4711 int old_size
= HASH_TABLE_SIZE (h
);
4712 int i
, new_size
, index_size
;
4714 if (INTEGERP (h
->rehash_size
))
4715 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4717 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4718 new_size
= max (old_size
+ 1, new_size
);
4719 index_size
= next_almost_prime ((int)
4721 / XFLOATINT (h
->rehash_threshold
)));
4722 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4723 error ("Hash table too large to resize");
4725 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4726 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4727 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4728 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4730 /* Update the free list. Do it so that new entries are added at
4731 the end of the free list. This makes some operations like
4733 for (i
= old_size
; i
< new_size
- 1; ++i
)
4734 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4736 if (!NILP (h
->next_free
))
4738 Lisp_Object last
, next
;
4740 last
= h
->next_free
;
4741 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4745 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4748 XSETFASTINT (h
->next_free
, old_size
);
4751 for (i
= 0; i
< old_size
; ++i
)
4752 if (!NILP (HASH_HASH (h
, i
)))
4754 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4755 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4756 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4757 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4763 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4764 the hash code of KEY. Value is the index of the entry in H
4765 matching KEY, or -1 if not found. */
4768 hash_lookup (h
, key
, hash
)
4769 struct Lisp_Hash_Table
*h
;
4774 int start_of_bucket
;
4777 hash_code
= h
->hashfn (h
, key
);
4781 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4782 idx
= HASH_INDEX (h
, start_of_bucket
);
4784 /* We need not gcpro idx since it's either an integer or nil. */
4787 int i
= XFASTINT (idx
);
4788 if (EQ (key
, HASH_KEY (h
, i
))
4790 && h
->cmpfn (h
, key
, hash_code
,
4791 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4793 idx
= HASH_NEXT (h
, i
);
4796 return NILP (idx
) ? -1 : XFASTINT (idx
);
4800 /* Put an entry into hash table H that associates KEY with VALUE.
4801 HASH is a previously computed hash code of KEY.
4802 Value is the index of the entry in H matching KEY. */
4805 hash_put (h
, key
, value
, hash
)
4806 struct Lisp_Hash_Table
*h
;
4807 Lisp_Object key
, value
;
4810 int start_of_bucket
, i
;
4812 xassert ((hash
& ~INTMASK
) == 0);
4814 /* Increment count after resizing because resizing may fail. */
4815 maybe_resize_hash_table (h
);
4816 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4818 /* Store key/value in the key_and_value vector. */
4819 i
= XFASTINT (h
->next_free
);
4820 h
->next_free
= HASH_NEXT (h
, i
);
4821 HASH_KEY (h
, i
) = key
;
4822 HASH_VALUE (h
, i
) = value
;
4824 /* Remember its hash code. */
4825 HASH_HASH (h
, i
) = make_number (hash
);
4827 /* Add new entry to its collision chain. */
4828 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4829 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4830 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4835 /* Remove the entry matching KEY from hash table H, if there is one. */
4838 hash_remove (h
, key
)
4839 struct Lisp_Hash_Table
*h
;
4843 int start_of_bucket
;
4844 Lisp_Object idx
, prev
;
4846 hash_code
= h
->hashfn (h
, key
);
4847 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4848 idx
= HASH_INDEX (h
, start_of_bucket
);
4851 /* We need not gcpro idx, prev since they're either integers or nil. */
4854 int i
= XFASTINT (idx
);
4856 if (EQ (key
, HASH_KEY (h
, i
))
4858 && h
->cmpfn (h
, key
, hash_code
,
4859 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4861 /* Take entry out of collision chain. */
4863 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4865 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4867 /* Clear slots in key_and_value and add the slots to
4869 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4870 HASH_NEXT (h
, i
) = h
->next_free
;
4871 h
->next_free
= make_number (i
);
4872 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4873 xassert (XINT (h
->count
) >= 0);
4879 idx
= HASH_NEXT (h
, i
);
4885 /* Clear hash table H. */
4889 struct Lisp_Hash_Table
*h
;
4891 if (XFASTINT (h
->count
) > 0)
4893 int i
, size
= HASH_TABLE_SIZE (h
);
4895 for (i
= 0; i
< size
; ++i
)
4897 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4898 HASH_KEY (h
, i
) = Qnil
;
4899 HASH_VALUE (h
, i
) = Qnil
;
4900 HASH_HASH (h
, i
) = Qnil
;
4903 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4904 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4906 h
->next_free
= make_number (0);
4907 h
->count
= make_number (0);
4913 /************************************************************************
4915 ************************************************************************/
4917 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4918 entries from the table that don't survive the current GC.
4919 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4920 non-zero if anything was marked. */
4923 sweep_weak_table (h
, remove_entries_p
)
4924 struct Lisp_Hash_Table
*h
;
4925 int remove_entries_p
;
4927 int bucket
, n
, marked
;
4929 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4932 for (bucket
= 0; bucket
< n
; ++bucket
)
4934 Lisp_Object idx
, next
, prev
;
4936 /* Follow collision chain, removing entries that
4937 don't survive this garbage collection. */
4939 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4941 int i
= XFASTINT (idx
);
4942 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4943 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4946 if (EQ (h
->weak
, Qkey
))
4947 remove_p
= !key_known_to_survive_p
;
4948 else if (EQ (h
->weak
, Qvalue
))
4949 remove_p
= !value_known_to_survive_p
;
4950 else if (EQ (h
->weak
, Qkey_or_value
))
4951 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4952 else if (EQ (h
->weak
, Qkey_and_value
))
4953 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4957 next
= HASH_NEXT (h
, i
);
4959 if (remove_entries_p
)
4963 /* Take out of collision chain. */
4965 HASH_INDEX (h
, bucket
) = next
;
4967 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4969 /* Add to free list. */
4970 HASH_NEXT (h
, i
) = h
->next_free
;
4973 /* Clear key, value, and hash. */
4974 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4975 HASH_HASH (h
, i
) = Qnil
;
4977 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4988 /* Make sure key and value survive. */
4989 if (!key_known_to_survive_p
)
4991 mark_object (HASH_KEY (h
, i
));
4995 if (!value_known_to_survive_p
)
4997 mark_object (HASH_VALUE (h
, i
));
5008 /* Remove elements from weak hash tables that don't survive the
5009 current garbage collection. Remove weak tables that don't survive
5010 from Vweak_hash_tables. Called from gc_sweep. */
5013 sweep_weak_hash_tables ()
5015 Lisp_Object table
, used
, next
;
5016 struct Lisp_Hash_Table
*h
;
5019 /* Mark all keys and values that are in use. Keep on marking until
5020 there is no more change. This is necessary for cases like
5021 value-weak table A containing an entry X -> Y, where Y is used in a
5022 key-weak table B, Z -> Y. If B comes after A in the list of weak
5023 tables, X -> Y might be removed from A, although when looking at B
5024 one finds that it shouldn't. */
5028 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
5030 h
= XHASH_TABLE (table
);
5031 if (h
->size
& ARRAY_MARK_FLAG
)
5032 marked
|= sweep_weak_table (h
, 0);
5037 /* Remove tables and entries that aren't used. */
5038 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
5040 h
= XHASH_TABLE (table
);
5041 next
= h
->next_weak
;
5043 if (h
->size
& ARRAY_MARK_FLAG
)
5045 /* TABLE is marked as used. Sweep its contents. */
5046 if (XFASTINT (h
->count
) > 0)
5047 sweep_weak_table (h
, 1);
5049 /* Add table to the list of used weak hash tables. */
5050 h
->next_weak
= used
;
5055 Vweak_hash_tables
= used
;
5060 /***********************************************************************
5061 Hash Code Computation
5062 ***********************************************************************/
5064 /* Maximum depth up to which to dive into Lisp structures. */
5066 #define SXHASH_MAX_DEPTH 3
5068 /* Maximum length up to which to take list and vector elements into
5071 #define SXHASH_MAX_LEN 7
5073 /* Combine two integers X and Y for hashing. */
5075 #define SXHASH_COMBINE(X, Y) \
5076 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
5080 /* Return a hash for string PTR which has length LEN. The hash
5081 code returned is guaranteed to fit in a Lisp integer. */
5084 sxhash_string (ptr
, len
)
5088 unsigned char *p
= ptr
;
5089 unsigned char *end
= p
+ len
;
5098 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
5101 return hash
& INTMASK
;
5105 /* Return a hash for list LIST. DEPTH is the current depth in the
5106 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
5109 sxhash_list (list
, depth
)
5116 if (depth
< SXHASH_MAX_DEPTH
)
5118 CONSP (list
) && i
< SXHASH_MAX_LEN
;
5119 list
= XCDR (list
), ++i
)
5121 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
5122 hash
= SXHASH_COMBINE (hash
, hash2
);
5127 unsigned hash2
= sxhash (list
, depth
+ 1);
5128 hash
= SXHASH_COMBINE (hash
, hash2
);
5135 /* Return a hash for vector VECTOR. DEPTH is the current depth in
5136 the Lisp structure. */
5139 sxhash_vector (vec
, depth
)
5143 unsigned hash
= XVECTOR (vec
)->size
;
5146 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5147 for (i
= 0; i
< n
; ++i
)
5149 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5150 hash
= SXHASH_COMBINE (hash
, hash2
);
5157 /* Return a hash for bool-vector VECTOR. */
5160 sxhash_bool_vector (vec
)
5163 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5166 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5167 for (i
= 0; i
< n
; ++i
)
5168 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5174 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5175 structure. Value is an unsigned integer clipped to INTMASK. */
5184 if (depth
> SXHASH_MAX_DEPTH
)
5187 switch (XTYPE (obj
))
5198 obj
= SYMBOL_NAME (obj
);
5202 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5205 /* This can be everything from a vector to an overlay. */
5206 case Lisp_Vectorlike
:
5208 /* According to the CL HyperSpec, two arrays are equal only if
5209 they are `eq', except for strings and bit-vectors. In
5210 Emacs, this works differently. We have to compare element
5212 hash
= sxhash_vector (obj
, depth
);
5213 else if (BOOL_VECTOR_P (obj
))
5214 hash
= sxhash_bool_vector (obj
);
5216 /* Others are `equal' if they are `eq', so let's take their
5222 hash
= sxhash_list (obj
, depth
);
5227 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5228 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5229 for (hash
= 0; p
< e
; ++p
)
5230 hash
= SXHASH_COMBINE (hash
, *p
);
5238 return hash
& INTMASK
;
5243 /***********************************************************************
5245 ***********************************************************************/
5248 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5249 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5253 unsigned hash
= sxhash (obj
, 0);;
5254 return make_number (hash
);
5258 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5259 doc
: /* Create and return a new hash table.
5261 Arguments are specified as keyword/argument pairs. The following
5262 arguments are defined:
5264 :test TEST -- TEST must be a symbol that specifies how to compare
5265 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5266 `equal'. User-supplied test and hash functions can be specified via
5267 `define-hash-table-test'.
5269 :size SIZE -- A hint as to how many elements will be put in the table.
5272 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5273 fills up. If REHASH-SIZE is an integer, add that many space. If it
5274 is a float, it must be > 1.0, and the new size is computed by
5275 multiplying the old size with that factor. Default is 1.5.
5277 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5278 Resize the hash table when ratio of the number of entries in the
5279 table. Default is 0.8.
5281 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5282 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5283 returned is a weak table. Key/value pairs are removed from a weak
5284 hash table when there are no non-weak references pointing to their
5285 key, value, one of key or value, or both key and value, depending on
5286 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5289 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5294 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5295 Lisp_Object user_test
, user_hash
;
5299 /* The vector `used' is used to keep track of arguments that
5300 have been consumed. */
5301 used
= (char *) alloca (nargs
* sizeof *used
);
5302 bzero (used
, nargs
* sizeof *used
);
5304 /* See if there's a `:test TEST' among the arguments. */
5305 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5306 test
= i
< 0 ? Qeql
: args
[i
];
5307 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5309 /* See if it is a user-defined test. */
5312 prop
= Fget (test
, Qhash_table_test
);
5313 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5314 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5316 user_test
= XCAR (prop
);
5317 user_hash
= XCAR (XCDR (prop
));
5320 user_test
= user_hash
= Qnil
;
5322 /* See if there's a `:size SIZE' argument. */
5323 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5324 size
= i
< 0 ? Qnil
: args
[i
];
5326 size
= make_number (DEFAULT_HASH_SIZE
);
5327 else if (!INTEGERP (size
) || XINT (size
) < 0)
5329 list2 (build_string ("Invalid hash table size"),
5332 /* Look for `:rehash-size SIZE'. */
5333 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5334 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5335 if (!NUMBERP (rehash_size
)
5336 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5337 || XFLOATINT (rehash_size
) <= 1.0)
5339 list2 (build_string ("Invalid hash table rehash size"),
5342 /* Look for `:rehash-threshold THRESHOLD'. */
5343 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5344 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5345 if (!FLOATP (rehash_threshold
)
5346 || XFLOATINT (rehash_threshold
) <= 0.0
5347 || XFLOATINT (rehash_threshold
) > 1.0)
5349 list2 (build_string ("Invalid hash table rehash threshold"),
5352 /* Look for `:weakness WEAK'. */
5353 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5354 weak
= i
< 0 ? Qnil
: args
[i
];
5356 weak
= Qkey_and_value
;
5359 && !EQ (weak
, Qvalue
)
5360 && !EQ (weak
, Qkey_or_value
)
5361 && !EQ (weak
, Qkey_and_value
))
5362 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5365 /* Now, all args should have been used up, or there's a problem. */
5366 for (i
= 0; i
< nargs
; ++i
)
5369 list2 (build_string ("Invalid argument list"), args
[i
]));
5371 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5372 user_test
, user_hash
);
5376 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5377 doc
: /* Return a copy of hash table TABLE. */)
5381 return copy_hash_table (check_hash_table (table
));
5385 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5386 doc
: /* Return the number of elements in TABLE. */)
5390 return check_hash_table (table
)->count
;
5394 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5395 Shash_table_rehash_size
, 1, 1, 0,
5396 doc
: /* Return the current rehash size of TABLE. */)
5400 return check_hash_table (table
)->rehash_size
;
5404 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5405 Shash_table_rehash_threshold
, 1, 1, 0,
5406 doc
: /* Return the current rehash threshold of TABLE. */)
5410 return check_hash_table (table
)->rehash_threshold
;
5414 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5415 doc
: /* Return the size of TABLE.
5416 The size can be used as an argument to `make-hash-table' to create
5417 a hash table than can hold as many elements of TABLE holds
5418 without need for resizing. */)
5422 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5423 return make_number (HASH_TABLE_SIZE (h
));
5427 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5428 doc
: /* Return the test TABLE uses. */)
5432 return check_hash_table (table
)->test
;
5436 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5438 doc
: /* Return the weakness of TABLE. */)
5442 return check_hash_table (table
)->weak
;
5446 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5447 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5451 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5455 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5456 doc
: /* Clear hash table TABLE. */)
5460 hash_clear (check_hash_table (table
));
5465 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5466 doc
: /* Look up KEY in TABLE and return its associated value.
5467 If KEY is not found, return DFLT which defaults to nil. */)
5469 Lisp_Object key
, table
, dflt
;
5471 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5472 int i
= hash_lookup (h
, key
, NULL
);
5473 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5477 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5478 doc
: /* Associate KEY with VALUE in hash table TABLE.
5479 If KEY is already present in table, replace its current value with
5482 Lisp_Object key
, value
, table
;
5484 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5488 i
= hash_lookup (h
, key
, &hash
);
5490 HASH_VALUE (h
, i
) = value
;
5492 hash_put (h
, key
, value
, hash
);
5498 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5499 doc
: /* Remove KEY from TABLE. */)
5501 Lisp_Object key
, table
;
5503 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5504 hash_remove (h
, key
);
5509 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5510 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5511 FUNCTION is called with two arguments, KEY and VALUE. */)
5513 Lisp_Object function
, table
;
5515 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5516 Lisp_Object args
[3];
5519 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5520 if (!NILP (HASH_HASH (h
, i
)))
5523 args
[1] = HASH_KEY (h
, i
);
5524 args
[2] = HASH_VALUE (h
, i
);
5532 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5533 Sdefine_hash_table_test
, 3, 3, 0,
5534 doc
: /* Define a new hash table test with name NAME, a symbol.
5536 In hash tables created with NAME specified as test, use TEST to
5537 compare keys, and HASH for computing hash codes of keys.
5539 TEST must be a function taking two arguments and returning non-nil if
5540 both arguments are the same. HASH must be a function taking one
5541 argument and return an integer that is the hash code of the argument.
5542 Hash code computation should use the whole value range of integers,
5543 including negative integers. */)
5545 Lisp_Object name
, test
, hash
;
5547 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5552 /************************************************************************
5554 ************************************************************************/
5559 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5560 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5562 A message digest is a cryptographic checksum of a document, and the
5563 algorithm to calculate it is defined in RFC 1321.
5565 The two optional arguments START and END are character positions
5566 specifying for which part of OBJECT the message digest should be
5567 computed. If nil or omitted, the digest is computed for the whole
5570 The MD5 message digest is computed from the result of encoding the
5571 text in a coding system, not directly from the internal Emacs form of
5572 the text. The optional fourth argument CODING-SYSTEM specifies which
5573 coding system to encode the text with. It should be the same coding
5574 system that you used or will use when actually writing the text into a
5577 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5578 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5579 system would be chosen by default for writing this text into a file.
5581 If OBJECT is a string, the most preferred coding system (see the
5582 command `prefer-coding-system') is used.
5584 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5585 guesswork fails. Normally, an error is signaled in such case. */)
5586 (object
, start
, end
, coding_system
, noerror
)
5587 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5589 unsigned char digest
[16];
5590 unsigned char value
[33];
5594 int start_char
= 0, end_char
= 0;
5595 int start_byte
= 0, end_byte
= 0;
5597 register struct buffer
*bp
;
5600 if (STRINGP (object
))
5602 if (NILP (coding_system
))
5604 /* Decide the coding-system to encode the data with. */
5606 if (STRING_MULTIBYTE (object
))
5607 /* use default, we can't guess correct value */
5608 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5610 coding_system
= Qraw_text
;
5613 if (NILP (Fcoding_system_p (coding_system
)))
5615 /* Invalid coding system. */
5617 if (!NILP (noerror
))
5618 coding_system
= Qraw_text
;
5621 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5624 if (STRING_MULTIBYTE (object
))
5625 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5627 size
= SCHARS (object
);
5628 size_byte
= SBYTES (object
);
5632 CHECK_NUMBER (start
);
5634 start_char
= XINT (start
);
5639 start_byte
= string_char_to_byte (object
, start_char
);
5645 end_byte
= size_byte
;
5651 end_char
= XINT (end
);
5656 end_byte
= string_char_to_byte (object
, end_char
);
5659 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5660 args_out_of_range_3 (object
, make_number (start_char
),
5661 make_number (end_char
));
5665 struct buffer
*prev
= current_buffer
;
5667 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5669 CHECK_BUFFER (object
);
5671 bp
= XBUFFER (object
);
5672 if (bp
!= current_buffer
)
5673 set_buffer_internal (bp
);
5679 CHECK_NUMBER_COERCE_MARKER (start
);
5687 CHECK_NUMBER_COERCE_MARKER (end
);
5692 temp
= b
, b
= e
, e
= temp
;
5694 if (!(BEGV
<= b
&& e
<= ZV
))
5695 args_out_of_range (start
, end
);
5697 if (NILP (coding_system
))
5699 /* Decide the coding-system to encode the data with.
5700 See fileio.c:Fwrite-region */
5702 if (!NILP (Vcoding_system_for_write
))
5703 coding_system
= Vcoding_system_for_write
;
5706 int force_raw_text
= 0;
5708 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5709 if (NILP (coding_system
)
5710 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5712 coding_system
= Qnil
;
5713 if (NILP (current_buffer
->enable_multibyte_characters
))
5717 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5719 /* Check file-coding-system-alist. */
5720 Lisp_Object args
[4], val
;
5722 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5723 args
[3] = Fbuffer_file_name(object
);
5724 val
= Ffind_operation_coding_system (4, args
);
5725 if (CONSP (val
) && !NILP (XCDR (val
)))
5726 coding_system
= XCDR (val
);
5729 if (NILP (coding_system
)
5730 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5732 /* If we still have not decided a coding system, use the
5733 default value of buffer-file-coding-system. */
5734 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5738 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5739 /* Confirm that VAL can surely encode the current region. */
5740 coding_system
= call4 (Vselect_safe_coding_system_function
,
5741 make_number (b
), make_number (e
),
5742 coding_system
, Qnil
);
5745 coding_system
= Qraw_text
;
5748 if (NILP (Fcoding_system_p (coding_system
)))
5750 /* Invalid coding system. */
5752 if (!NILP (noerror
))
5753 coding_system
= Qraw_text
;
5756 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5760 object
= make_buffer_string (b
, e
, 0);
5761 if (prev
!= current_buffer
)
5762 set_buffer_internal (prev
);
5763 /* Discard the unwind protect for recovering the current
5767 if (STRING_MULTIBYTE (object
))
5768 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5771 md5_buffer (SDATA (object
) + start_byte
,
5772 SBYTES (object
) - (size_byte
- end_byte
),
5775 for (i
= 0; i
< 16; i
++)
5776 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5779 return make_string (value
, 32);
5786 /* Hash table stuff. */
5787 Qhash_table_p
= intern ("hash-table-p");
5788 staticpro (&Qhash_table_p
);
5789 Qeq
= intern ("eq");
5791 Qeql
= intern ("eql");
5793 Qequal
= intern ("equal");
5794 staticpro (&Qequal
);
5795 QCtest
= intern (":test");
5796 staticpro (&QCtest
);
5797 QCsize
= intern (":size");
5798 staticpro (&QCsize
);
5799 QCrehash_size
= intern (":rehash-size");
5800 staticpro (&QCrehash_size
);
5801 QCrehash_threshold
= intern (":rehash-threshold");
5802 staticpro (&QCrehash_threshold
);
5803 QCweakness
= intern (":weakness");
5804 staticpro (&QCweakness
);
5805 Qkey
= intern ("key");
5807 Qvalue
= intern ("value");
5808 staticpro (&Qvalue
);
5809 Qhash_table_test
= intern ("hash-table-test");
5810 staticpro (&Qhash_table_test
);
5811 Qkey_or_value
= intern ("key-or-value");
5812 staticpro (&Qkey_or_value
);
5813 Qkey_and_value
= intern ("key-and-value");
5814 staticpro (&Qkey_and_value
);
5817 defsubr (&Smake_hash_table
);
5818 defsubr (&Scopy_hash_table
);
5819 defsubr (&Shash_table_count
);
5820 defsubr (&Shash_table_rehash_size
);
5821 defsubr (&Shash_table_rehash_threshold
);
5822 defsubr (&Shash_table_size
);
5823 defsubr (&Shash_table_test
);
5824 defsubr (&Shash_table_weakness
);
5825 defsubr (&Shash_table_p
);
5826 defsubr (&Sclrhash
);
5827 defsubr (&Sgethash
);
5828 defsubr (&Sputhash
);
5829 defsubr (&Sremhash
);
5830 defsubr (&Smaphash
);
5831 defsubr (&Sdefine_hash_table_test
);
5833 Qstring_lessp
= intern ("string-lessp");
5834 staticpro (&Qstring_lessp
);
5835 Qprovide
= intern ("provide");
5836 staticpro (&Qprovide
);
5837 Qrequire
= intern ("require");
5838 staticpro (&Qrequire
);
5839 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5840 staticpro (&Qyes_or_no_p_history
);
5841 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5842 staticpro (&Qcursor_in_echo_area
);
5843 Qwidget_type
= intern ("widget-type");
5844 staticpro (&Qwidget_type
);
5846 staticpro (&string_char_byte_cache_string
);
5847 string_char_byte_cache_string
= Qnil
;
5849 require_nesting_list
= Qnil
;
5850 staticpro (&require_nesting_list
);
5852 Fset (Qyes_or_no_p_history
, Qnil
);
5854 DEFVAR_LISP ("features", &Vfeatures
,
5855 doc
: /* A list of symbols which are the features of the executing emacs.
5856 Used by `featurep' and `require', and altered by `provide'. */);
5857 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5858 Qsubfeatures
= intern ("subfeatures");
5859 staticpro (&Qsubfeatures
);
5861 #ifdef HAVE_LANGINFO_CODESET
5862 Qcodeset
= intern ("codeset");
5863 staticpro (&Qcodeset
);
5864 Qdays
= intern ("days");
5866 Qmonths
= intern ("months");
5867 staticpro (&Qmonths
);
5868 Qpaper
= intern ("paper");
5869 staticpro (&Qpaper
);
5870 #endif /* HAVE_LANGINFO_CODESET */
5872 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5873 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5874 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5875 invoked by mouse clicks and mouse menu items. */);
5878 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5879 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5880 This applies to commands from menus and tool bar buttons. The value of
5881 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5882 used if both `use-dialog-box' and this variable are non-nil. */);
5883 use_file_dialog
= 1;
5885 defsubr (&Sidentity
);
5888 defsubr (&Ssafe_length
);
5889 defsubr (&Sstring_bytes
);
5890 defsubr (&Sstring_equal
);
5891 defsubr (&Scompare_strings
);
5892 defsubr (&Sstring_lessp
);
5895 defsubr (&Svconcat
);
5896 defsubr (&Scopy_sequence
);
5897 defsubr (&Sstring_make_multibyte
);
5898 defsubr (&Sstring_make_unibyte
);
5899 defsubr (&Sstring_as_multibyte
);
5900 defsubr (&Sstring_as_unibyte
);
5901 defsubr (&Sstring_to_multibyte
);
5902 defsubr (&Scopy_alist
);
5903 defsubr (&Ssubstring
);
5904 defsubr (&Ssubstring_no_properties
);
5916 defsubr (&Snreverse
);
5917 defsubr (&Sreverse
);
5919 defsubr (&Splist_get
);
5921 defsubr (&Splist_put
);
5923 defsubr (&Slax_plist_get
);
5924 defsubr (&Slax_plist_put
);
5927 defsubr (&Sequal_including_properties
);
5928 defsubr (&Sfillarray
);
5929 defsubr (&Sclear_string
);
5930 defsubr (&Schar_table_subtype
);
5931 defsubr (&Schar_table_parent
);
5932 defsubr (&Sset_char_table_parent
);
5933 defsubr (&Schar_table_extra_slot
);
5934 defsubr (&Sset_char_table_extra_slot
);
5935 defsubr (&Schar_table_range
);
5936 defsubr (&Sset_char_table_range
);
5937 defsubr (&Sset_char_table_default
);
5938 defsubr (&Soptimize_char_table
);
5939 defsubr (&Smap_char_table
);
5943 defsubr (&Smapconcat
);
5944 defsubr (&Sy_or_n_p
);
5945 defsubr (&Syes_or_no_p
);
5946 defsubr (&Sload_average
);
5947 defsubr (&Sfeaturep
);
5948 defsubr (&Srequire
);
5949 defsubr (&Sprovide
);
5950 defsubr (&Splist_member
);
5951 defsubr (&Swidget_put
);
5952 defsubr (&Swidget_get
);
5953 defsubr (&Swidget_apply
);
5954 defsubr (&Sbase64_encode_region
);
5955 defsubr (&Sbase64_decode_region
);
5956 defsubr (&Sbase64_encode_string
);
5957 defsubr (&Sbase64_decode_string
);
5959 defsubr (&Slocale_info
);
5966 Vweak_hash_tables
= Qnil
;
5969 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5970 (do not change this comment) */