1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
40 #include "intervals.h"
43 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
48 #define NULL (void *)0
52 #define min(a, b) ((a) < (b) ? (a) : (b))
53 #define max(a, b) ((a) > (b) ? (a) : (b))
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 extern int minibuffer_auto_raise
;
61 extern Lisp_Object minibuf_window
;
63 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
64 Lisp_Object Qyes_or_no_p_history
;
65 Lisp_Object Qcursor_in_echo_area
;
66 Lisp_Object Qwidget_type
;
68 extern Lisp_Object Qinput_method_function
;
70 static int internal_equal ();
72 extern long get_random ();
73 extern void seed_random ();
79 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
80 "Return the argument unchanged.")
87 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
88 "Return a pseudo-random number.\n\
89 All integers representable in Lisp are equally likely.\n\
90 On most systems, this is 28 bits' worth.\n\
91 With positive integer argument N, return random number in interval [0,N).\n\
92 With argument t, set the random number seed from the current time and pid.")
97 Lisp_Object lispy_val
;
98 unsigned long denominator
;
101 seed_random (getpid () + time (NULL
));
102 if (NATNUMP (n
) && XFASTINT (n
) != 0)
104 /* Try to take our random number from the higher bits of VAL,
105 not the lower, since (says Gentzel) the low bits of `random'
106 are less random than the higher ones. We do this by using the
107 quotient rather than the remainder. At the high end of the RNG
108 it's possible to get a quotient larger than n; discarding
109 these values eliminates the bias that would otherwise appear
110 when using a large n. */
111 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
113 val
= get_random () / denominator
;
114 while (val
>= XFASTINT (n
));
118 XSETINT (lispy_val
, val
);
122 /* Random data-structure functions */
124 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
125 "Return the length of vector, list or string SEQUENCE.\n\
126 A byte-code function object is also allowed.\n\
127 If the string contains multibyte characters, this is not the necessarily\n\
128 the number of bytes in the string; it is the number of characters.\n\
129 To get the number of bytes, use `string-bytes'")
131 register Lisp_Object sequence
;
133 register Lisp_Object tail
, val
;
137 if (STRINGP (sequence
))
138 XSETFASTINT (val
, XSTRING (sequence
)->size
);
139 else if (VECTORP (sequence
))
140 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
141 else if (CHAR_TABLE_P (sequence
))
142 XSETFASTINT (val
, MAX_CHAR
);
143 else if (BOOL_VECTOR_P (sequence
))
144 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
145 else if (COMPILEDP (sequence
))
146 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
147 else if (CONSP (sequence
))
150 while (CONSP (sequence
))
152 sequence
= XCDR (sequence
);
155 if (!CONSP (sequence
))
158 sequence
= XCDR (sequence
);
163 if (!NILP (sequence
))
164 wrong_type_argument (Qlistp
, sequence
);
166 val
= make_number (i
);
168 else if (NILP (sequence
))
169 XSETFASTINT (val
, 0);
172 sequence
= wrong_type_argument (Qsequencep
, sequence
);
178 /* This does not check for quits. That is safe
179 since it must terminate. */
181 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
182 "Return the length of a list, but avoid error or infinite loop.\n\
183 This function never gets an error. If LIST is not really a list,\n\
184 it returns 0. If LIST is circular, it returns a finite value\n\
185 which is at least the number of distinct elements.")
189 Lisp_Object tail
, halftail
, length
;
192 /* halftail is used to detect circular lists. */
194 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
196 if (EQ (tail
, halftail
) && len
!= 0)
200 halftail
= XCDR (halftail
);
203 XSETINT (length
, len
);
207 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
208 "Return the number of bytes in STRING.\n\
209 If STRING is a multibyte string, this is greater than the length of STRING.")
213 CHECK_STRING (string
, 1);
214 return make_number (STRING_BYTES (XSTRING (string
)));
217 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
218 "Return t if two strings have identical contents.\n\
219 Case is significant, but text properties are ignored.\n\
220 Symbols are also allowed; their print names are used instead.")
222 register Lisp_Object s1
, s2
;
225 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
227 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
228 CHECK_STRING (s1
, 0);
229 CHECK_STRING (s2
, 1);
231 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
232 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
233 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
238 DEFUN ("compare-strings", Fcompare_strings
,
239 Scompare_strings
, 6, 7, 0,
240 "Compare the contents of two strings, converting to multibyte if needed.\n\
241 In string STR1, skip the first START1 characters and stop at END1.\n\
242 In string STR2, skip the first START2 characters and stop at END2.\n\
243 END1 and END2 default to the full lengths of the respective strings.\n\
245 Case is significant in this comparison if IGNORE-CASE is nil.\n\
246 Unibyte strings are converted to multibyte for comparison.\n\
248 The value is t if the strings (or specified portions) match.\n\
249 If string STR1 is less, the value is a negative number N;\n\
250 - 1 - N is the number of characters that match at the beginning.\n\
251 If string STR1 is greater, the value is a positive number N;\n\
252 N - 1 is the number of characters that match at the beginning.")
253 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
254 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
256 register int end1_char
, end2_char
;
257 register int i1
, i1_byte
, i2
, i2_byte
;
259 CHECK_STRING (str1
, 0);
260 CHECK_STRING (str2
, 1);
262 start1
= make_number (0);
264 start2
= make_number (0);
265 CHECK_NATNUM (start1
, 2);
266 CHECK_NATNUM (start2
, 3);
268 CHECK_NATNUM (end1
, 4);
270 CHECK_NATNUM (end2
, 4);
275 i1_byte
= string_char_to_byte (str1
, i1
);
276 i2_byte
= string_char_to_byte (str2
, i2
);
278 end1_char
= XSTRING (str1
)->size
;
279 if (! NILP (end1
) && end1_char
> XINT (end1
))
280 end1_char
= XINT (end1
);
282 end2_char
= XSTRING (str2
)->size
;
283 if (! NILP (end2
) && end2_char
> XINT (end2
))
284 end2_char
= XINT (end2
);
286 while (i1
< end1_char
&& i2
< end2_char
)
288 /* When we find a mismatch, we must compare the
289 characters, not just the bytes. */
292 if (STRING_MULTIBYTE (str1
))
293 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
296 c1
= XSTRING (str1
)->data
[i1
++];
297 c1
= unibyte_char_to_multibyte (c1
);
300 if (STRING_MULTIBYTE (str2
))
301 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
304 c2
= XSTRING (str2
)->data
[i2
++];
305 c2
= unibyte_char_to_multibyte (c2
);
311 if (! NILP (ignore_case
))
315 tem
= Fupcase (make_number (c1
));
317 tem
= Fupcase (make_number (c2
));
324 /* Note that I1 has already been incremented
325 past the character that we are comparing;
326 hence we don't add or subtract 1 here. */
328 return make_number (- i1
);
330 return make_number (i1
);
334 return make_number (i1
- XINT (start1
) + 1);
336 return make_number (- i1
+ XINT (start1
) - 1);
341 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
342 "Return t if first arg string is less than second in lexicographic order.\n\
343 Case is significant.\n\
344 Symbols are also allowed; their print names are used instead.")
346 register Lisp_Object s1
, s2
;
349 register int i1
, i1_byte
, i2
, i2_byte
;
352 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
354 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
355 CHECK_STRING (s1
, 0);
356 CHECK_STRING (s2
, 1);
358 i1
= i1_byte
= i2
= i2_byte
= 0;
360 end
= XSTRING (s1
)->size
;
361 if (end
> XSTRING (s2
)->size
)
362 end
= XSTRING (s2
)->size
;
366 /* When we find a mismatch, we must compare the
367 characters, not just the bytes. */
370 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
371 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
374 return c1
< c2
? Qt
: Qnil
;
376 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
379 static Lisp_Object
concat ();
390 return concat (2, args
, Lisp_String
, 0);
392 return concat (2, &s1
, Lisp_String
, 0);
393 #endif /* NO_ARG_ARRAY */
399 Lisp_Object s1
, s2
, s3
;
406 return concat (3, args
, Lisp_String
, 0);
408 return concat (3, &s1
, Lisp_String
, 0);
409 #endif /* NO_ARG_ARRAY */
412 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
413 "Concatenate all the arguments and make the result a list.\n\
414 The result is a list whose elements are the elements of all the arguments.\n\
415 Each argument may be a list, vector or string.\n\
416 The last argument is not copied, just used as the tail of the new list.")
421 return concat (nargs
, args
, Lisp_Cons
, 1);
424 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
425 "Concatenate all the arguments and make the result a string.\n\
426 The result is a string whose elements are the elements of all the arguments.\n\
427 Each argument may be a string or a list or vector of characters (integers).")
432 return concat (nargs
, args
, Lisp_String
, 0);
435 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
436 "Concatenate all the arguments and make the result a vector.\n\
437 The result is a vector whose elements are the elements of all the arguments.\n\
438 Each argument may be a list, vector or string.")
443 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
446 /* Retrun a copy of a sub char table ARG. The elements except for a
447 nested sub char table are not copied. */
449 copy_sub_char_table (arg
)
452 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
455 /* Copy all the contents. */
456 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
457 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
458 /* Recursively copy any sub char-tables in the ordinary slots. */
459 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
460 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
461 XCHAR_TABLE (copy
)->contents
[i
]
462 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
468 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
469 "Return a copy of a list, vector or string.\n\
470 The elements of a list or vector are not copied; they are shared\n\
475 if (NILP (arg
)) return arg
;
477 if (CHAR_TABLE_P (arg
))
482 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
483 /* Copy all the slots, including the extra ones. */
484 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
485 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
486 * sizeof (Lisp_Object
)));
488 /* Recursively copy any sub char tables in the ordinary slots
489 for multibyte characters. */
490 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
491 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
492 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
493 XCHAR_TABLE (copy
)->contents
[i
]
494 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
499 if (BOOL_VECTOR_P (arg
))
503 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
505 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
506 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
511 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
512 arg
= wrong_type_argument (Qsequencep
, arg
);
513 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
516 /* In string STR of length LEN, see if bytes before STR[I] combine
517 with bytes after STR[I] to form a single character. If so, return
518 the number of bytes after STR[I] which combine in this way.
519 Otherwize, return 0. */
522 count_combining (str
, len
, i
)
526 int j
= i
- 1, bytes
;
528 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
530 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
531 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
533 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
534 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
537 /* This structure holds information of an argument of `concat' that is
538 a string and has text properties to be copied. */
541 int argnum
; /* refer to ARGS (arguments of `concat') */
542 int from
; /* refer to ARGS[argnum] (argument string) */
543 int to
; /* refer to VAL (the target string) */
547 concat (nargs
, args
, target_type
, last_special
)
550 enum Lisp_Type target_type
;
554 register Lisp_Object tail
;
555 register Lisp_Object
this;
557 int toindex_byte
= 0;
558 register int result_len
;
559 register int result_len_byte
;
561 Lisp_Object last_tail
;
564 /* When we make a multibyte string, we can't copy text properties
565 while concatinating each string because the length of resulting
566 string can't be decided until we finish the whole concatination.
567 So, we record strings that have text properties to be copied
568 here, and copy the text properties after the concatination. */
569 struct textprop_rec
*textprops
= NULL
;
570 /* Number of elments in textprops. */
571 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
+= STRING_BYTES (XSTRING (this));
647 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
648 XSTRING (this)->size
);
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;
681 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
683 for (argnum
= 0; argnum
< nargs
; argnum
++)
687 register unsigned int thisindex
= 0;
688 register unsigned int thisindex_byte
= 0;
692 thislen
= Flength (this), thisleni
= XINT (thislen
);
694 /* Between strings of the same kind, copy fast. */
695 if (STRINGP (this) && STRINGP (val
)
696 && STRING_MULTIBYTE (this) == some_multibyte
)
698 int thislen_byte
= STRING_BYTES (XSTRING (this));
701 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
702 STRING_BYTES (XSTRING (this)));
703 combined
= (some_multibyte
&& toindex_byte
> 0
704 ? count_combining (XSTRING (val
)->data
,
705 toindex_byte
+ thislen_byte
,
708 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
710 textprops
[num_textprops
].argnum
= argnum
;
711 /* We ignore text properties on characters being combined. */
712 textprops
[num_textprops
].from
= combined
;
713 textprops
[num_textprops
++].to
= toindex
;
715 toindex_byte
+= thislen_byte
;
716 toindex
+= thisleni
- combined
;
717 XSTRING (val
)->size
-= combined
;
719 /* Copy a single-byte string to a multibyte string. */
720 else if (STRINGP (this) && STRINGP (val
))
722 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
724 textprops
[num_textprops
].argnum
= argnum
;
725 textprops
[num_textprops
].from
= 0;
726 textprops
[num_textprops
++].to
= toindex
;
728 toindex_byte
+= copy_text (XSTRING (this)->data
,
729 XSTRING (val
)->data
+ toindex_byte
,
730 XSTRING (this)->size
, 0, 1);
734 /* Copy element by element. */
737 register Lisp_Object elt
;
739 /* Fetch next element of `this' arg into `elt', or break if
740 `this' is exhausted. */
741 if (NILP (this)) break;
743 elt
= XCAR (this), this = XCDR (this);
744 else if (thisindex
>= thisleni
)
746 else if (STRINGP (this))
749 if (STRING_MULTIBYTE (this))
751 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
754 XSETFASTINT (elt
, c
);
758 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
760 && (XINT (elt
) >= 0240
761 || (XINT (elt
) >= 0200
762 && ! NILP (Vnonascii_translation_table
)))
763 && XINT (elt
) < 0400)
765 c
= unibyte_char_to_multibyte (XINT (elt
));
770 else if (BOOL_VECTOR_P (this))
773 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
774 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
781 elt
= XVECTOR (this)->contents
[thisindex
++];
783 /* Store this element into the result. */
790 else if (VECTORP (val
))
791 XVECTOR (val
)->contents
[toindex
++] = elt
;
794 CHECK_NUMBER (elt
, 0);
795 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
799 += CHAR_STRING (XINT (elt
),
800 XSTRING (val
)->data
+ toindex_byte
);
802 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
805 && count_combining (XSTRING (val
)->data
,
806 toindex_byte
, toindex_byte
- 1))
807 XSTRING (val
)->size
--;
812 /* If we have any multibyte characters,
813 we already decided to make a multibyte string. */
816 /* P exists as a variable
817 to avoid a bug on the Masscomp C compiler. */
818 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
820 toindex_byte
+= CHAR_STRING (c
, p
);
827 XCDR (prev
) = last_tail
;
829 if (num_textprops
> 0)
833 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
835 this = args
[textprops
[argnum
].argnum
];
836 props
= text_property_list (this,
838 make_number (XSTRING (this)->size
),
840 /* If successive arguments have properites, be sure that the
841 value of `composition' property be the copy. */
843 && textprops
[argnum
- 1].argnum
+ 1 == textprops
[argnum
].argnum
)
844 make_composition_value_copy (props
);
845 add_text_properties_from_list (val
, props
,
846 make_number (textprops
[argnum
].to
));
852 static Lisp_Object string_char_byte_cache_string
;
853 static int string_char_byte_cache_charpos
;
854 static int string_char_byte_cache_bytepos
;
857 clear_string_char_byte_cache ()
859 string_char_byte_cache_string
= Qnil
;
862 /* Return the character index corresponding to CHAR_INDEX in STRING. */
865 string_char_to_byte (string
, char_index
)
870 int best_below
, best_below_byte
;
871 int best_above
, best_above_byte
;
873 if (! STRING_MULTIBYTE (string
))
876 best_below
= best_below_byte
= 0;
877 best_above
= XSTRING (string
)->size
;
878 best_above_byte
= STRING_BYTES (XSTRING (string
));
880 if (EQ (string
, string_char_byte_cache_string
))
882 if (string_char_byte_cache_charpos
< char_index
)
884 best_below
= string_char_byte_cache_charpos
;
885 best_below_byte
= string_char_byte_cache_bytepos
;
889 best_above
= string_char_byte_cache_charpos
;
890 best_above_byte
= string_char_byte_cache_bytepos
;
894 if (char_index
- best_below
< best_above
- char_index
)
896 while (best_below
< char_index
)
899 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
900 best_below
, best_below_byte
);
903 i_byte
= best_below_byte
;
907 while (best_above
> char_index
)
909 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
910 unsigned char *pbeg
= pend
- best_above_byte
;
911 unsigned char *p
= pend
- 1;
914 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
915 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
916 if (bytes
== pend
- p
)
917 best_above_byte
-= bytes
;
918 else if (bytes
> pend
- p
)
919 best_above_byte
-= (pend
- p
);
925 i_byte
= best_above_byte
;
928 string_char_byte_cache_bytepos
= i_byte
;
929 string_char_byte_cache_charpos
= i
;
930 string_char_byte_cache_string
= string
;
935 /* Return the character index corresponding to BYTE_INDEX in STRING. */
938 string_byte_to_char (string
, byte_index
)
943 int best_below
, best_below_byte
;
944 int best_above
, best_above_byte
;
946 if (! STRING_MULTIBYTE (string
))
949 best_below
= best_below_byte
= 0;
950 best_above
= XSTRING (string
)->size
;
951 best_above_byte
= STRING_BYTES (XSTRING (string
));
953 if (EQ (string
, string_char_byte_cache_string
))
955 if (string_char_byte_cache_bytepos
< byte_index
)
957 best_below
= string_char_byte_cache_charpos
;
958 best_below_byte
= string_char_byte_cache_bytepos
;
962 best_above
= string_char_byte_cache_charpos
;
963 best_above_byte
= string_char_byte_cache_bytepos
;
967 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
969 while (best_below_byte
< byte_index
)
972 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
973 best_below
, best_below_byte
);
976 i_byte
= best_below_byte
;
980 while (best_above_byte
> byte_index
)
982 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
983 unsigned char *pbeg
= pend
- best_above_byte
;
984 unsigned char *p
= pend
- 1;
987 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
988 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
989 if (bytes
== pend
- p
)
990 best_above_byte
-= bytes
;
991 else if (bytes
> pend
- p
)
992 best_above_byte
-= (pend
- p
);
998 i_byte
= best_above_byte
;
1001 string_char_byte_cache_bytepos
= i_byte
;
1002 string_char_byte_cache_charpos
= i
;
1003 string_char_byte_cache_string
= string
;
1008 /* Convert STRING to a multibyte string.
1009 Single-byte characters 0240 through 0377 are converted
1010 by adding nonascii_insert_offset to each. */
1013 string_make_multibyte (string
)
1019 if (STRING_MULTIBYTE (string
))
1022 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1023 XSTRING (string
)->size
);
1024 /* If all the chars are ASCII, they won't need any more bytes
1025 once converted. In that case, we can return STRING itself. */
1026 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1029 buf
= (unsigned char *) alloca (nbytes
);
1030 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1033 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1036 /* Convert STRING to a single-byte string. */
1039 string_make_unibyte (string
)
1044 if (! STRING_MULTIBYTE (string
))
1047 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1049 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1052 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1055 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1057 "Return the multibyte equivalent of STRING.\n\
1058 The function `unibyte-char-to-multibyte' is used to convert\n\
1059 each unibyte character to a multibyte character.")
1063 CHECK_STRING (string
, 0);
1065 return string_make_multibyte (string
);
1068 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1070 "Return the unibyte equivalent of STRING.\n\
1071 Multibyte character codes are converted to unibyte\n\
1072 by using just the low 8 bits.")
1076 CHECK_STRING (string
, 0);
1078 return string_make_unibyte (string
);
1081 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1083 "Return a unibyte string with the same individual bytes as STRING.\n\
1084 If STRING is unibyte, the result is STRING itself.\n\
1085 Otherwise it is a newly created string, with no text properties.\n\
1086 If STRING is multibyte and contains a character of charset `binary',\n\
1087 it is converted to the corresponding single byte.")
1091 CHECK_STRING (string
, 0);
1093 if (STRING_MULTIBYTE (string
))
1095 int bytes
= STRING_BYTES (XSTRING (string
));
1096 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1098 bcopy (XSTRING (string
)->data
, str
, bytes
);
1099 bytes
= str_as_unibyte (str
, bytes
);
1100 string
= make_unibyte_string (str
, bytes
);
1106 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1108 "Return a multibyte string with the same individual bytes as STRING.\n\
1109 If STRING is multibyte, the result is STRING itself.\n\
1110 Otherwise it is a newly created string, with no text properties.\n\
1111 If STRING is unibyte and contains an individual 8-bit byte (i.e. not\n\
1112 part of multibyte form), it is converted to the corresponding\n\
1113 multibyte character of charset `binary'.")
1117 CHECK_STRING (string
, 0);
1119 if (! STRING_MULTIBYTE (string
))
1121 Lisp_Object new_string
;
1124 parse_str_as_multibyte (XSTRING (string
)->data
,
1125 STRING_BYTES (XSTRING (string
)),
1127 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1128 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1129 STRING_BYTES (XSTRING (string
)));
1130 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1131 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1132 STRING_BYTES (XSTRING (string
)), NULL
);
1133 string
= new_string
;
1134 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1139 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1140 "Return a copy of ALIST.\n\
1141 This is an alist which represents the same mapping from objects to objects,\n\
1142 but does not share the alist structure with ALIST.\n\
1143 The objects mapped (cars and cdrs of elements of the alist)\n\
1144 are shared, however.\n\
1145 Elements of ALIST that are not conses are also shared.")
1149 register Lisp_Object tem
;
1151 CHECK_LIST (alist
, 0);
1154 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1155 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1157 register Lisp_Object car
;
1161 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1166 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1167 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1168 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1169 If FROM or TO is negative, it counts from the end.\n\
1171 This function allows vectors as well as strings.")
1174 register Lisp_Object from
, to
;
1179 int from_char
, to_char
;
1180 int from_byte
= 0, to_byte
= 0;
1182 if (! (STRINGP (string
) || VECTORP (string
)))
1183 wrong_type_argument (Qarrayp
, string
);
1185 CHECK_NUMBER (from
, 1);
1187 if (STRINGP (string
))
1189 size
= XSTRING (string
)->size
;
1190 size_byte
= STRING_BYTES (XSTRING (string
));
1193 size
= XVECTOR (string
)->size
;
1198 to_byte
= size_byte
;
1202 CHECK_NUMBER (to
, 2);
1204 to_char
= XINT (to
);
1208 if (STRINGP (string
))
1209 to_byte
= string_char_to_byte (string
, to_char
);
1212 from_char
= XINT (from
);
1215 if (STRINGP (string
))
1216 from_byte
= string_char_to_byte (string
, from_char
);
1218 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1219 args_out_of_range_3 (string
, make_number (from_char
),
1220 make_number (to_char
));
1222 if (STRINGP (string
))
1224 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1225 to_char
- from_char
, to_byte
- from_byte
,
1226 STRING_MULTIBYTE (string
));
1227 copy_text_properties (make_number (from_char
), make_number (to_char
),
1228 string
, make_number (0), res
, Qnil
);
1231 res
= Fvector (to_char
- from_char
,
1232 XVECTOR (string
)->contents
+ from_char
);
1237 /* Extract a substring of STRING, giving start and end positions
1238 both in characters and in bytes. */
1241 substring_both (string
, from
, from_byte
, to
, to_byte
)
1243 int from
, from_byte
, to
, to_byte
;
1249 if (! (STRINGP (string
) || VECTORP (string
)))
1250 wrong_type_argument (Qarrayp
, string
);
1252 if (STRINGP (string
))
1254 size
= XSTRING (string
)->size
;
1255 size_byte
= STRING_BYTES (XSTRING (string
));
1258 size
= XVECTOR (string
)->size
;
1260 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1261 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1263 if (STRINGP (string
))
1265 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1266 to
- from
, to_byte
- from_byte
,
1267 STRING_MULTIBYTE (string
));
1268 copy_text_properties (make_number (from
), make_number (to
),
1269 string
, make_number (0), res
, Qnil
);
1272 res
= Fvector (to
- from
,
1273 XVECTOR (string
)->contents
+ from
);
1278 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1279 "Take cdr N times on LIST, returns the result.")
1282 register Lisp_Object list
;
1284 register int i
, num
;
1285 CHECK_NUMBER (n
, 0);
1287 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1291 wrong_type_argument (Qlistp
, list
);
1297 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1298 "Return the Nth element of LIST.\n\
1299 N counts from zero. If LIST is not that long, nil is returned.")
1301 Lisp_Object n
, list
;
1303 return Fcar (Fnthcdr (n
, list
));
1306 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1307 "Return element of SEQUENCE at index N.")
1309 register Lisp_Object sequence
, n
;
1311 CHECK_NUMBER (n
, 0);
1314 if (CONSP (sequence
) || NILP (sequence
))
1315 return Fcar (Fnthcdr (n
, sequence
));
1316 else if (STRINGP (sequence
) || VECTORP (sequence
)
1317 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1318 return Faref (sequence
, n
);
1320 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1324 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1325 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1326 The value is actually the tail of LIST whose car is ELT.")
1328 register Lisp_Object elt
;
1331 register Lisp_Object tail
;
1332 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1334 register Lisp_Object tem
;
1336 wrong_type_argument (Qlistp
, list
);
1338 if (! NILP (Fequal (elt
, tem
)))
1345 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1346 "Return non-nil if ELT is an element of LIST.\n\
1347 Comparison done with EQ. The value is actually the tail of LIST\n\
1350 Lisp_Object elt
, list
;
1354 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1358 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1362 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1369 if (!CONSP (list
) && !NILP (list
))
1370 list
= wrong_type_argument (Qlistp
, list
);
1375 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1376 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1377 The value is actually the element of LIST whose car is KEY.\n\
1378 Elements of LIST that are not conses are ignored.")
1380 Lisp_Object key
, list
;
1387 || (CONSP (XCAR (list
))
1388 && EQ (XCAR (XCAR (list
)), key
)))
1393 || (CONSP (XCAR (list
))
1394 && EQ (XCAR (XCAR (list
)), key
)))
1399 || (CONSP (XCAR (list
))
1400 && EQ (XCAR (XCAR (list
)), key
)))
1408 result
= XCAR (list
);
1409 else if (NILP (list
))
1412 result
= wrong_type_argument (Qlistp
, list
);
1417 /* Like Fassq but never report an error and do not allow quits.
1418 Use only on lists known never to be circular. */
1421 assq_no_quit (key
, list
)
1422 Lisp_Object key
, list
;
1425 && (!CONSP (XCAR (list
))
1426 || !EQ (XCAR (XCAR (list
)), key
)))
1429 return CONSP (list
) ? XCAR (list
) : Qnil
;
1432 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1433 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1434 The value is actually the element of LIST whose car equals KEY.")
1436 Lisp_Object key
, list
;
1438 Lisp_Object result
, car
;
1443 || (CONSP (XCAR (list
))
1444 && (car
= XCAR (XCAR (list
)),
1445 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1450 || (CONSP (XCAR (list
))
1451 && (car
= XCAR (XCAR (list
)),
1452 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1457 || (CONSP (XCAR (list
))
1458 && (car
= XCAR (XCAR (list
)),
1459 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1467 result
= XCAR (list
);
1468 else if (NILP (list
))
1471 result
= wrong_type_argument (Qlistp
, list
);
1476 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1477 "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
1478 The value is actually the element of LIST whose cdr is KEY.")
1480 register Lisp_Object key
;
1488 || (CONSP (XCAR (list
))
1489 && EQ (XCDR (XCAR (list
)), key
)))
1494 || (CONSP (XCAR (list
))
1495 && EQ (XCDR (XCAR (list
)), key
)))
1500 || (CONSP (XCAR (list
))
1501 && EQ (XCDR (XCAR (list
)), key
)))
1510 else if (CONSP (list
))
1511 result
= XCAR (list
);
1513 result
= wrong_type_argument (Qlistp
, list
);
1518 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1519 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1520 The value is actually the element of LIST whose cdr equals KEY.")
1522 Lisp_Object key
, list
;
1524 Lisp_Object result
, cdr
;
1529 || (CONSP (XCAR (list
))
1530 && (cdr
= XCDR (XCAR (list
)),
1531 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1536 || (CONSP (XCAR (list
))
1537 && (cdr
= XCDR (XCAR (list
)),
1538 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1543 || (CONSP (XCAR (list
))
1544 && (cdr
= XCDR (XCAR (list
)),
1545 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1553 result
= XCAR (list
);
1554 else if (NILP (list
))
1557 result
= wrong_type_argument (Qlistp
, list
);
1562 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1563 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1564 The modified LIST is returned. Comparison is done with `eq'.\n\
1565 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1566 therefore, write `(setq foo (delq element foo))'\n\
1567 to be sure of changing the value of `foo'.")
1569 register Lisp_Object elt
;
1572 register Lisp_Object tail
, prev
;
1573 register Lisp_Object tem
;
1577 while (!NILP (tail
))
1580 wrong_type_argument (Qlistp
, list
);
1587 Fsetcdr (prev
, XCDR (tail
));
1597 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1598 "Delete by side effect any occurrences of ELT as a member of SEQ.\n\
1599 SEQ must be a list, a vector, or a string.\n\
1600 The modified SEQ is returned. Comparison is done with `equal'.\n\
1601 If SEQ is not a list, or the first member of SEQ is ELT, deleting it\n\
1602 is not a side effect; it is simply using a different sequence.\n\
1603 Therefore, write `(setq foo (delete element foo))'\n\
1604 to be sure of changing the value of `foo'.")
1606 Lisp_Object elt
, seq
;
1610 EMACS_INT i
, n
, size
;
1612 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1613 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1616 if (n
!= ASIZE (seq
))
1618 struct Lisp_Vector
*p
= allocate_vectorlike (n
);
1620 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1621 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1622 p
->contents
[n
++] = AREF (seq
, i
);
1625 XSETVECTOR (seq
, p
);
1628 else if (STRINGP (seq
))
1630 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1633 for (i
= nchars
= nbytes
= ibyte
= 0;
1634 i
< XSTRING (seq
)->size
;
1635 ++i
, ibyte
+= cbytes
)
1637 if (STRING_MULTIBYTE (seq
))
1639 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1640 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1641 cbytes
= CHAR_BYTES (c
);
1645 c
= XSTRING (seq
)->data
[i
];
1649 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1656 if (nchars
!= XSTRING (seq
)->size
)
1660 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1661 if (!STRING_MULTIBYTE (seq
))
1662 SET_STRING_BYTES (XSTRING (tem
), -1);
1664 for (i
= nchars
= nbytes
= ibyte
= 0;
1665 i
< XSTRING (seq
)->size
;
1666 ++i
, ibyte
+= cbytes
)
1668 if (STRING_MULTIBYTE (seq
))
1670 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1671 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1672 cbytes
= CHAR_BYTES (c
);
1676 c
= XSTRING (seq
)->data
[i
];
1680 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1682 unsigned char *from
= &XSTRING (seq
)->data
[ibyte
];
1683 unsigned char *to
= &XSTRING (tem
)->data
[nbytes
];
1689 for (n
= cbytes
; n
--; )
1699 Lisp_Object tail
, prev
;
1701 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1704 wrong_type_argument (Qlistp
, seq
);
1706 if (!NILP (Fequal (elt
, XCAR (tail
))))
1711 Fsetcdr (prev
, XCDR (tail
));
1722 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1723 "Reverse LIST by modifying cdr pointers.\n\
1724 Returns the beginning of the reversed list.")
1728 register Lisp_Object prev
, tail
, next
;
1730 if (NILP (list
)) return list
;
1733 while (!NILP (tail
))
1737 wrong_type_argument (Qlistp
, list
);
1739 Fsetcdr (tail
, prev
);
1746 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1747 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1748 See also the function `nreverse', which is used more often.")
1754 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1755 new = Fcons (XCAR (list
), new);
1757 wrong_type_argument (Qconsp
, list
);
1761 Lisp_Object
merge ();
1763 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1764 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1765 Returns the sorted list. LIST is modified by side effects.\n\
1766 PREDICATE is called with two elements of LIST, and should return T\n\
1767 if the first element is \"less\" than the second.")
1769 Lisp_Object list
, predicate
;
1771 Lisp_Object front
, back
;
1772 register Lisp_Object len
, tem
;
1773 struct gcpro gcpro1
, gcpro2
;
1774 register int length
;
1777 len
= Flength (list
);
1778 length
= XINT (len
);
1782 XSETINT (len
, (length
/ 2) - 1);
1783 tem
= Fnthcdr (len
, list
);
1785 Fsetcdr (tem
, Qnil
);
1787 GCPRO2 (front
, back
);
1788 front
= Fsort (front
, predicate
);
1789 back
= Fsort (back
, predicate
);
1791 return merge (front
, back
, predicate
);
1795 merge (org_l1
, org_l2
, pred
)
1796 Lisp_Object org_l1
, org_l2
;
1800 register Lisp_Object tail
;
1802 register Lisp_Object l1
, l2
;
1803 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1810 /* It is sufficient to protect org_l1 and org_l2.
1811 When l1 and l2 are updated, we copy the new values
1812 back into the org_ vars. */
1813 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1833 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1849 Fsetcdr (tail
, tem
);
1855 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1856 "Extract a value from a property list.\n\
1857 PLIST is a property list, which is a list of the form\n\
1858 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1859 corresponding to the given PROP, or nil if PROP is not\n\
1860 one of the properties on the list.")
1863 register Lisp_Object prop
;
1865 register Lisp_Object tail
;
1866 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCDR (tail
)))
1868 register Lisp_Object tem
;
1871 return Fcar (XCDR (tail
));
1876 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1877 "Return the value of SYMBOL's PROPNAME property.\n\
1878 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1880 Lisp_Object symbol
, propname
;
1882 CHECK_SYMBOL (symbol
, 0);
1883 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1886 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1887 "Change value in PLIST of PROP to VAL.\n\
1888 PLIST is a property list, which is a list of the form\n\
1889 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1890 If PROP is already a property on the list, its value is set to VAL,\n\
1891 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1892 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1893 The PLIST is modified by side effects.")
1896 register Lisp_Object prop
;
1899 register Lisp_Object tail
, prev
;
1900 Lisp_Object newcell
;
1902 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1903 tail
= XCDR (XCDR (tail
)))
1905 if (EQ (prop
, XCAR (tail
)))
1907 Fsetcar (XCDR (tail
), val
);
1912 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1916 Fsetcdr (XCDR (prev
), newcell
);
1920 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1921 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1922 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1923 (symbol
, propname
, value
)
1924 Lisp_Object symbol
, propname
, value
;
1926 CHECK_SYMBOL (symbol
, 0);
1927 XSYMBOL (symbol
)->plist
1928 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1932 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1933 "Return t if two Lisp objects have similar structure and contents.\n\
1934 They must have the same data type.\n\
1935 Conses are compared by comparing the cars and the cdrs.\n\
1936 Vectors and strings are compared element by element.\n\
1937 Numbers are compared by value, but integers cannot equal floats.\n\
1938 (Use `=' if you want integers and floats to be able to be equal.)\n\
1939 Symbols must match exactly.")
1941 register Lisp_Object o1
, o2
;
1943 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1947 internal_equal (o1
, o2
, depth
)
1948 register Lisp_Object o1
, o2
;
1952 error ("Stack overflow in equal");
1958 if (XTYPE (o1
) != XTYPE (o2
))
1964 return (extract_float (o1
) == extract_float (o2
));
1967 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1974 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1978 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1980 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1983 o1
= XOVERLAY (o1
)->plist
;
1984 o2
= XOVERLAY (o2
)->plist
;
1989 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1990 && (XMARKER (o1
)->buffer
== 0
1991 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1995 case Lisp_Vectorlike
:
1997 register int i
, size
;
1998 size
= XVECTOR (o1
)->size
;
1999 /* Pseudovectors have the type encoded in the size field, so this test
2000 actually checks that the objects have the same type as well as the
2002 if (XVECTOR (o2
)->size
!= size
)
2004 /* Boolvectors are compared much like strings. */
2005 if (BOOL_VECTOR_P (o1
))
2008 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2010 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2012 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2017 if (WINDOW_CONFIGURATIONP (o1
))
2018 return compare_window_configurations (o1
, o2
, 0);
2020 /* Aside from them, only true vectors, char-tables, and compiled
2021 functions are sensible to compare, so eliminate the others now. */
2022 if (size
& PSEUDOVECTOR_FLAG
)
2024 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2026 size
&= PSEUDOVECTOR_SIZE_MASK
;
2028 for (i
= 0; i
< size
; i
++)
2031 v1
= XVECTOR (o1
)->contents
[i
];
2032 v2
= XVECTOR (o2
)->contents
[i
];
2033 if (!internal_equal (v1
, v2
, depth
+ 1))
2041 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
2043 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
2045 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
2046 STRING_BYTES (XSTRING (o1
))))
2052 case Lisp_Type_Limit
:
2059 extern Lisp_Object
Fmake_char_internal ();
2061 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2062 "Store each element of ARRAY with ITEM.\n\
2063 ARRAY is a vector, string, char-table, or bool-vector.")
2065 Lisp_Object array
, item
;
2067 register int size
, index
, charval
;
2069 if (VECTORP (array
))
2071 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2072 size
= XVECTOR (array
)->size
;
2073 for (index
= 0; index
< size
; index
++)
2076 else if (CHAR_TABLE_P (array
))
2078 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2079 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2080 for (index
= 0; index
< size
; index
++)
2082 XCHAR_TABLE (array
)->defalt
= Qnil
;
2084 else if (STRINGP (array
))
2086 register unsigned char *p
= XSTRING (array
)->data
;
2087 CHECK_NUMBER (item
, 1);
2088 charval
= XINT (item
);
2089 size
= XSTRING (array
)->size
;
2090 if (STRING_MULTIBYTE (array
))
2092 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2093 int len
= CHAR_STRING (charval
, str
);
2094 int size_byte
= STRING_BYTES (XSTRING (array
));
2095 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2098 if (size
!= size_byte
)
2101 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2102 if (len
!= this_len
)
2103 error ("Attempt to change byte length of a string");
2106 for (i
= 0; i
< size_byte
; i
++)
2107 *p
++ = str
[i
% len
];
2110 for (index
= 0; index
< size
; index
++)
2113 else if (BOOL_VECTOR_P (array
))
2115 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2117 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2119 charval
= (! NILP (item
) ? -1 : 0);
2120 for (index
= 0; index
< size_in_chars
; index
++)
2125 array
= wrong_type_argument (Qarrayp
, array
);
2131 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2133 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
2135 Lisp_Object char_table
;
2137 CHECK_CHAR_TABLE (char_table
, 0);
2139 return XCHAR_TABLE (char_table
)->purpose
;
2142 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2144 "Return the parent char-table of CHAR-TABLE.\n\
2145 The value is either nil or another char-table.\n\
2146 If CHAR-TABLE holds nil for a given character,\n\
2147 then the actual applicable value is inherited from the parent char-table\n\
2148 \(or from its parents, if necessary).")
2150 Lisp_Object char_table
;
2152 CHECK_CHAR_TABLE (char_table
, 0);
2154 return XCHAR_TABLE (char_table
)->parent
;
2157 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2159 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
2160 PARENT must be either nil or another char-table.")
2161 (char_table
, parent
)
2162 Lisp_Object char_table
, parent
;
2166 CHECK_CHAR_TABLE (char_table
, 0);
2170 CHECK_CHAR_TABLE (parent
, 0);
2172 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2173 if (EQ (temp
, char_table
))
2174 error ("Attempt to make a chartable be its own parent");
2177 XCHAR_TABLE (char_table
)->parent
= parent
;
2182 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2184 "Return the value of CHAR-TABLE's extra-slot number N.")
2186 Lisp_Object char_table
, n
;
2188 CHECK_CHAR_TABLE (char_table
, 1);
2189 CHECK_NUMBER (n
, 2);
2191 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2192 args_out_of_range (char_table
, n
);
2194 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2197 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2198 Sset_char_table_extra_slot
,
2200 "Set CHAR-TABLE's extra-slot number N to VALUE.")
2201 (char_table
, n
, value
)
2202 Lisp_Object char_table
, n
, value
;
2204 CHECK_CHAR_TABLE (char_table
, 1);
2205 CHECK_NUMBER (n
, 2);
2207 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2208 args_out_of_range (char_table
, n
);
2210 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2213 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2215 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
2216 RANGE should be nil (for the default value)\n\
2217 a vector which identifies a character set or a row of a character set,\n\
2218 a character set name, or a character code.")
2220 Lisp_Object char_table
, range
;
2222 CHECK_CHAR_TABLE (char_table
, 0);
2224 if (EQ (range
, Qnil
))
2225 return XCHAR_TABLE (char_table
)->defalt
;
2226 else if (INTEGERP (range
))
2227 return Faref (char_table
, range
);
2228 else if (SYMBOLP (range
))
2230 Lisp_Object charset_info
;
2232 charset_info
= Fget (range
, Qcharset
);
2233 CHECK_VECTOR (charset_info
, 0);
2235 return Faref (char_table
,
2236 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2239 else if (VECTORP (range
))
2241 if (XVECTOR (range
)->size
== 1)
2242 return Faref (char_table
,
2243 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2246 int size
= XVECTOR (range
)->size
;
2247 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2248 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2249 size
<= 1 ? Qnil
: val
[1],
2250 size
<= 2 ? Qnil
: val
[2]);
2251 return Faref (char_table
, ch
);
2255 error ("Invalid RANGE argument to `char-table-range'");
2259 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2261 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2262 RANGE should be t (for all characters), nil (for the default value)\n\
2263 a vector which identifies a character set or a row of a character set,\n\
2264 a coding system, or a character code.")
2265 (char_table
, range
, value
)
2266 Lisp_Object char_table
, range
, value
;
2270 CHECK_CHAR_TABLE (char_table
, 0);
2273 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2274 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2275 else if (EQ (range
, Qnil
))
2276 XCHAR_TABLE (char_table
)->defalt
= value
;
2277 else if (SYMBOLP (range
))
2279 Lisp_Object charset_info
;
2281 charset_info
= Fget (range
, Qcharset
);
2282 CHECK_VECTOR (charset_info
, 0);
2284 return Faset (char_table
,
2285 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2289 else if (INTEGERP (range
))
2290 Faset (char_table
, range
, value
);
2291 else if (VECTORP (range
))
2293 if (XVECTOR (range
)->size
== 1)
2294 return Faset (char_table
,
2295 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2299 int size
= XVECTOR (range
)->size
;
2300 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2301 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2302 size
<= 1 ? Qnil
: val
[1],
2303 size
<= 2 ? Qnil
: val
[2]);
2304 return Faset (char_table
, ch
, value
);
2308 error ("Invalid RANGE argument to `set-char-table-range'");
2313 DEFUN ("set-char-table-default", Fset_char_table_default
,
2314 Sset_char_table_default
, 3, 3, 0,
2315 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2316 The generic character specifies the group of characters.\n\
2317 See also the documentation of make-char.")
2318 (char_table
, ch
, value
)
2319 Lisp_Object char_table
, ch
, value
;
2321 int c
, charset
, code1
, code2
;
2324 CHECK_CHAR_TABLE (char_table
, 0);
2325 CHECK_NUMBER (ch
, 1);
2328 SPLIT_CHAR (c
, charset
, code1
, code2
);
2330 /* Since we may want to set the default value for a character set
2331 not yet defined, we check only if the character set is in the
2332 valid range or not, instead of it is already defined or not. */
2333 if (! CHARSET_VALID_P (charset
))
2334 invalid_character (c
);
2336 if (charset
== CHARSET_ASCII
)
2337 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2339 /* Even if C is not a generic char, we had better behave as if a
2340 generic char is specified. */
2341 if (CHARSET_DIMENSION (charset
) == 1)
2343 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2346 if (SUB_CHAR_TABLE_P (temp
))
2347 XCHAR_TABLE (temp
)->defalt
= value
;
2349 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2353 if (! SUB_CHAR_TABLE_P (char_table
))
2354 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2355 = make_sub_char_table (temp
));
2356 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2357 if (SUB_CHAR_TABLE_P (temp
))
2358 XCHAR_TABLE (temp
)->defalt
= value
;
2360 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2364 /* Look up the element in TABLE at index CH,
2365 and return it as an integer.
2366 If the element is nil, return CH itself.
2367 (Actually we do that for any non-integer.) */
2370 char_table_translate (table
, ch
)
2375 value
= Faref (table
, make_number (ch
));
2376 if (! INTEGERP (value
))
2378 return XINT (value
);
2382 optimize_sub_char_table (table
, chars
)
2390 from
= 33, to
= 127;
2392 from
= 32, to
= 128;
2394 if (!SUB_CHAR_TABLE_P (*table
))
2396 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2397 for (; from
< to
; from
++)
2398 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2403 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2405 "Optimize char table TABLE.")
2413 CHECK_CHAR_TABLE (table
, 0);
2415 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2417 elt
= XCHAR_TABLE (table
)->contents
[i
];
2418 if (!SUB_CHAR_TABLE_P (elt
))
2420 dim
= CHARSET_DIMENSION (i
);
2422 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2423 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2424 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2430 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2431 character or group of characters that share a value.
2432 DEPTH is the current depth in the originally specified
2433 chartable, and INDICES contains the vector indices
2434 for the levels our callers have descended.
2436 ARG is passed to C_FUNCTION when that is called. */
2439 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2440 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2441 Lisp_Object function
, subtable
, arg
, *indices
;
2448 /* At first, handle ASCII and 8-bit European characters. */
2449 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2451 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2453 (*c_function
) (arg
, make_number (i
), elt
);
2455 call2 (function
, make_number (i
), elt
);
2457 #if 0 /* If the char table has entries for higher characters,
2458 we should report them. */
2459 if (NILP (current_buffer
->enable_multibyte_characters
))
2462 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2466 int charset
= XFASTINT (indices
[0]) - 128;
2469 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2470 if (CHARSET_CHARS (charset
) == 94)
2479 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2480 XSETFASTINT (indices
[depth
], i
);
2481 charset
= XFASTINT (indices
[0]) - 128;
2483 && (!CHARSET_DEFINED_P (charset
)
2484 || charset
== CHARSET_8_BIT_CONTROL
2485 || charset
== CHARSET_8_BIT_GRAPHIC
))
2488 if (SUB_CHAR_TABLE_P (elt
))
2491 error ("Too deep char table");
2492 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2499 elt
= XCHAR_TABLE (subtable
)->defalt
;
2500 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2501 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2502 c
= MAKE_CHAR (charset
, c1
, c2
);
2504 (*c_function
) (arg
, make_number (c
), elt
);
2506 call2 (function
, make_number (c
), elt
);
2511 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2513 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2514 FUNCTION is called with two arguments--a key and a value.\n\
2515 The key is always a possible IDX argument to `aref'.")
2516 (function
, char_table
)
2517 Lisp_Object function
, char_table
;
2519 /* The depth of char table is at most 3. */
2520 Lisp_Object indices
[3];
2522 CHECK_CHAR_TABLE (char_table
, 1);
2524 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2528 /* Return a value for character C in char-table TABLE. Store the
2529 actual index for that value in *IDX. Ignore the default value of
2533 char_table_ref_and_index (table
, c
, idx
)
2537 int charset
, c1
, c2
;
2540 if (SINGLE_BYTE_CHAR_P (c
))
2543 return XCHAR_TABLE (table
)->contents
[c
];
2545 SPLIT_CHAR (c
, charset
, c1
, c2
);
2546 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2547 *idx
= MAKE_CHAR (charset
, 0, 0);
2548 if (!SUB_CHAR_TABLE_P (elt
))
2550 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2551 return XCHAR_TABLE (elt
)->defalt
;
2552 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2553 *idx
= MAKE_CHAR (charset
, c1
, 0);
2554 if (!SUB_CHAR_TABLE_P (elt
))
2556 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2557 return XCHAR_TABLE (elt
)->defalt
;
2559 return XCHAR_TABLE (elt
)->contents
[c2
];
2569 Lisp_Object args
[2];
2572 return Fnconc (2, args
);
2574 return Fnconc (2, &s1
);
2575 #endif /* NO_ARG_ARRAY */
2578 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2579 "Concatenate any number of lists by altering them.\n\
2580 Only the last argument is not altered, and need not be a list.")
2585 register int argnum
;
2586 register Lisp_Object tail
, tem
, val
;
2590 for (argnum
= 0; argnum
< nargs
; argnum
++)
2593 if (NILP (tem
)) continue;
2598 if (argnum
+ 1 == nargs
) break;
2601 tem
= wrong_type_argument (Qlistp
, tem
);
2610 tem
= args
[argnum
+ 1];
2611 Fsetcdr (tail
, tem
);
2613 args
[argnum
+ 1] = tail
;
2619 /* This is the guts of all mapping functions.
2620 Apply FN to each element of SEQ, one by one,
2621 storing the results into elements of VALS, a C vector of Lisp_Objects.
2622 LENI is the length of VALS, which should also be the length of SEQ. */
2625 mapcar1 (leni
, vals
, fn
, seq
)
2628 Lisp_Object fn
, seq
;
2630 register Lisp_Object tail
;
2633 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2637 /* Don't let vals contain any garbage when GC happens. */
2638 for (i
= 0; i
< leni
; i
++)
2641 GCPRO3 (dummy
, fn
, seq
);
2643 gcpro1
.nvars
= leni
;
2647 /* We need not explicitly protect `tail' because it is used only on lists, and
2648 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2652 for (i
= 0; i
< leni
; i
++)
2654 dummy
= XVECTOR (seq
)->contents
[i
];
2655 dummy
= call1 (fn
, dummy
);
2660 else if (BOOL_VECTOR_P (seq
))
2662 for (i
= 0; i
< leni
; i
++)
2665 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2666 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2671 dummy
= call1 (fn
, dummy
);
2676 else if (STRINGP (seq
))
2680 for (i
= 0, i_byte
= 0; i
< leni
;)
2685 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2686 XSETFASTINT (dummy
, c
);
2687 dummy
= call1 (fn
, dummy
);
2689 vals
[i_before
] = dummy
;
2692 else /* Must be a list, since Flength did not get an error */
2695 for (i
= 0; i
< leni
; i
++)
2697 dummy
= call1 (fn
, Fcar (tail
));
2707 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2708 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2709 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2710 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2711 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2712 (function
, sequence
, separator
)
2713 Lisp_Object function
, sequence
, separator
;
2718 register Lisp_Object
*args
;
2720 struct gcpro gcpro1
;
2722 len
= Flength (sequence
);
2724 nargs
= leni
+ leni
- 1;
2725 if (nargs
< 0) return build_string ("");
2727 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2730 mapcar1 (leni
, args
, function
, sequence
);
2733 for (i
= leni
- 1; i
>= 0; i
--)
2734 args
[i
+ i
] = args
[i
];
2736 for (i
= 1; i
< nargs
; i
+= 2)
2737 args
[i
] = separator
;
2739 return Fconcat (nargs
, args
);
2742 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2743 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2744 The result is a list just as long as SEQUENCE.\n\
2745 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2746 (function
, sequence
)
2747 Lisp_Object function
, sequence
;
2749 register Lisp_Object len
;
2751 register Lisp_Object
*args
;
2753 len
= Flength (sequence
);
2754 leni
= XFASTINT (len
);
2755 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2757 mapcar1 (leni
, args
, function
, sequence
);
2759 return Flist (leni
, args
);
2762 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2763 "Apply FUNCTION to each element of SEQUENCE for side effects only.\n\
2764 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.\n\
2765 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2766 (function
, sequence
)
2767 Lisp_Object function
, sequence
;
2771 leni
= XFASTINT (Flength (sequence
));
2772 mapcar1 (leni
, 0, function
, sequence
);
2777 /* Anything that calls this function must protect from GC! */
2779 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2780 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2781 Takes one argument, which is the string to display to ask the question.\n\
2782 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2783 No confirmation of the answer is requested; a single character is enough.\n\
2784 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2785 the bindings in `query-replace-map'; see the documentation of that variable\n\
2786 for more information. In this case, the useful bindings are `act', `skip',\n\
2787 `recenter', and `quit'.\)\n\
2789 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2794 register Lisp_Object obj
, key
, def
, map
;
2795 register int answer
;
2796 Lisp_Object xprompt
;
2797 Lisp_Object args
[2];
2798 struct gcpro gcpro1
, gcpro2
;
2799 int count
= specpdl_ptr
- specpdl
;
2801 specbind (Qcursor_in_echo_area
, Qt
);
2803 map
= Fsymbol_value (intern ("query-replace-map"));
2805 CHECK_STRING (prompt
, 0);
2807 GCPRO2 (prompt
, xprompt
);
2809 #ifdef HAVE_X_WINDOWS
2810 if (display_busy_cursor_p
)
2811 cancel_busy_cursor ();
2818 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2822 Lisp_Object pane
, menu
;
2823 redisplay_preserve_echo_area ();
2824 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2825 Fcons (Fcons (build_string ("No"), Qnil
),
2827 menu
= Fcons (prompt
, pane
);
2828 obj
= Fx_popup_dialog (Qt
, menu
);
2829 answer
= !NILP (obj
);
2832 #endif /* HAVE_MENUS */
2833 cursor_in_echo_area
= 1;
2834 choose_minibuf_frame ();
2835 message_with_string ("%s(y or n) ", xprompt
, 0);
2837 if (minibuffer_auto_raise
)
2839 Lisp_Object mini_frame
;
2841 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2843 Fraise_frame (mini_frame
);
2846 obj
= read_filtered_event (1, 0, 0, 0);
2847 cursor_in_echo_area
= 0;
2848 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2851 key
= Fmake_vector (make_number (1), obj
);
2852 def
= Flookup_key (map
, key
, Qt
);
2854 if (EQ (def
, intern ("skip")))
2859 else if (EQ (def
, intern ("act")))
2864 else if (EQ (def
, intern ("recenter")))
2870 else if (EQ (def
, intern ("quit")))
2872 /* We want to exit this command for exit-prefix,
2873 and this is the only way to do it. */
2874 else if (EQ (def
, intern ("exit-prefix")))
2879 /* If we don't clear this, then the next call to read_char will
2880 return quit_char again, and we'll enter an infinite loop. */
2885 if (EQ (xprompt
, prompt
))
2887 args
[0] = build_string ("Please answer y or n. ");
2889 xprompt
= Fconcat (2, args
);
2894 if (! noninteractive
)
2896 cursor_in_echo_area
= -1;
2897 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2901 unbind_to (count
, Qnil
);
2902 return answer
? Qt
: Qnil
;
2905 /* This is how C code calls `yes-or-no-p' and allows the user
2908 Anything that calls this function must protect from GC! */
2911 do_yes_or_no_p (prompt
)
2914 return call1 (intern ("yes-or-no-p"), prompt
);
2917 /* Anything that calls this function must protect from GC! */
2919 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2920 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2921 Takes one argument, which is the string to display to ask the question.\n\
2922 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2923 The user must confirm the answer with RET,\n\
2924 and can edit it until it has been confirmed.\n\
2926 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2931 register Lisp_Object ans
;
2932 Lisp_Object args
[2];
2933 struct gcpro gcpro1
;
2935 CHECK_STRING (prompt
, 0);
2938 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2942 Lisp_Object pane
, menu
, obj
;
2943 redisplay_preserve_echo_area ();
2944 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2945 Fcons (Fcons (build_string ("No"), Qnil
),
2948 menu
= Fcons (prompt
, pane
);
2949 obj
= Fx_popup_dialog (Qt
, menu
);
2953 #endif /* HAVE_MENUS */
2956 args
[1] = build_string ("(yes or no) ");
2957 prompt
= Fconcat (2, args
);
2963 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2964 Qyes_or_no_p_history
, Qnil
,
2966 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2971 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2979 message ("Please answer yes or no.");
2980 Fsleep_for (make_number (2), Qnil
);
2984 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2985 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2986 Each of the three load averages is multiplied by 100,\n\
2987 then converted to integer.\n\
2988 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2989 These floats are not multiplied by 100.\n\n\
2990 If the 5-minute or 15-minute load averages are not available, return a\n\
2991 shortened list, containing only those averages which are available.")
2993 Lisp_Object use_floats
;
2996 int loads
= getloadavg (load_ave
, 3);
2997 Lisp_Object ret
= Qnil
;
3000 error ("load-average not implemented for this operating system");
3004 Lisp_Object load
= (NILP (use_floats
) ?
3005 make_number ((int) (100.0 * load_ave
[loads
]))
3006 : make_float (load_ave
[loads
]));
3007 ret
= Fcons (load
, ret
);
3013 Lisp_Object Vfeatures
;
3015 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
3016 "Returns t if FEATURE is present in this Emacs.\n\
3017 Use this to conditionalize execution of lisp code based on the presence or\n\
3018 absence of emacs or environment extensions.\n\
3019 Use `provide' to declare that a feature is available.\n\
3020 This function looks at the value of the variable `features'.")
3022 Lisp_Object feature
;
3024 register Lisp_Object tem
;
3025 CHECK_SYMBOL (feature
, 0);
3026 tem
= Fmemq (feature
, Vfeatures
);
3027 return (NILP (tem
)) ? Qnil
: Qt
;
3030 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
3031 "Announce that FEATURE is a feature of the current Emacs.")
3033 Lisp_Object feature
;
3035 register Lisp_Object tem
;
3036 CHECK_SYMBOL (feature
, 0);
3037 if (!NILP (Vautoload_queue
))
3038 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3039 tem
= Fmemq (feature
, Vfeatures
);
3041 Vfeatures
= Fcons (feature
, Vfeatures
);
3042 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3046 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3047 "If feature FEATURE is not loaded, load it from FILENAME.\n\
3048 If FEATURE is not a member of the list `features', then the feature\n\
3049 is not loaded; so load the file FILENAME.\n\
3050 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
3051 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
3052 If the optional third argument NOERROR is non-nil,\n\
3053 then return nil if the file is not found.\n\
3054 Normally the return value is FEATURE.")
3055 (feature
, file_name
, noerror
)
3056 Lisp_Object feature
, file_name
, noerror
;
3058 register Lisp_Object tem
;
3059 CHECK_SYMBOL (feature
, 0);
3060 tem
= Fmemq (feature
, Vfeatures
);
3062 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3066 int count
= specpdl_ptr
- specpdl
;
3068 /* Value saved here is to be restored into Vautoload_queue */
3069 record_unwind_protect (un_autoload
, Vautoload_queue
);
3070 Vautoload_queue
= Qt
;
3072 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
3073 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
3074 /* If load failed entirely, return nil. */
3076 return unbind_to (count
, Qnil
);
3078 tem
= Fmemq (feature
, Vfeatures
);
3080 error ("Required feature %s was not provided",
3081 XSYMBOL (feature
)->name
->data
);
3083 /* Once loading finishes, don't undo it. */
3084 Vautoload_queue
= Qt
;
3085 feature
= unbind_to (count
, feature
);
3090 /* Primitives for work of the "widget" library.
3091 In an ideal world, this section would not have been necessary.
3092 However, lisp function calls being as slow as they are, it turns
3093 out that some functions in the widget library (wid-edit.el) are the
3094 bottleneck of Widget operation. Here is their translation to C,
3095 for the sole reason of efficiency. */
3097 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3098 "Return non-nil if PLIST has the property PROP.\n\
3099 PLIST is a property list, which is a list of the form\n\
3100 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
3101 Unlike `plist-get', this allows you to distinguish between a missing\n\
3102 property and a property with the value nil.\n\
3103 The value is actually the tail of PLIST whose car is PROP.")
3105 Lisp_Object plist
, prop
;
3107 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3110 plist
= XCDR (plist
);
3111 plist
= CDR (plist
);
3116 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3117 "In WIDGET, set PROPERTY to VALUE.\n\
3118 The value can later be retrieved with `widget-get'.")
3119 (widget
, property
, value
)
3120 Lisp_Object widget
, property
, value
;
3122 CHECK_CONS (widget
, 1);
3123 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
3127 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3128 "In WIDGET, get the value of PROPERTY.\n\
3129 The value could either be specified when the widget was created, or\n\
3130 later with `widget-put'.")
3132 Lisp_Object widget
, property
;
3140 CHECK_CONS (widget
, 1);
3141 tmp
= Fplist_member (XCDR (widget
), property
);
3147 tmp
= XCAR (widget
);
3150 widget
= Fget (tmp
, Qwidget_type
);
3154 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3155 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
3156 ARGS are passed as extra arguments to the function.")
3161 /* This function can GC. */
3162 Lisp_Object newargs
[3];
3163 struct gcpro gcpro1
, gcpro2
;
3166 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3167 newargs
[1] = args
[0];
3168 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3169 GCPRO2 (newargs
[0], newargs
[2]);
3170 result
= Fapply (3, newargs
);
3175 /* base64 encode/decode functions.
3176 Based on code from GNU recode. */
3178 #define MIME_LINE_LENGTH 76
3180 #define IS_ASCII(Character) \
3182 #define IS_BASE64(Character) \
3183 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3184 #define IS_BASE64_IGNORABLE(Character) \
3185 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3186 || (Character) == '\f' || (Character) == '\r')
3188 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3189 character or return retval if there are no characters left to
3191 #define READ_QUADRUPLET_BYTE(retval) \
3198 while (IS_BASE64_IGNORABLE (c))
3200 /* Don't use alloca for regions larger than this, lest we overflow
3202 #define MAX_ALLOCA 16*1024
3204 /* Table of characters coding the 64 values. */
3205 static char base64_value_to_char
[64] =
3207 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3208 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3209 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3210 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3211 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3212 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3213 '8', '9', '+', '/' /* 60-63 */
3216 /* Table of base64 values for first 128 characters. */
3217 static short base64_char_to_value
[128] =
3219 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3220 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3221 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3222 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3223 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3224 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3225 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3226 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3227 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3228 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3229 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3230 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3231 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3234 /* The following diagram shows the logical steps by which three octets
3235 get transformed into four base64 characters.
3237 .--------. .--------. .--------.
3238 |aaaaaabb| |bbbbcccc| |ccdddddd|
3239 `--------' `--------' `--------'
3241 .--------+--------+--------+--------.
3242 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3243 `--------+--------+--------+--------'
3245 .--------+--------+--------+--------.
3246 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3247 `--------+--------+--------+--------'
3249 The octets are divided into 6 bit chunks, which are then encoded into
3250 base64 characters. */
3253 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3254 static int base64_decode_1
P_ ((const char *, char *, int));
3256 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3258 "Base64-encode the region between BEG and END.\n\
3259 Return the length of the encoded text.\n\
3260 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3261 into shorter lines.")
3262 (beg
, end
, no_line_break
)
3263 Lisp_Object beg
, end
, no_line_break
;
3266 int allength
, length
;
3267 int ibeg
, iend
, encoded_length
;
3270 validate_region (&beg
, &end
);
3272 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3273 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3274 move_gap_both (XFASTINT (beg
), ibeg
);
3276 /* We need to allocate enough room for encoding the text.
3277 We need 33 1/3% more space, plus a newline every 76
3278 characters, and then we round up. */
3279 length
= iend
- ibeg
;
3280 allength
= length
+ length
/3 + 1;
3281 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3283 if (allength
<= MAX_ALLOCA
)
3284 encoded
= (char *) alloca (allength
);
3286 encoded
= (char *) xmalloc (allength
);
3287 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3288 NILP (no_line_break
),
3289 !NILP (current_buffer
->enable_multibyte_characters
));
3290 if (encoded_length
> allength
)
3293 if (encoded_length
< 0)
3295 /* The encoding wasn't possible. */
3296 if (length
> MAX_ALLOCA
)
3298 error ("Base64 encoding failed");
3301 /* Now we have encoded the region, so we insert the new contents
3302 and delete the old. (Insert first in order to preserve markers.) */
3303 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3304 insert (encoded
, encoded_length
);
3305 if (allength
> MAX_ALLOCA
)
3307 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3309 /* If point was outside of the region, restore it exactly; else just
3310 move to the beginning of the region. */
3311 if (old_pos
>= XFASTINT (end
))
3312 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3313 else if (old_pos
> XFASTINT (beg
))
3314 old_pos
= XFASTINT (beg
);
3317 /* We return the length of the encoded text. */
3318 return make_number (encoded_length
);
3321 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3323 "Base64-encode STRING and return the result.\n\
3324 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3325 into shorter lines.")
3326 (string
, no_line_break
)
3327 Lisp_Object string
, no_line_break
;
3329 int allength
, length
, encoded_length
;
3331 Lisp_Object encoded_string
;
3333 CHECK_STRING (string
, 1);
3335 /* We need to allocate enough room for encoding the text.
3336 We need 33 1/3% more space, plus a newline every 76
3337 characters, and then we round up. */
3338 length
= STRING_BYTES (XSTRING (string
));
3339 allength
= length
+ length
/3 + 1;
3340 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3342 /* We need to allocate enough room for decoding the text. */
3343 if (allength
<= MAX_ALLOCA
)
3344 encoded
= (char *) alloca (allength
);
3346 encoded
= (char *) xmalloc (allength
);
3348 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3349 encoded
, length
, NILP (no_line_break
),
3350 STRING_MULTIBYTE (string
));
3351 if (encoded_length
> allength
)
3354 if (encoded_length
< 0)
3356 /* The encoding wasn't possible. */
3357 if (length
> MAX_ALLOCA
)
3359 error ("Base64 encoding failed");
3362 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3363 if (allength
> MAX_ALLOCA
)
3366 return encoded_string
;
3370 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3377 int counter
= 0, i
= 0;
3387 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3388 if (!SINGLE_BYTE_CHAR_P (c
))
3395 /* Wrap line every 76 characters. */
3399 if (counter
< MIME_LINE_LENGTH
/ 4)
3408 /* Process first byte of a triplet. */
3410 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3411 value
= (0x03 & c
) << 4;
3413 /* Process second byte of a triplet. */
3417 *e
++ = base64_value_to_char
[value
];
3425 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3431 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3432 value
= (0x0f & c
) << 2;
3434 /* Process third byte of a triplet. */
3438 *e
++ = base64_value_to_char
[value
];
3445 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3451 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3452 *e
++ = base64_value_to_char
[0x3f & c
];
3459 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3461 "Base64-decode the region between BEG and END.\n\
3462 Return the length of the decoded text.\n\
3463 If the region can't be decoded, signal an error and don't modify the buffer.")
3465 Lisp_Object beg
, end
;
3467 int ibeg
, iend
, length
;
3473 validate_region (&beg
, &end
);
3475 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3476 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3478 length
= iend
- ibeg
;
3479 /* We need to allocate enough room for decoding the text. */
3480 if (length
<= MAX_ALLOCA
)
3481 decoded
= (char *) alloca (length
);
3483 decoded
= (char *) xmalloc (length
);
3485 move_gap_both (XFASTINT (beg
), ibeg
);
3486 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3487 if (decoded_length
> length
)
3490 if (decoded_length
< 0)
3492 /* The decoding wasn't possible. */
3493 if (length
> MAX_ALLOCA
)
3495 error ("Base64 decoding failed");
3498 inserted_chars
= decoded_length
;
3499 if (!NILP (current_buffer
->enable_multibyte_characters
))
3500 decoded_length
= str_to_multibyte (decoded
, length
, decoded_length
);
3502 /* Now we have decoded the region, so we insert the new contents
3503 and delete the old. (Insert first in order to preserve markers.) */
3504 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3505 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3506 if (length
> MAX_ALLOCA
)
3508 /* Delete the original text. */
3509 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3510 iend
+ decoded_length
, 1);
3512 /* If point was outside of the region, restore it exactly; else just
3513 move to the beginning of the region. */
3514 if (old_pos
>= XFASTINT (end
))
3515 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3516 else if (old_pos
> XFASTINT (beg
))
3517 old_pos
= XFASTINT (beg
);
3518 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3520 return make_number (inserted_chars
);
3523 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3525 "Base64-decode STRING and return the result.")
3530 int length
, decoded_length
;
3531 Lisp_Object decoded_string
;
3533 CHECK_STRING (string
, 1);
3535 length
= STRING_BYTES (XSTRING (string
));
3536 /* We need to allocate enough room for decoding the text. */
3537 if (length
<= MAX_ALLOCA
)
3538 decoded
= (char *) alloca (length
);
3540 decoded
= (char *) xmalloc (length
);
3542 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3543 if (decoded_length
> length
)
3545 else if (decoded_length
>= 0)
3546 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3548 decoded_string
= Qnil
;
3550 if (length
> MAX_ALLOCA
)
3552 if (!STRINGP (decoded_string
))
3553 error ("Base64 decoding failed");
3555 return decoded_string
;
3559 base64_decode_1 (from
, to
, length
)
3567 unsigned long value
;
3571 /* Process first byte of a quadruplet. */
3573 READ_QUADRUPLET_BYTE (e
-to
);
3577 value
= base64_char_to_value
[c
] << 18;
3579 /* Process second byte of a quadruplet. */
3581 READ_QUADRUPLET_BYTE (-1);
3585 value
|= base64_char_to_value
[c
] << 12;
3587 *e
++ = (unsigned char) (value
>> 16);
3589 /* Process third byte of a quadruplet. */
3591 READ_QUADRUPLET_BYTE (-1);
3595 READ_QUADRUPLET_BYTE (-1);
3604 value
|= base64_char_to_value
[c
] << 6;
3606 *e
++ = (unsigned char) (0xff & value
>> 8);
3608 /* Process fourth byte of a quadruplet. */
3610 READ_QUADRUPLET_BYTE (-1);
3617 value
|= base64_char_to_value
[c
];
3619 *e
++ = (unsigned char) (0xff & value
);
3625 /***********************************************************************
3627 ***** Hash Tables *****
3629 ***********************************************************************/
3631 /* Implemented by gerd@gnu.org. This hash table implementation was
3632 inspired by CMUCL hash tables. */
3636 1. For small tables, association lists are probably faster than
3637 hash tables because they have lower overhead.
3639 For uses of hash tables where the O(1) behavior of table
3640 operations is not a requirement, it might therefore be a good idea
3641 not to hash. Instead, we could just do a linear search in the
3642 key_and_value vector of the hash table. This could be done
3643 if a `:linear-search t' argument is given to make-hash-table. */
3646 /* Value is the key part of entry IDX in hash table H. */
3648 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3650 /* Value is the value part of entry IDX in hash table H. */
3652 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3654 /* Value is the index of the next entry following the one at IDX
3657 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3659 /* Value is the hash code computed for entry IDX in hash table H. */
3661 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3663 /* Value is the index of the element in hash table H that is the
3664 start of the collision list at index IDX in the index vector of H. */
3666 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3668 /* Value is the size of hash table H. */
3670 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3672 /* The list of all weak hash tables. Don't staticpro this one. */
3674 Lisp_Object Vweak_hash_tables
;
3676 /* Various symbols. */
3678 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3679 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3680 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3682 /* Function prototypes. */
3684 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3685 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3686 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3687 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3688 Lisp_Object
, unsigned));
3689 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3690 Lisp_Object
, unsigned));
3691 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3692 unsigned, Lisp_Object
, unsigned));
3693 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3694 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3695 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3696 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3698 static unsigned sxhash_string
P_ ((unsigned char *, int));
3699 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3700 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3701 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3702 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3706 /***********************************************************************
3708 ***********************************************************************/
3710 /* If OBJ is a Lisp hash table, return a pointer to its struct
3711 Lisp_Hash_Table. Otherwise, signal an error. */
3713 static struct Lisp_Hash_Table
*
3714 check_hash_table (obj
)
3717 CHECK_HASH_TABLE (obj
, 0);
3718 return XHASH_TABLE (obj
);
3722 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3726 next_almost_prime (n
)
3739 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3740 which USED[I] is non-zero. If found at index I in ARGS, set
3741 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3742 -1. This function is used to extract a keyword/argument pair from
3743 a DEFUN parameter list. */
3746 get_key_arg (key
, nargs
, args
, used
)
3754 for (i
= 0; i
< nargs
- 1; ++i
)
3755 if (!used
[i
] && EQ (args
[i
], key
))
3770 /* Return a Lisp vector which has the same contents as VEC but has
3771 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3772 vector that are not copied from VEC are set to INIT. */
3775 larger_vector (vec
, new_size
, init
)
3780 struct Lisp_Vector
*v
;
3783 xassert (VECTORP (vec
));
3784 old_size
= XVECTOR (vec
)->size
;
3785 xassert (new_size
>= old_size
);
3787 v
= allocate_vectorlike (new_size
);
3789 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3790 old_size
* sizeof *v
->contents
);
3791 for (i
= old_size
; i
< new_size
; ++i
)
3792 v
->contents
[i
] = init
;
3793 XSETVECTOR (vec
, v
);
3798 /***********************************************************************
3800 ***********************************************************************/
3802 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3803 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3804 KEY2 are the same. */
3807 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3808 struct Lisp_Hash_Table
*h
;
3809 Lisp_Object key1
, key2
;
3810 unsigned hash1
, hash2
;
3812 return (FLOATP (key1
)
3814 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3818 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3819 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3820 KEY2 are the same. */
3823 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3824 struct Lisp_Hash_Table
*h
;
3825 Lisp_Object key1
, key2
;
3826 unsigned hash1
, hash2
;
3828 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3832 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3833 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3834 if KEY1 and KEY2 are the same. */
3837 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3838 struct Lisp_Hash_Table
*h
;
3839 Lisp_Object key1
, key2
;
3840 unsigned hash1
, hash2
;
3844 Lisp_Object args
[3];
3846 args
[0] = h
->user_cmp_function
;
3849 return !NILP (Ffuncall (3, args
));
3856 /* Value is a hash code for KEY for use in hash table H which uses
3857 `eq' to compare keys. The hash code returned is guaranteed to fit
3858 in a Lisp integer. */
3862 struct Lisp_Hash_Table
*h
;
3865 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3866 xassert ((hash
& ~VALMASK
) == 0);
3871 /* Value is a hash code for KEY for use in hash table H which uses
3872 `eql' to compare keys. The hash code returned is guaranteed to fit
3873 in a Lisp integer. */
3877 struct Lisp_Hash_Table
*h
;
3882 hash
= sxhash (key
, 0);
3884 hash
= XUINT (key
) ^ XGCTYPE (key
);
3885 xassert ((hash
& ~VALMASK
) == 0);
3890 /* Value is a hash code for KEY for use in hash table H which uses
3891 `equal' to compare keys. The hash code returned is guaranteed to fit
3892 in a Lisp integer. */
3895 hashfn_equal (h
, key
)
3896 struct Lisp_Hash_Table
*h
;
3899 unsigned hash
= sxhash (key
, 0);
3900 xassert ((hash
& ~VALMASK
) == 0);
3905 /* Value is a hash code for KEY for use in hash table H which uses as
3906 user-defined function to compare keys. The hash code returned is
3907 guaranteed to fit in a Lisp integer. */
3910 hashfn_user_defined (h
, key
)
3911 struct Lisp_Hash_Table
*h
;
3914 Lisp_Object args
[2], hash
;
3916 args
[0] = h
->user_hash_function
;
3918 hash
= Ffuncall (2, args
);
3919 if (!INTEGERP (hash
))
3921 list2 (build_string ("Invalid hash code returned from \
3922 user-supplied hash function"),
3924 return XUINT (hash
);
3928 /* Create and initialize a new hash table.
3930 TEST specifies the test the hash table will use to compare keys.
3931 It must be either one of the predefined tests `eq', `eql' or
3932 `equal' or a symbol denoting a user-defined test named TEST with
3933 test and hash functions USER_TEST and USER_HASH.
3935 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3937 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3938 new size when it becomes full is computed by adding REHASH_SIZE to
3939 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3940 table's new size is computed by multiplying its old size with
3943 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3944 be resized when the ratio of (number of entries in the table) /
3945 (table size) is >= REHASH_THRESHOLD.
3947 WEAK specifies the weakness of the table. If non-nil, it must be
3948 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3951 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3952 user_test
, user_hash
)
3953 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3954 Lisp_Object user_test
, user_hash
;
3956 struct Lisp_Hash_Table
*h
;
3957 struct Lisp_Vector
*v
;
3959 int index_size
, i
, len
, sz
;
3961 /* Preconditions. */
3962 xassert (SYMBOLP (test
));
3963 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3964 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3965 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3966 xassert (FLOATP (rehash_threshold
)
3967 && XFLOATINT (rehash_threshold
) > 0
3968 && XFLOATINT (rehash_threshold
) <= 1.0);
3970 if (XFASTINT (size
) == 0)
3971 size
= make_number (1);
3973 /* Allocate a vector, and initialize it. */
3974 len
= VECSIZE (struct Lisp_Hash_Table
);
3975 v
= allocate_vectorlike (len
);
3977 for (i
= 0; i
< len
; ++i
)
3978 v
->contents
[i
] = Qnil
;
3980 /* Initialize hash table slots. */
3981 sz
= XFASTINT (size
);
3982 h
= (struct Lisp_Hash_Table
*) v
;
3985 if (EQ (test
, Qeql
))
3987 h
->cmpfn
= cmpfn_eql
;
3988 h
->hashfn
= hashfn_eql
;
3990 else if (EQ (test
, Qeq
))
3993 h
->hashfn
= hashfn_eq
;
3995 else if (EQ (test
, Qequal
))
3997 h
->cmpfn
= cmpfn_equal
;
3998 h
->hashfn
= hashfn_equal
;
4002 h
->user_cmp_function
= user_test
;
4003 h
->user_hash_function
= user_hash
;
4004 h
->cmpfn
= cmpfn_user_defined
;
4005 h
->hashfn
= hashfn_user_defined
;
4009 h
->rehash_threshold
= rehash_threshold
;
4010 h
->rehash_size
= rehash_size
;
4011 h
->count
= make_number (0);
4012 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4013 h
->hash
= Fmake_vector (size
, Qnil
);
4014 h
->next
= Fmake_vector (size
, Qnil
);
4015 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4016 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4017 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4019 /* Set up the free list. */
4020 for (i
= 0; i
< sz
- 1; ++i
)
4021 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4022 h
->next_free
= make_number (0);
4024 XSET_HASH_TABLE (table
, h
);
4025 xassert (HASH_TABLE_P (table
));
4026 xassert (XHASH_TABLE (table
) == h
);
4028 /* Maybe add this hash table to the list of all weak hash tables. */
4030 h
->next_weak
= Qnil
;
4033 h
->next_weak
= Vweak_hash_tables
;
4034 Vweak_hash_tables
= table
;
4041 /* Return a copy of hash table H1. Keys and values are not copied,
4042 only the table itself is. */
4045 copy_hash_table (h1
)
4046 struct Lisp_Hash_Table
*h1
;
4049 struct Lisp_Hash_Table
*h2
;
4050 struct Lisp_Vector
*v
, *next
;
4053 len
= VECSIZE (struct Lisp_Hash_Table
);
4054 v
= allocate_vectorlike (len
);
4055 h2
= (struct Lisp_Hash_Table
*) v
;
4056 next
= h2
->vec_next
;
4057 bcopy (h1
, h2
, sizeof *h2
);
4058 h2
->vec_next
= next
;
4059 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4060 h2
->hash
= Fcopy_sequence (h1
->hash
);
4061 h2
->next
= Fcopy_sequence (h1
->next
);
4062 h2
->index
= Fcopy_sequence (h1
->index
);
4063 XSET_HASH_TABLE (table
, h2
);
4065 /* Maybe add this hash table to the list of all weak hash tables. */
4066 if (!NILP (h2
->weak
))
4068 h2
->next_weak
= Vweak_hash_tables
;
4069 Vweak_hash_tables
= table
;
4076 /* Resize hash table H if it's too full. If H cannot be resized
4077 because it's already too large, throw an error. */
4080 maybe_resize_hash_table (h
)
4081 struct Lisp_Hash_Table
*h
;
4083 if (NILP (h
->next_free
))
4085 int old_size
= HASH_TABLE_SIZE (h
);
4086 int i
, new_size
, index_size
;
4088 if (INTEGERP (h
->rehash_size
))
4089 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4091 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4092 new_size
= max (old_size
+ 1, new_size
);
4093 index_size
= next_almost_prime ((int)
4095 / XFLOATINT (h
->rehash_threshold
)));
4096 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4097 error ("Hash table too large to resize");
4099 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4100 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4101 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4102 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4104 /* Update the free list. Do it so that new entries are added at
4105 the end of the free list. This makes some operations like
4107 for (i
= old_size
; i
< new_size
- 1; ++i
)
4108 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4110 if (!NILP (h
->next_free
))
4112 Lisp_Object last
, next
;
4114 last
= h
->next_free
;
4115 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4119 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4122 XSETFASTINT (h
->next_free
, old_size
);
4125 for (i
= 0; i
< old_size
; ++i
)
4126 if (!NILP (HASH_HASH (h
, i
)))
4128 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4129 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4130 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4131 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4137 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4138 the hash code of KEY. Value is the index of the entry in H
4139 matching KEY, or -1 if not found. */
4142 hash_lookup (h
, key
, hash
)
4143 struct Lisp_Hash_Table
*h
;
4148 int start_of_bucket
;
4151 hash_code
= h
->hashfn (h
, key
);
4155 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4156 idx
= HASH_INDEX (h
, start_of_bucket
);
4158 /* We need not gcpro idx since it's either an integer or nil. */
4161 int i
= XFASTINT (idx
);
4162 if (EQ (key
, HASH_KEY (h
, i
))
4164 && h
->cmpfn (h
, key
, hash_code
,
4165 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4167 idx
= HASH_NEXT (h
, i
);
4170 return NILP (idx
) ? -1 : XFASTINT (idx
);
4174 /* Put an entry into hash table H that associates KEY with VALUE.
4175 HASH is a previously computed hash code of KEY.
4176 Value is the index of the entry in H matching KEY. */
4179 hash_put (h
, key
, value
, hash
)
4180 struct Lisp_Hash_Table
*h
;
4181 Lisp_Object key
, value
;
4184 int start_of_bucket
, i
;
4186 xassert ((hash
& ~VALMASK
) == 0);
4188 /* Increment count after resizing because resizing may fail. */
4189 maybe_resize_hash_table (h
);
4190 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4192 /* Store key/value in the key_and_value vector. */
4193 i
= XFASTINT (h
->next_free
);
4194 h
->next_free
= HASH_NEXT (h
, i
);
4195 HASH_KEY (h
, i
) = key
;
4196 HASH_VALUE (h
, i
) = value
;
4198 /* Remember its hash code. */
4199 HASH_HASH (h
, i
) = make_number (hash
);
4201 /* Add new entry to its collision chain. */
4202 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4203 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4204 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4209 /* Remove the entry matching KEY from hash table H, if there is one. */
4212 hash_remove (h
, key
)
4213 struct Lisp_Hash_Table
*h
;
4217 int start_of_bucket
;
4218 Lisp_Object idx
, prev
;
4220 hash_code
= h
->hashfn (h
, key
);
4221 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4222 idx
= HASH_INDEX (h
, start_of_bucket
);
4225 /* We need not gcpro idx, prev since they're either integers or nil. */
4228 int i
= XFASTINT (idx
);
4230 if (EQ (key
, HASH_KEY (h
, i
))
4232 && h
->cmpfn (h
, key
, hash_code
,
4233 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4235 /* Take entry out of collision chain. */
4237 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4239 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4241 /* Clear slots in key_and_value and add the slots to
4243 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4244 HASH_NEXT (h
, i
) = h
->next_free
;
4245 h
->next_free
= make_number (i
);
4246 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4247 xassert (XINT (h
->count
) >= 0);
4253 idx
= HASH_NEXT (h
, i
);
4259 /* Clear hash table H. */
4263 struct Lisp_Hash_Table
*h
;
4265 if (XFASTINT (h
->count
) > 0)
4267 int i
, size
= HASH_TABLE_SIZE (h
);
4269 for (i
= 0; i
< size
; ++i
)
4271 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4272 HASH_KEY (h
, i
) = Qnil
;
4273 HASH_VALUE (h
, i
) = Qnil
;
4274 HASH_HASH (h
, i
) = Qnil
;
4277 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4278 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4280 h
->next_free
= make_number (0);
4281 h
->count
= make_number (0);
4287 /************************************************************************
4289 ************************************************************************/
4291 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4292 entries from the table that don't survive the current GC.
4293 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4294 non-zero if anything was marked. */
4297 sweep_weak_table (h
, remove_entries_p
)
4298 struct Lisp_Hash_Table
*h
;
4299 int remove_entries_p
;
4301 int bucket
, n
, marked
;
4303 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4306 for (bucket
= 0; bucket
< n
; ++bucket
)
4308 Lisp_Object idx
, prev
;
4310 /* Follow collision chain, removing entries that
4311 don't survive this garbage collection. */
4312 idx
= HASH_INDEX (h
, bucket
);
4314 while (!GC_NILP (idx
))
4317 int i
= XFASTINT (idx
);
4319 int key_known_to_survive_p
, value_known_to_survive_p
;
4321 key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4322 value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4324 if (EQ (h
->weak
, Qkey
))
4325 remove_p
= !key_known_to_survive_p
;
4326 else if (EQ (h
->weak
, Qvalue
))
4327 remove_p
= !value_known_to_survive_p
;
4328 else if (EQ (h
->weak
, Qkey_or_value
))
4329 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4330 else if (EQ (h
->weak
, Qkey_and_value
))
4331 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4335 next
= HASH_NEXT (h
, i
);
4337 if (remove_entries_p
)
4341 /* Take out of collision chain. */
4343 HASH_INDEX (h
, i
) = next
;
4345 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4347 /* Add to free list. */
4348 HASH_NEXT (h
, i
) = h
->next_free
;
4351 /* Clear key, value, and hash. */
4352 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4353 HASH_HASH (h
, i
) = Qnil
;
4355 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4362 /* Make sure key and value survive. */
4363 if (!key_known_to_survive_p
)
4365 mark_object (&HASH_KEY (h
, i
));
4369 if (!value_known_to_survive_p
)
4371 mark_object (&HASH_VALUE (h
, i
));
4384 /* Remove elements from weak hash tables that don't survive the
4385 current garbage collection. Remove weak tables that don't survive
4386 from Vweak_hash_tables. Called from gc_sweep. */
4389 sweep_weak_hash_tables ()
4391 Lisp_Object table
, used
, next
;
4392 struct Lisp_Hash_Table
*h
;
4395 /* Mark all keys and values that are in use. Keep on marking until
4396 there is no more change. This is necessary for cases like
4397 value-weak table A containing an entry X -> Y, where Y is used in a
4398 key-weak table B, Z -> Y. If B comes after A in the list of weak
4399 tables, X -> Y might be removed from A, although when looking at B
4400 one finds that it shouldn't. */
4404 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4406 h
= XHASH_TABLE (table
);
4407 if (h
->size
& ARRAY_MARK_FLAG
)
4408 marked
|= sweep_weak_table (h
, 0);
4413 /* Remove tables and entries that aren't used. */
4414 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4416 h
= XHASH_TABLE (table
);
4417 next
= h
->next_weak
;
4419 if (h
->size
& ARRAY_MARK_FLAG
)
4421 /* TABLE is marked as used. Sweep its contents. */
4422 if (XFASTINT (h
->count
) > 0)
4423 sweep_weak_table (h
, 1);
4425 /* Add table to the list of used weak hash tables. */
4426 h
->next_weak
= used
;
4431 Vweak_hash_tables
= used
;
4436 /***********************************************************************
4437 Hash Code Computation
4438 ***********************************************************************/
4440 /* Maximum depth up to which to dive into Lisp structures. */
4442 #define SXHASH_MAX_DEPTH 3
4444 /* Maximum length up to which to take list and vector elements into
4447 #define SXHASH_MAX_LEN 7
4449 /* Combine two integers X and Y for hashing. */
4451 #define SXHASH_COMBINE(X, Y) \
4452 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4456 /* Return a hash for string PTR which has length LEN. The hash
4457 code returned is guaranteed to fit in a Lisp integer. */
4460 sxhash_string (ptr
, len
)
4464 unsigned char *p
= ptr
;
4465 unsigned char *end
= p
+ len
;
4474 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4477 return hash
& VALMASK
;
4481 /* Return a hash for list LIST. DEPTH is the current depth in the
4482 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4485 sxhash_list (list
, depth
)
4492 if (depth
< SXHASH_MAX_DEPTH
)
4494 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4495 list
= XCDR (list
), ++i
)
4497 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4498 hash
= SXHASH_COMBINE (hash
, hash2
);
4505 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4506 the Lisp structure. */
4509 sxhash_vector (vec
, depth
)
4513 unsigned hash
= XVECTOR (vec
)->size
;
4516 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4517 for (i
= 0; i
< n
; ++i
)
4519 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4520 hash
= SXHASH_COMBINE (hash
, hash2
);
4527 /* Return a hash for bool-vector VECTOR. */
4530 sxhash_bool_vector (vec
)
4533 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4536 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4537 for (i
= 0; i
< n
; ++i
)
4538 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4544 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4545 structure. Value is an unsigned integer clipped to VALMASK. */
4554 if (depth
> SXHASH_MAX_DEPTH
)
4557 switch (XTYPE (obj
))
4564 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4565 XSYMBOL (obj
)->name
->size
);
4573 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4576 /* This can be everything from a vector to an overlay. */
4577 case Lisp_Vectorlike
:
4579 /* According to the CL HyperSpec, two arrays are equal only if
4580 they are `eq', except for strings and bit-vectors. In
4581 Emacs, this works differently. We have to compare element
4583 hash
= sxhash_vector (obj
, depth
);
4584 else if (BOOL_VECTOR_P (obj
))
4585 hash
= sxhash_bool_vector (obj
);
4587 /* Others are `equal' if they are `eq', so let's take their
4593 hash
= sxhash_list (obj
, depth
);
4598 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4599 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4600 for (hash
= 0; p
< e
; ++p
)
4601 hash
= SXHASH_COMBINE (hash
, *p
);
4609 return hash
& VALMASK
;
4614 /***********************************************************************
4616 ***********************************************************************/
4619 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4620 "Compute a hash code for OBJ and return it as integer.")
4624 unsigned hash
= sxhash (obj
, 0);;
4625 return make_number (hash
);
4629 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4630 "Create and return a new hash table.\n\
4631 Arguments are specified as keyword/argument pairs. The following\n\
4632 arguments are defined:\n\
4634 :test TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4635 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4636 User-supplied test and hash functions can be specified via\n\
4637 `define-hash-table-test'.\n\
4639 :size SIZE -- A hint as to how many elements will be put in the table.\n\
4642 :rehash-size REHASH-SIZE - Indicates how to expand the table when\n\
4643 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4644 If it is a float, it must be > 1.0, and the new size is computed by\n\
4645 multiplying the old size with that factor. Default is 1.5.\n\
4647 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4648 Resize the hash table when ratio of the number of entries in the table.\n\
4651 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',\n\
4652 `key-or-value', or `key-and-value'. If WEAK is not nil, the table returned\n\
4653 is a weak table. Key/value pairs are removed from a weak hash table when\n\
4654 there are no non-weak references pointing to their key, value, one of key\n\
4655 or value, or both key and value, depending on WEAK. WEAK t is equivalent\n\
4656 to `key-and-value'. Default value of WEAK is nil.")
4661 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4662 Lisp_Object user_test
, user_hash
;
4666 /* The vector `used' is used to keep track of arguments that
4667 have been consumed. */
4668 used
= (char *) alloca (nargs
* sizeof *used
);
4669 bzero (used
, nargs
* sizeof *used
);
4671 /* See if there's a `:test TEST' among the arguments. */
4672 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4673 test
= i
< 0 ? Qeql
: args
[i
];
4674 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4676 /* See if it is a user-defined test. */
4679 prop
= Fget (test
, Qhash_table_test
);
4680 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4681 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4683 user_test
= Fnth (make_number (0), prop
);
4684 user_hash
= Fnth (make_number (1), prop
);
4687 user_test
= user_hash
= Qnil
;
4689 /* See if there's a `:size SIZE' argument. */
4690 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4691 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4692 if (!INTEGERP (size
) || XINT (size
) < 0)
4694 list2 (build_string ("Invalid hash table size"),
4697 /* Look for `:rehash-size SIZE'. */
4698 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4699 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4700 if (!NUMBERP (rehash_size
)
4701 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4702 || XFLOATINT (rehash_size
) <= 1.0)
4704 list2 (build_string ("Invalid hash table rehash size"),
4707 /* Look for `:rehash-threshold THRESHOLD'. */
4708 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4709 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4710 if (!FLOATP (rehash_threshold
)
4711 || XFLOATINT (rehash_threshold
) <= 0.0
4712 || XFLOATINT (rehash_threshold
) > 1.0)
4714 list2 (build_string ("Invalid hash table rehash threshold"),
4717 /* Look for `:weakness WEAK'. */
4718 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4719 weak
= i
< 0 ? Qnil
: args
[i
];
4721 weak
= Qkey_and_value
;
4724 && !EQ (weak
, Qvalue
)
4725 && !EQ (weak
, Qkey_or_value
)
4726 && !EQ (weak
, Qkey_and_value
))
4727 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4730 /* Now, all args should have been used up, or there's a problem. */
4731 for (i
= 0; i
< nargs
; ++i
)
4734 list2 (build_string ("Invalid argument list"), args
[i
]));
4736 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4737 user_test
, user_hash
);
4741 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4742 "Return a copy of hash table TABLE.")
4746 return copy_hash_table (check_hash_table (table
));
4750 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4751 "Create a new hash table.\n\
4752 Optional first argument TEST specifies how to compare keys in\n\
4753 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4754 is `eql'. New tests can be defined with `define-hash-table-test'.")
4758 Lisp_Object args
[2];
4760 args
[1] = NILP (test
) ? Qeql
: test
;
4761 return Fmake_hash_table (2, args
);
4765 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4766 "Return the number of elements in TABLE.")
4770 return check_hash_table (table
)->count
;
4774 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4775 Shash_table_rehash_size
, 1, 1, 0,
4776 "Return the current rehash size of TABLE.")
4780 return check_hash_table (table
)->rehash_size
;
4784 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4785 Shash_table_rehash_threshold
, 1, 1, 0,
4786 "Return the current rehash threshold of TABLE.")
4790 return check_hash_table (table
)->rehash_threshold
;
4794 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4795 "Return the size of TABLE.\n\
4796 The size can be used as an argument to `make-hash-table' to create\n\
4797 a hash table than can hold as many elements of TABLE holds\n\
4798 without need for resizing.")
4802 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4803 return make_number (HASH_TABLE_SIZE (h
));
4807 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4808 "Return the test TABLE uses.")
4812 return check_hash_table (table
)->test
;
4816 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4818 "Return the weakness of TABLE.")
4822 return check_hash_table (table
)->weak
;
4826 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4827 "Return t if OBJ is a Lisp hash table object.")
4831 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4835 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4836 "Clear hash table TABLE.")
4840 hash_clear (check_hash_table (table
));
4845 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4846 "Look up KEY in TABLE and return its associated value.\n\
4847 If KEY is not found, return DFLT which defaults to nil.")
4849 Lisp_Object key
, table
, dflt
;
4851 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4852 int i
= hash_lookup (h
, key
, NULL
);
4853 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4857 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4858 "Associate KEY with VALUE in hash table TABLE.\n\
4859 If KEY is already present in table, replace its current value with\n\
4862 Lisp_Object key
, value
, table
;
4864 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4868 i
= hash_lookup (h
, key
, &hash
);
4870 HASH_VALUE (h
, i
) = value
;
4872 hash_put (h
, key
, value
, hash
);
4878 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4879 "Remove KEY from TABLE.")
4881 Lisp_Object key
, table
;
4883 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4884 hash_remove (h
, key
);
4889 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4890 "Call FUNCTION for all entries in hash table TABLE.\n\
4891 FUNCTION is called with 2 arguments KEY and VALUE.")
4893 Lisp_Object function
, table
;
4895 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4896 Lisp_Object args
[3];
4899 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4900 if (!NILP (HASH_HASH (h
, i
)))
4903 args
[1] = HASH_KEY (h
, i
);
4904 args
[2] = HASH_VALUE (h
, i
);
4912 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4913 Sdefine_hash_table_test
, 3, 3, 0,
4914 "Define a new hash table test with name NAME, a symbol.\n\
4915 In hash tables create with NAME specified as test, use TEST to compare\n\
4916 keys, and HASH for computing hash codes of keys.\n\
4918 TEST must be a function taking two arguments and returning non-nil\n\
4919 if both arguments are the same. HASH must be a function taking\n\
4920 one argument and return an integer that is the hash code of the\n\
4921 argument. Hash code computation should use the whole value range of\n\
4922 integers, including negative integers.")
4924 Lisp_Object name
, test
, hash
;
4926 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4935 /* Hash table stuff. */
4936 Qhash_table_p
= intern ("hash-table-p");
4937 staticpro (&Qhash_table_p
);
4938 Qeq
= intern ("eq");
4940 Qeql
= intern ("eql");
4942 Qequal
= intern ("equal");
4943 staticpro (&Qequal
);
4944 QCtest
= intern (":test");
4945 staticpro (&QCtest
);
4946 QCsize
= intern (":size");
4947 staticpro (&QCsize
);
4948 QCrehash_size
= intern (":rehash-size");
4949 staticpro (&QCrehash_size
);
4950 QCrehash_threshold
= intern (":rehash-threshold");
4951 staticpro (&QCrehash_threshold
);
4952 QCweakness
= intern (":weakness");
4953 staticpro (&QCweakness
);
4954 Qkey
= intern ("key");
4956 Qvalue
= intern ("value");
4957 staticpro (&Qvalue
);
4958 Qhash_table_test
= intern ("hash-table-test");
4959 staticpro (&Qhash_table_test
);
4960 Qkey_or_value
= intern ("key-or-value");
4961 staticpro (&Qkey_or_value
);
4962 Qkey_and_value
= intern ("key-and-value");
4963 staticpro (&Qkey_and_value
);
4966 defsubr (&Smake_hash_table
);
4967 defsubr (&Scopy_hash_table
);
4968 defsubr (&Smakehash
);
4969 defsubr (&Shash_table_count
);
4970 defsubr (&Shash_table_rehash_size
);
4971 defsubr (&Shash_table_rehash_threshold
);
4972 defsubr (&Shash_table_size
);
4973 defsubr (&Shash_table_test
);
4974 defsubr (&Shash_table_weakness
);
4975 defsubr (&Shash_table_p
);
4976 defsubr (&Sclrhash
);
4977 defsubr (&Sgethash
);
4978 defsubr (&Sputhash
);
4979 defsubr (&Sremhash
);
4980 defsubr (&Smaphash
);
4981 defsubr (&Sdefine_hash_table_test
);
4983 Qstring_lessp
= intern ("string-lessp");
4984 staticpro (&Qstring_lessp
);
4985 Qprovide
= intern ("provide");
4986 staticpro (&Qprovide
);
4987 Qrequire
= intern ("require");
4988 staticpro (&Qrequire
);
4989 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4990 staticpro (&Qyes_or_no_p_history
);
4991 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4992 staticpro (&Qcursor_in_echo_area
);
4993 Qwidget_type
= intern ("widget-type");
4994 staticpro (&Qwidget_type
);
4996 staticpro (&string_char_byte_cache_string
);
4997 string_char_byte_cache_string
= Qnil
;
4999 Fset (Qyes_or_no_p_history
, Qnil
);
5001 DEFVAR_LISP ("features", &Vfeatures
,
5002 "A list of symbols which are the features of the executing emacs.\n\
5003 Used by `featurep' and `require', and altered by `provide'.");
5006 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5007 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
5008 This applies to y-or-n and yes-or-no questions asked by commands\n\
5009 invoked by mouse clicks and mouse menu items.");
5012 defsubr (&Sidentity
);
5015 defsubr (&Ssafe_length
);
5016 defsubr (&Sstring_bytes
);
5017 defsubr (&Sstring_equal
);
5018 defsubr (&Scompare_strings
);
5019 defsubr (&Sstring_lessp
);
5022 defsubr (&Svconcat
);
5023 defsubr (&Scopy_sequence
);
5024 defsubr (&Sstring_make_multibyte
);
5025 defsubr (&Sstring_make_unibyte
);
5026 defsubr (&Sstring_as_multibyte
);
5027 defsubr (&Sstring_as_unibyte
);
5028 defsubr (&Scopy_alist
);
5029 defsubr (&Ssubstring
);
5041 defsubr (&Snreverse
);
5042 defsubr (&Sreverse
);
5044 defsubr (&Splist_get
);
5046 defsubr (&Splist_put
);
5049 defsubr (&Sfillarray
);
5050 defsubr (&Schar_table_subtype
);
5051 defsubr (&Schar_table_parent
);
5052 defsubr (&Sset_char_table_parent
);
5053 defsubr (&Schar_table_extra_slot
);
5054 defsubr (&Sset_char_table_extra_slot
);
5055 defsubr (&Schar_table_range
);
5056 defsubr (&Sset_char_table_range
);
5057 defsubr (&Sset_char_table_default
);
5058 defsubr (&Soptimize_char_table
);
5059 defsubr (&Smap_char_table
);
5063 defsubr (&Smapconcat
);
5064 defsubr (&Sy_or_n_p
);
5065 defsubr (&Syes_or_no_p
);
5066 defsubr (&Sload_average
);
5067 defsubr (&Sfeaturep
);
5068 defsubr (&Srequire
);
5069 defsubr (&Sprovide
);
5070 defsubr (&Splist_member
);
5071 defsubr (&Swidget_put
);
5072 defsubr (&Swidget_get
);
5073 defsubr (&Swidget_apply
);
5074 defsubr (&Sbase64_encode_region
);
5075 defsubr (&Sbase64_decode_region
);
5076 defsubr (&Sbase64_encode_string
);
5077 defsubr (&Sbase64_decode_string
);
5084 Vweak_hash_tables
= Qnil
;