1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 #define DOC_STRINGS_IN_COMMENTS
31 /* Note on some machines this defines `vector' as a typedef,
32 so make sure we don't use that name in this file. */
43 #include "intervals.h"
46 #include "blockinput.h"
47 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
52 #define NULL (void *)0
55 /* Nonzero enables use of dialog boxes for questions
56 asked by mouse commands. */
59 extern int minibuffer_auto_raise
;
60 extern Lisp_Object minibuf_window
;
62 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
63 Lisp_Object Qyes_or_no_p_history
;
64 Lisp_Object Qcursor_in_echo_area
;
65 Lisp_Object Qwidget_type
;
67 extern Lisp_Object Qinput_method_function
;
69 static int internal_equal ();
71 extern long get_random ();
72 extern void seed_random ();
78 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
79 /* Return the argument unchanged. */
86 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
87 /* Return a pseudo-random number.
88 All integers representable in Lisp are equally likely.
89 On most systems, this is 28 bits' worth.
90 With positive integer argument N, return random number in interval [0,N).
91 With argument t, set the random number seed from the current time and pid. */
96 Lisp_Object lispy_val
;
97 unsigned long denominator
;
100 seed_random (getpid () + time (NULL
));
101 if (NATNUMP (n
) && XFASTINT (n
) != 0)
103 /* Try to take our random number from the higher bits of VAL,
104 not the lower, since (says Gentzel) the low bits of `random'
105 are less random than the higher ones. We do this by using the
106 quotient rather than the remainder. At the high end of the RNG
107 it's possible to get a quotient larger than n; discarding
108 these values eliminates the bias that would otherwise appear
109 when using a large n. */
110 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
112 val
= get_random () / denominator
;
113 while (val
>= XFASTINT (n
));
117 XSETINT (lispy_val
, val
);
121 /* Random data-structure functions */
123 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
124 /* Return the length of vector, list or string SEQUENCE.
125 A byte-code function object is also allowed.
126 If the string contains multibyte characters, this is not the necessarily
127 the number of bytes in the string; it is the number of characters.
128 To get the number of bytes, use `string-bytes'. */
130 register Lisp_Object sequence
;
132 register Lisp_Object val
;
136 if (STRINGP (sequence
))
137 XSETFASTINT (val
, XSTRING (sequence
)->size
);
138 else if (VECTORP (sequence
))
139 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
140 else if (CHAR_TABLE_P (sequence
))
141 XSETFASTINT (val
, MAX_CHAR
);
142 else if (BOOL_VECTOR_P (sequence
))
143 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
144 else if (COMPILEDP (sequence
))
145 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
146 else if (CONSP (sequence
))
149 while (CONSP (sequence
))
151 sequence
= XCDR (sequence
);
154 if (!CONSP (sequence
))
157 sequence
= XCDR (sequence
);
162 if (!NILP (sequence
))
163 wrong_type_argument (Qlistp
, sequence
);
165 val
= make_number (i
);
167 else if (NILP (sequence
))
168 XSETFASTINT (val
, 0);
171 sequence
= wrong_type_argument (Qsequencep
, sequence
);
177 /* This does not check for quits. That is safe
178 since it must terminate. */
180 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
181 /* Return the length of a list, but avoid error or infinite loop.
182 This function never gets an error. If LIST is not really a list,
183 it returns 0. If LIST is circular, it returns a finite value
184 which is at least the number of distinct elements. */
188 Lisp_Object tail
, halftail
, length
;
191 /* halftail is used to detect circular lists. */
193 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
195 if (EQ (tail
, halftail
) && len
!= 0)
199 halftail
= XCDR (halftail
);
202 XSETINT (length
, len
);
206 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
207 /* Return the number of bytes in STRING.
208 If STRING is a multibyte string, this is greater than the length of STRING. */
212 CHECK_STRING (string
, 1);
213 return make_number (STRING_BYTES (XSTRING (string
)));
216 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
217 /* Return t if two strings have identical contents.
218 Case is significant, but text properties are ignored.
219 Symbols are also allowed; their print names are used instead. */
221 register Lisp_Object s1
, s2
;
224 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
226 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
227 CHECK_STRING (s1
, 0);
228 CHECK_STRING (s2
, 1);
230 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
231 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
232 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
237 DEFUN ("compare-strings", Fcompare_strings
,
238 Scompare_strings
, 6, 7, 0,
239 /* Compare the contents of two strings, converting to multibyte if needed.
240 In string STR1, skip the first START1 characters and stop at END1.
241 In string STR2, skip the first START2 characters and stop at END2.
242 END1 and END2 default to the full lengths of the respective strings.
244 Case is significant in this comparison if IGNORE-CASE is nil.
245 Unibyte strings are converted to multibyte for comparison.
247 The value is t if the strings (or specified portions) match.
248 If string STR1 is less, the value is a negative number N;
249 - 1 - N is the number of characters that match at the beginning.
250 If string STR1 is greater, the value is a positive number N;
251 N - 1 is the number of characters that match at the beginning. */
252 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
))
253 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
255 register int end1_char
, end2_char
;
256 register int i1
, i1_byte
, i2
, i2_byte
;
258 CHECK_STRING (str1
, 0);
259 CHECK_STRING (str2
, 1);
261 start1
= make_number (0);
263 start2
= make_number (0);
264 CHECK_NATNUM (start1
, 2);
265 CHECK_NATNUM (start2
, 3);
267 CHECK_NATNUM (end1
, 4);
269 CHECK_NATNUM (end2
, 4);
274 i1_byte
= string_char_to_byte (str1
, i1
);
275 i2_byte
= string_char_to_byte (str2
, i2
);
277 end1_char
= XSTRING (str1
)->size
;
278 if (! NILP (end1
) && end1_char
> XINT (end1
))
279 end1_char
= XINT (end1
);
281 end2_char
= XSTRING (str2
)->size
;
282 if (! NILP (end2
) && end2_char
> XINT (end2
))
283 end2_char
= XINT (end2
);
285 while (i1
< end1_char
&& i2
< end2_char
)
287 /* When we find a mismatch, we must compare the
288 characters, not just the bytes. */
291 if (STRING_MULTIBYTE (str1
))
292 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
295 c1
= XSTRING (str1
)->data
[i1
++];
296 c1
= unibyte_char_to_multibyte (c1
);
299 if (STRING_MULTIBYTE (str2
))
300 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
303 c2
= XSTRING (str2
)->data
[i2
++];
304 c2
= unibyte_char_to_multibyte (c2
);
310 if (! NILP (ignore_case
))
314 tem
= Fupcase (make_number (c1
));
316 tem
= Fupcase (make_number (c2
));
323 /* Note that I1 has already been incremented
324 past the character that we are comparing;
325 hence we don't add or subtract 1 here. */
327 return make_number (- i1
+ XINT (start1
));
329 return make_number (i1
- XINT (start1
));
333 return make_number (i1
- XINT (start1
) + 1);
335 return make_number (- i1
+ XINT (start1
) - 1);
340 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
341 /* Return t if first arg string is less than second in lexicographic order.
343 Symbols are also allowed; their print names are used instead. */
345 register Lisp_Object s1
, s2
;
348 register int i1
, i1_byte
, i2
, i2_byte
;
351 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
353 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
354 CHECK_STRING (s1
, 0);
355 CHECK_STRING (s2
, 1);
357 i1
= i1_byte
= i2
= i2_byte
= 0;
359 end
= XSTRING (s1
)->size
;
360 if (end
> XSTRING (s2
)->size
)
361 end
= XSTRING (s2
)->size
;
365 /* When we find a mismatch, we must compare the
366 characters, not just the bytes. */
369 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
370 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
373 return c1
< c2
? Qt
: Qnil
;
375 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
378 static Lisp_Object
concat ();
389 return concat (2, args
, Lisp_String
, 0);
391 return concat (2, &s1
, Lisp_String
, 0);
392 #endif /* NO_ARG_ARRAY */
398 Lisp_Object s1
, s2
, s3
;
405 return concat (3, args
, Lisp_String
, 0);
407 return concat (3, &s1
, Lisp_String
, 0);
408 #endif /* NO_ARG_ARRAY */
411 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
412 /* Concatenate all the arguments and make the result a list.
413 The result is a list whose elements are the elements of all the arguments.
414 Each argument may be a list, vector or string.
415 The last argument is not copied, just used as the tail of the new list. */
420 return concat (nargs
, args
, Lisp_Cons
, 1);
423 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
424 /* Concatenate all the arguments and make the result a string.
425 The result is a string whose elements are the elements of all the arguments.
426 Each argument may be a string or a list or vector of characters (integers). */
431 return concat (nargs
, args
, Lisp_String
, 0);
434 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
435 /* Concatenate all the arguments and make the result a vector.
436 The result is a vector whose elements are the elements of all the arguments.
437 Each argument may be a list, vector or string. */
442 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
445 /* Retrun a copy of a sub char table ARG. The elements except for a
446 nested sub char table are not copied. */
448 copy_sub_char_table (arg
)
451 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
454 /* Copy all the contents. */
455 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
456 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
457 /* Recursively copy any sub char-tables in the ordinary slots. */
458 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
459 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
460 XCHAR_TABLE (copy
)->contents
[i
]
461 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
467 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
468 /* Return a copy of a list, vector or string.
469 The elements of a list or vector are not copied; they are shared
470 with the original. */
474 if (NILP (arg
)) return arg
;
476 if (CHAR_TABLE_P (arg
))
481 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
482 /* Copy all the slots, including the extra ones. */
483 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
484 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
485 * sizeof (Lisp_Object
)));
487 /* Recursively copy any sub char tables in the ordinary slots
488 for multibyte characters. */
489 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
490 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
491 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
492 XCHAR_TABLE (copy
)->contents
[i
]
493 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
498 if (BOOL_VECTOR_P (arg
))
502 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
504 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
505 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
510 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
511 arg
= wrong_type_argument (Qsequencep
, arg
);
512 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
515 /* In string STR of length LEN, see if bytes before STR[I] combine
516 with bytes after STR[I] to form a single character. If so, return
517 the number of bytes after STR[I] which combine in this way.
518 Otherwize, return 0. */
521 count_combining (str
, len
, i
)
525 int j
= i
- 1, bytes
;
527 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
529 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
530 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
532 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
533 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
536 /* This structure holds information of an argument of `concat' that is
537 a string and has text properties to be copied. */
540 int argnum
; /* refer to ARGS (arguments of `concat') */
541 int from
; /* refer to ARGS[argnum] (argument string) */
542 int to
; /* refer to VAL (the target string) */
546 concat (nargs
, args
, target_type
, last_special
)
549 enum Lisp_Type target_type
;
553 register Lisp_Object tail
;
554 register Lisp_Object
this;
556 int toindex_byte
= 0;
557 register int result_len
;
558 register int result_len_byte
;
560 Lisp_Object last_tail
;
563 /* When we make a multibyte string, we can't copy text properties
564 while concatinating each string because the length of resulting
565 string can't be decided until we finish the whole concatination.
566 So, we record strings that have text properties to be copied
567 here, and copy the text properties after the concatination. */
568 struct textprop_rec
*textprops
= NULL
;
569 /* Number of elments in textprops. */
570 int num_textprops
= 0;
574 /* In append, the last arg isn't treated like the others */
575 if (last_special
&& nargs
> 0)
578 last_tail
= args
[nargs
];
583 /* Canonicalize each argument. */
584 for (argnum
= 0; argnum
< nargs
; argnum
++)
587 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
588 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
590 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
594 /* Compute total length in chars of arguments in RESULT_LEN.
595 If desired output is a string, also compute length in bytes
596 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
597 whether the result should be a multibyte string. */
601 for (argnum
= 0; argnum
< nargs
; argnum
++)
605 len
= XFASTINT (Flength (this));
606 if (target_type
== Lisp_String
)
608 /* We must count the number of bytes needed in the string
609 as well as the number of characters. */
615 for (i
= 0; i
< len
; i
++)
617 ch
= XVECTOR (this)->contents
[i
];
619 wrong_type_argument (Qintegerp
, ch
);
620 this_len_byte
= CHAR_BYTES (XINT (ch
));
621 result_len_byte
+= this_len_byte
;
622 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
625 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
626 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
627 else if (CONSP (this))
628 for (; CONSP (this); this = XCDR (this))
632 wrong_type_argument (Qintegerp
, ch
);
633 this_len_byte
= CHAR_BYTES (XINT (ch
));
634 result_len_byte
+= this_len_byte
;
635 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
638 else if (STRINGP (this))
640 if (STRING_MULTIBYTE (this))
643 result_len_byte
+= STRING_BYTES (XSTRING (this));
646 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
647 XSTRING (this)->size
);
654 if (! some_multibyte
)
655 result_len_byte
= result_len
;
657 /* Create the output object. */
658 if (target_type
== Lisp_Cons
)
659 val
= Fmake_list (make_number (result_len
), Qnil
);
660 else if (target_type
== Lisp_Vectorlike
)
661 val
= Fmake_vector (make_number (result_len
), Qnil
);
662 else if (some_multibyte
)
663 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
665 val
= make_uninit_string (result_len
);
667 /* In `append', if all but last arg are nil, return last arg. */
668 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
671 /* Copy the contents of the args into the result. */
673 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
675 toindex
= 0, toindex_byte
= 0;
680 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
682 for (argnum
= 0; argnum
< nargs
; argnum
++)
686 register unsigned int thisindex
= 0;
687 register unsigned int thisindex_byte
= 0;
691 thislen
= Flength (this), thisleni
= XINT (thislen
);
693 /* Between strings of the same kind, copy fast. */
694 if (STRINGP (this) && STRINGP (val
)
695 && STRING_MULTIBYTE (this) == some_multibyte
)
697 int thislen_byte
= STRING_BYTES (XSTRING (this));
700 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
701 STRING_BYTES (XSTRING (this)));
702 combined
= (some_multibyte
&& toindex_byte
> 0
703 ? count_combining (XSTRING (val
)->data
,
704 toindex_byte
+ thislen_byte
,
707 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
709 textprops
[num_textprops
].argnum
= argnum
;
710 /* We ignore text properties on characters being combined. */
711 textprops
[num_textprops
].from
= combined
;
712 textprops
[num_textprops
++].to
= toindex
;
714 toindex_byte
+= thislen_byte
;
715 toindex
+= thisleni
- combined
;
716 XSTRING (val
)->size
-= combined
;
718 /* Copy a single-byte string to a multibyte string. */
719 else if (STRINGP (this) && STRINGP (val
))
721 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
723 textprops
[num_textprops
].argnum
= argnum
;
724 textprops
[num_textprops
].from
= 0;
725 textprops
[num_textprops
++].to
= toindex
;
727 toindex_byte
+= copy_text (XSTRING (this)->data
,
728 XSTRING (val
)->data
+ toindex_byte
,
729 XSTRING (this)->size
, 0, 1);
733 /* Copy element by element. */
736 register Lisp_Object elt
;
738 /* Fetch next element of `this' arg into `elt', or break if
739 `this' is exhausted. */
740 if (NILP (this)) break;
742 elt
= XCAR (this), this = XCDR (this);
743 else if (thisindex
>= thisleni
)
745 else if (STRINGP (this))
748 if (STRING_MULTIBYTE (this))
750 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
753 XSETFASTINT (elt
, c
);
757 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
759 && (XINT (elt
) >= 0240
760 || (XINT (elt
) >= 0200
761 && ! NILP (Vnonascii_translation_table
)))
762 && XINT (elt
) < 0400)
764 c
= unibyte_char_to_multibyte (XINT (elt
));
769 else if (BOOL_VECTOR_P (this))
772 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
773 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
780 elt
= XVECTOR (this)->contents
[thisindex
++];
782 /* Store this element into the result. */
789 else if (VECTORP (val
))
790 XVECTOR (val
)->contents
[toindex
++] = elt
;
793 CHECK_NUMBER (elt
, 0);
794 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
798 += CHAR_STRING (XINT (elt
),
799 XSTRING (val
)->data
+ toindex_byte
);
801 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
804 && count_combining (XSTRING (val
)->data
,
805 toindex_byte
, toindex_byte
- 1))
806 XSTRING (val
)->size
--;
811 /* If we have any multibyte characters,
812 we already decided to make a multibyte string. */
815 /* P exists as a variable
816 to avoid a bug on the Masscomp C compiler. */
817 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
819 toindex_byte
+= CHAR_STRING (c
, p
);
826 XCDR (prev
) = last_tail
;
828 if (num_textprops
> 0)
831 int last_to_end
= -1;
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. */
842 if (last_to_end
== textprops
[argnum
].to
)
843 make_composition_value_copy (props
);
844 add_text_properties_from_list (val
, props
,
845 make_number (textprops
[argnum
].to
));
846 last_to_end
= textprops
[argnum
].to
+ XSTRING (this)->size
;
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.
1058 The function `unibyte-char-to-multibyte' is used to convert
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.
1071 Multibyte character codes are converted to unibyte
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.
1084 If STRING is unibyte, the result is STRING itself.
1085 Otherwise it is a newly created string, with no text properties.
1086 If STRING is multibyte and contains a character of charset
1087 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1088 corresponding single byte. */
1092 CHECK_STRING (string
, 0);
1094 if (STRING_MULTIBYTE (string
))
1096 int bytes
= STRING_BYTES (XSTRING (string
));
1097 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1099 bcopy (XSTRING (string
)->data
, str
, bytes
);
1100 bytes
= str_as_unibyte (str
, bytes
);
1101 string
= make_unibyte_string (str
, bytes
);
1107 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1109 /* Return a multibyte string with the same individual bytes as STRING.
1110 If STRING is multibyte, the result is STRING itself.
1111 Otherwise it is a newly created string, with no text properties.
1112 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1113 part of a multibyte form), it is converted to the corresponding
1114 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */
1118 CHECK_STRING (string
, 0);
1120 if (! STRING_MULTIBYTE (string
))
1122 Lisp_Object new_string
;
1125 parse_str_as_multibyte (XSTRING (string
)->data
,
1126 STRING_BYTES (XSTRING (string
)),
1128 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1129 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1130 STRING_BYTES (XSTRING (string
)));
1131 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1132 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1133 STRING_BYTES (XSTRING (string
)), NULL
);
1134 string
= new_string
;
1135 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1140 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1141 /* Return a copy of ALIST.
1142 This is an alist which represents the same mapping from objects to objects,
1143 but does not share the alist structure with ALIST.
1144 The objects mapped (cars and cdrs of elements of the alist)
1145 are shared, however.
1146 Elements of ALIST that are not conses are also shared. */
1150 register Lisp_Object tem
;
1152 CHECK_LIST (alist
, 0);
1155 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1156 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1158 register Lisp_Object car
;
1162 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1167 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1168 /* Return a substring of STRING, starting at index FROM and ending before TO.
1169 TO may be nil or omitted; then the substring runs to the end of STRING.
1170 If FROM or TO is negative, it counts from the end.
1172 This function allows vectors as well as strings. */
1175 register Lisp_Object from
, to
;
1180 int from_char
, to_char
;
1181 int from_byte
= 0, to_byte
= 0;
1183 if (! (STRINGP (string
) || VECTORP (string
)))
1184 wrong_type_argument (Qarrayp
, string
);
1186 CHECK_NUMBER (from
, 1);
1188 if (STRINGP (string
))
1190 size
= XSTRING (string
)->size
;
1191 size_byte
= STRING_BYTES (XSTRING (string
));
1194 size
= XVECTOR (string
)->size
;
1199 to_byte
= size_byte
;
1203 CHECK_NUMBER (to
, 2);
1205 to_char
= XINT (to
);
1209 if (STRINGP (string
))
1210 to_byte
= string_char_to_byte (string
, to_char
);
1213 from_char
= XINT (from
);
1216 if (STRINGP (string
))
1217 from_byte
= string_char_to_byte (string
, from_char
);
1219 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1220 args_out_of_range_3 (string
, make_number (from_char
),
1221 make_number (to_char
));
1223 if (STRINGP (string
))
1225 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1226 to_char
- from_char
, to_byte
- from_byte
,
1227 STRING_MULTIBYTE (string
));
1228 copy_text_properties (make_number (from_char
), make_number (to_char
),
1229 string
, make_number (0), res
, Qnil
);
1232 res
= Fvector (to_char
- from_char
,
1233 XVECTOR (string
)->contents
+ from_char
);
1238 /* Extract a substring of STRING, giving start and end positions
1239 both in characters and in bytes. */
1242 substring_both (string
, from
, from_byte
, to
, to_byte
)
1244 int from
, from_byte
, to
, to_byte
;
1250 if (! (STRINGP (string
) || VECTORP (string
)))
1251 wrong_type_argument (Qarrayp
, string
);
1253 if (STRINGP (string
))
1255 size
= XSTRING (string
)->size
;
1256 size_byte
= STRING_BYTES (XSTRING (string
));
1259 size
= XVECTOR (string
)->size
;
1261 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1262 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1264 if (STRINGP (string
))
1266 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1267 to
- from
, to_byte
- from_byte
,
1268 STRING_MULTIBYTE (string
));
1269 copy_text_properties (make_number (from
), make_number (to
),
1270 string
, make_number (0), res
, Qnil
);
1273 res
= Fvector (to
- from
,
1274 XVECTOR (string
)->contents
+ from
);
1279 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1280 /* Take cdr N times on LIST, returns the result. */
1283 register Lisp_Object list
;
1285 register int i
, num
;
1286 CHECK_NUMBER (n
, 0);
1288 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1292 wrong_type_argument (Qlistp
, list
);
1298 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1299 /* Return the Nth element of LIST.
1300 N counts from zero. If LIST is not that long, nil is returned. */
1302 Lisp_Object n
, list
;
1304 return Fcar (Fnthcdr (n
, list
));
1307 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1308 /* Return element of SEQUENCE at index N. */
1310 register Lisp_Object sequence
, n
;
1312 CHECK_NUMBER (n
, 0);
1315 if (CONSP (sequence
) || NILP (sequence
))
1316 return Fcar (Fnthcdr (n
, sequence
));
1317 else if (STRINGP (sequence
) || VECTORP (sequence
)
1318 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1319 return Faref (sequence
, n
);
1321 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1325 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1326 /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1327 The value is actually the tail of LIST whose car is ELT. */
1329 register Lisp_Object elt
;
1332 register Lisp_Object tail
;
1333 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1335 register Lisp_Object tem
;
1337 wrong_type_argument (Qlistp
, list
);
1339 if (! NILP (Fequal (elt
, tem
)))
1346 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1347 /* Return non-nil if ELT is an element of LIST.
1348 Comparison done with EQ. The value is actually the tail of LIST
1349 whose car is ELT. */
1351 Lisp_Object elt
, list
;
1355 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1359 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1363 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1370 if (!CONSP (list
) && !NILP (list
))
1371 list
= wrong_type_argument (Qlistp
, list
);
1376 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1377 /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1378 The value is actually the element of LIST whose car is KEY.
1379 Elements of LIST that are not conses are ignored. */
1381 Lisp_Object key
, list
;
1388 || (CONSP (XCAR (list
))
1389 && EQ (XCAR (XCAR (list
)), key
)))
1394 || (CONSP (XCAR (list
))
1395 && EQ (XCAR (XCAR (list
)), key
)))
1400 || (CONSP (XCAR (list
))
1401 && EQ (XCAR (XCAR (list
)), key
)))
1409 result
= XCAR (list
);
1410 else if (NILP (list
))
1413 result
= wrong_type_argument (Qlistp
, list
);
1418 /* Like Fassq but never report an error and do not allow quits.
1419 Use only on lists known never to be circular. */
1422 assq_no_quit (key
, list
)
1423 Lisp_Object key
, list
;
1426 && (!CONSP (XCAR (list
))
1427 || !EQ (XCAR (XCAR (list
)), key
)))
1430 return CONSP (list
) ? XCAR (list
) : Qnil
;
1433 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1434 /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1435 The value is actually the element of LIST whose car equals KEY. */
1437 Lisp_Object key
, list
;
1439 Lisp_Object result
, car
;
1444 || (CONSP (XCAR (list
))
1445 && (car
= XCAR (XCAR (list
)),
1446 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1451 || (CONSP (XCAR (list
))
1452 && (car
= XCAR (XCAR (list
)),
1453 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1458 || (CONSP (XCAR (list
))
1459 && (car
= XCAR (XCAR (list
)),
1460 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1468 result
= XCAR (list
);
1469 else if (NILP (list
))
1472 result
= wrong_type_argument (Qlistp
, list
);
1477 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1478 /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1479 The value is actually the element of LIST whose cdr is KEY. */
1481 register Lisp_Object key
;
1489 || (CONSP (XCAR (list
))
1490 && EQ (XCDR (XCAR (list
)), key
)))
1495 || (CONSP (XCAR (list
))
1496 && EQ (XCDR (XCAR (list
)), key
)))
1501 || (CONSP (XCAR (list
))
1502 && EQ (XCDR (XCAR (list
)), key
)))
1511 else if (CONSP (list
))
1512 result
= XCAR (list
);
1514 result
= wrong_type_argument (Qlistp
, list
);
1519 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1520 /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1521 The value is actually the element of LIST whose cdr equals KEY. */
1523 Lisp_Object key
, list
;
1525 Lisp_Object result
, cdr
;
1530 || (CONSP (XCAR (list
))
1531 && (cdr
= XCDR (XCAR (list
)),
1532 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1537 || (CONSP (XCAR (list
))
1538 && (cdr
= XCDR (XCAR (list
)),
1539 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1544 || (CONSP (XCAR (list
))
1545 && (cdr
= XCDR (XCAR (list
)),
1546 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1554 result
= XCAR (list
);
1555 else if (NILP (list
))
1558 result
= wrong_type_argument (Qlistp
, list
);
1563 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1564 /* Delete by side effect any occurrences of ELT as a member of LIST.
1565 The modified LIST is returned. Comparison is done with `eq'.
1566 If the first member of LIST is ELT, there is no way to remove it by side effect;
1567 therefore, write `(setq foo (delq element foo))'
1568 to be sure of changing the value of `foo'. */
1570 register Lisp_Object elt
;
1573 register Lisp_Object tail
, prev
;
1574 register Lisp_Object tem
;
1578 while (!NILP (tail
))
1581 wrong_type_argument (Qlistp
, list
);
1588 Fsetcdr (prev
, XCDR (tail
));
1598 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1599 /* Delete by side effect any occurrences of ELT as a member of SEQ.
1600 SEQ must be a list, a vector, or a string.
1601 The modified SEQ is returned. Comparison is done with `equal'.
1602 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1603 is not a side effect; it is simply using a different sequence.
1604 Therefore, write `(setq foo (delete element foo))'
1605 to be sure of changing the value of `foo'. */
1607 Lisp_Object elt
, seq
;
1613 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1614 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1617 if (n
!= ASIZE (seq
))
1619 struct Lisp_Vector
*p
= allocate_vector (n
);
1621 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1622 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1623 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.
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.
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.
1765 Returns the sorted list. LIST is modified by side effects.
1766 PREDICATE is called with two elements of LIST, and should return t
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.
1857 PLIST is a property list, which is a list of the form
1858 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1859 corresponding to the given PROP, or nil if PROP is not
1860 one of the properties on the list. */
1868 CONSP (tail
) && CONSP (XCDR (tail
));
1869 tail
= XCDR (XCDR (tail
)))
1871 if (EQ (prop
, XCAR (tail
)))
1872 return XCAR (XCDR (tail
));
1874 /* This function can be called asynchronously
1875 (setup_coding_system). Don't QUIT in that case. */
1876 if (!interrupt_input_blocked
)
1881 wrong_type_argument (Qlistp
, prop
);
1886 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1887 /* Return the value of SYMBOL's PROPNAME property.
1888 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */
1890 Lisp_Object symbol
, propname
;
1892 CHECK_SYMBOL (symbol
, 0);
1893 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1896 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1897 /* Change value in PLIST of PROP to VAL.
1898 PLIST is a property list, which is a list of the form
1899 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1900 If PROP is already a property on the list, its value is set to VAL,
1901 otherwise the new PROP VAL pair is added. The new plist is returned;
1902 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1903 The PLIST is modified by side effects. */
1906 register Lisp_Object prop
;
1909 register Lisp_Object tail
, prev
;
1910 Lisp_Object newcell
;
1912 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1913 tail
= XCDR (XCDR (tail
)))
1915 if (EQ (prop
, XCAR (tail
)))
1917 Fsetcar (XCDR (tail
), val
);
1924 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1928 Fsetcdr (XCDR (prev
), newcell
);
1932 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1933 /* Store SYMBOL's PROPNAME property with value VALUE.
1934 It can be retrieved with `(get SYMBOL PROPNAME)'. */
1935 (symbol
, propname
, value
))
1936 Lisp_Object symbol
, propname
, value
;
1938 CHECK_SYMBOL (symbol
, 0);
1939 XSYMBOL (symbol
)->plist
1940 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1944 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1945 /* Return t if two Lisp objects have similar structure and contents.
1946 They must have the same data type.
1947 Conses are compared by comparing the cars and the cdrs.
1948 Vectors and strings are compared element by element.
1949 Numbers are compared by value, but integers cannot equal floats.
1950 (Use `=' if you want integers and floats to be able to be equal.)
1951 Symbols must match exactly. */
1953 register Lisp_Object o1
, o2
;
1955 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1959 internal_equal (o1
, o2
, depth
)
1960 register Lisp_Object o1
, o2
;
1964 error ("Stack overflow in equal");
1970 if (XTYPE (o1
) != XTYPE (o2
))
1976 return (extract_float (o1
) == extract_float (o2
));
1979 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1986 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1990 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1992 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1995 o1
= XOVERLAY (o1
)->plist
;
1996 o2
= XOVERLAY (o2
)->plist
;
2001 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2002 && (XMARKER (o1
)->buffer
== 0
2003 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2007 case Lisp_Vectorlike
:
2009 register int i
, size
;
2010 size
= XVECTOR (o1
)->size
;
2011 /* Pseudovectors have the type encoded in the size field, so this test
2012 actually checks that the objects have the same type as well as the
2014 if (XVECTOR (o2
)->size
!= size
)
2016 /* Boolvectors are compared much like strings. */
2017 if (BOOL_VECTOR_P (o1
))
2020 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2022 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2024 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2029 if (WINDOW_CONFIGURATIONP (o1
))
2030 return compare_window_configurations (o1
, o2
, 0);
2032 /* Aside from them, only true vectors, char-tables, and compiled
2033 functions are sensible to compare, so eliminate the others now. */
2034 if (size
& PSEUDOVECTOR_FLAG
)
2036 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2038 size
&= PSEUDOVECTOR_SIZE_MASK
;
2040 for (i
= 0; i
< size
; i
++)
2043 v1
= XVECTOR (o1
)->contents
[i
];
2044 v2
= XVECTOR (o2
)->contents
[i
];
2045 if (!internal_equal (v1
, v2
, depth
+ 1))
2053 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
2055 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
2057 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
2058 STRING_BYTES (XSTRING (o1
))))
2064 case Lisp_Type_Limit
:
2071 extern Lisp_Object
Fmake_char_internal ();
2073 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2074 /* Store each element of ARRAY with ITEM.
2075 ARRAY is a vector, string, char-table, or bool-vector. */
2077 Lisp_Object array
, item
;
2079 register int size
, index
, charval
;
2081 if (VECTORP (array
))
2083 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2084 size
= XVECTOR (array
)->size
;
2085 for (index
= 0; index
< size
; index
++)
2088 else if (CHAR_TABLE_P (array
))
2090 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2091 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2092 for (index
= 0; index
< size
; index
++)
2094 XCHAR_TABLE (array
)->defalt
= Qnil
;
2096 else if (STRINGP (array
))
2098 register unsigned char *p
= XSTRING (array
)->data
;
2099 CHECK_NUMBER (item
, 1);
2100 charval
= XINT (item
);
2101 size
= XSTRING (array
)->size
;
2102 if (STRING_MULTIBYTE (array
))
2104 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2105 int len
= CHAR_STRING (charval
, str
);
2106 int size_byte
= STRING_BYTES (XSTRING (array
));
2107 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2110 if (size
!= size_byte
)
2113 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2114 if (len
!= this_len
)
2115 error ("Attempt to change byte length of a string");
2118 for (i
= 0; i
< size_byte
; i
++)
2119 *p
++ = str
[i
% len
];
2122 for (index
= 0; index
< size
; index
++)
2125 else if (BOOL_VECTOR_P (array
))
2127 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2129 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2131 charval
= (! NILP (item
) ? -1 : 0);
2132 for (index
= 0; index
< size_in_chars
; index
++)
2137 array
= wrong_type_argument (Qarrayp
, array
);
2143 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2145 /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */
2147 Lisp_Object char_table
;
2149 CHECK_CHAR_TABLE (char_table
, 0);
2151 return XCHAR_TABLE (char_table
)->purpose
;
2154 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2156 /* Return the parent char-table of CHAR-TABLE.
2157 The value is either nil or another char-table.
2158 If CHAR-TABLE holds nil for a given character,
2159 then the actual applicable value is inherited from the parent char-table
2160 \(or from its parents, if necessary). */
2162 Lisp_Object char_table
;
2164 CHECK_CHAR_TABLE (char_table
, 0);
2166 return XCHAR_TABLE (char_table
)->parent
;
2169 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2171 /* Set the parent char-table of CHAR-TABLE to PARENT.
2172 PARENT must be either nil or another char-table. */
2173 (char_table
, parent
))
2174 Lisp_Object char_table
, parent
;
2178 CHECK_CHAR_TABLE (char_table
, 0);
2182 CHECK_CHAR_TABLE (parent
, 0);
2184 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2185 if (EQ (temp
, char_table
))
2186 error ("Attempt to make a chartable be its own parent");
2189 XCHAR_TABLE (char_table
)->parent
= parent
;
2194 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2196 /* Return the value of CHAR-TABLE's extra-slot number N. */
2198 Lisp_Object char_table
, n
;
2200 CHECK_CHAR_TABLE (char_table
, 1);
2201 CHECK_NUMBER (n
, 2);
2203 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2204 args_out_of_range (char_table
, n
);
2206 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2209 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2210 Sset_char_table_extra_slot
,
2212 /* Set CHAR-TABLE's extra-slot number N to VALUE. */
2213 (char_table
, n
, value
))
2214 Lisp_Object char_table
, n
, value
;
2216 CHECK_CHAR_TABLE (char_table
, 1);
2217 CHECK_NUMBER (n
, 2);
2219 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2220 args_out_of_range (char_table
, n
);
2222 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2225 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2227 /* Return the value in CHAR-TABLE for a range of characters RANGE.
2228 RANGE should be nil (for the default value)
2229 a vector which identifies a character set or a row of a character set,
2230 a character set name, or a character code. */
2231 (char_table
, range
))
2232 Lisp_Object char_table
, range
;
2234 CHECK_CHAR_TABLE (char_table
, 0);
2236 if (EQ (range
, Qnil
))
2237 return XCHAR_TABLE (char_table
)->defalt
;
2238 else if (INTEGERP (range
))
2239 return Faref (char_table
, range
);
2240 else if (SYMBOLP (range
))
2242 Lisp_Object charset_info
;
2244 charset_info
= Fget (range
, Qcharset
);
2245 CHECK_VECTOR (charset_info
, 0);
2247 return Faref (char_table
,
2248 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2251 else if (VECTORP (range
))
2253 if (XVECTOR (range
)->size
== 1)
2254 return Faref (char_table
,
2255 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2258 int size
= XVECTOR (range
)->size
;
2259 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2260 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2261 size
<= 1 ? Qnil
: val
[1],
2262 size
<= 2 ? Qnil
: val
[2]);
2263 return Faref (char_table
, ch
);
2267 error ("Invalid RANGE argument to `char-table-range'");
2271 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2273 /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2274 RANGE should be t (for all characters), nil (for the default value)
2275 a vector which identifies a character set or a row of a character set,
2276 a coding system, or a character code. */
2277 (char_table
, range
, value
))
2278 Lisp_Object char_table
, range
, value
;
2282 CHECK_CHAR_TABLE (char_table
, 0);
2285 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2286 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2287 else if (EQ (range
, Qnil
))
2288 XCHAR_TABLE (char_table
)->defalt
= value
;
2289 else if (SYMBOLP (range
))
2291 Lisp_Object charset_info
;
2293 charset_info
= Fget (range
, Qcharset
);
2294 CHECK_VECTOR (charset_info
, 0);
2296 return Faset (char_table
,
2297 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2301 else if (INTEGERP (range
))
2302 Faset (char_table
, range
, value
);
2303 else if (VECTORP (range
))
2305 if (XVECTOR (range
)->size
== 1)
2306 return Faset (char_table
,
2307 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2311 int size
= XVECTOR (range
)->size
;
2312 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2313 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2314 size
<= 1 ? Qnil
: val
[1],
2315 size
<= 2 ? Qnil
: val
[2]);
2316 return Faset (char_table
, ch
, value
);
2320 error ("Invalid RANGE argument to `set-char-table-range'");
2325 DEFUN ("set-char-table-default", Fset_char_table_default
,
2326 Sset_char_table_default
, 3, 3, 0,
2327 /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
2328 The generic character specifies the group of characters.
2329 See also the documentation of make-char. */
2330 (char_table
, ch
, value
))
2331 Lisp_Object char_table
, ch
, value
;
2333 int c
, charset
, code1
, code2
;
2336 CHECK_CHAR_TABLE (char_table
, 0);
2337 CHECK_NUMBER (ch
, 1);
2340 SPLIT_CHAR (c
, charset
, code1
, code2
);
2342 /* Since we may want to set the default value for a character set
2343 not yet defined, we check only if the character set is in the
2344 valid range or not, instead of it is already defined or not. */
2345 if (! CHARSET_VALID_P (charset
))
2346 invalid_character (c
);
2348 if (charset
== CHARSET_ASCII
)
2349 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2351 /* Even if C is not a generic char, we had better behave as if a
2352 generic char is specified. */
2353 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2355 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2358 if (SUB_CHAR_TABLE_P (temp
))
2359 XCHAR_TABLE (temp
)->defalt
= value
;
2361 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2364 if (SUB_CHAR_TABLE_P (temp
))
2367 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2368 = make_sub_char_table (temp
));
2369 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2370 if (SUB_CHAR_TABLE_P (temp
))
2371 XCHAR_TABLE (temp
)->defalt
= value
;
2373 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2377 /* Look up the element in TABLE at index CH,
2378 and return it as an integer.
2379 If the element is nil, return CH itself.
2380 (Actually we do that for any non-integer.) */
2383 char_table_translate (table
, ch
)
2388 value
= Faref (table
, make_number (ch
));
2389 if (! INTEGERP (value
))
2391 return XINT (value
);
2395 optimize_sub_char_table (table
, chars
)
2403 from
= 33, to
= 127;
2405 from
= 32, to
= 128;
2407 if (!SUB_CHAR_TABLE_P (*table
))
2409 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2410 for (; from
< to
; from
++)
2411 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2416 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2418 /* Optimize char table TABLE. */
2426 CHECK_CHAR_TABLE (table
, 0);
2428 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2430 elt
= XCHAR_TABLE (table
)->contents
[i
];
2431 if (!SUB_CHAR_TABLE_P (elt
))
2433 dim
= CHARSET_DIMENSION (i
- 128);
2435 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2436 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2437 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2443 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2444 character or group of characters that share a value.
2445 DEPTH is the current depth in the originally specified
2446 chartable, and INDICES contains the vector indices
2447 for the levels our callers have descended.
2449 ARG is passed to C_FUNCTION when that is called. */
2452 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2453 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2454 Lisp_Object function
, subtable
, arg
, *indices
;
2461 /* At first, handle ASCII and 8-bit European characters. */
2462 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2464 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2466 (*c_function
) (arg
, make_number (i
), elt
);
2468 call2 (function
, make_number (i
), elt
);
2470 #if 0 /* If the char table has entries for higher characters,
2471 we should report them. */
2472 if (NILP (current_buffer
->enable_multibyte_characters
))
2475 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2479 int charset
= XFASTINT (indices
[0]) - 128;
2482 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2483 if (CHARSET_CHARS (charset
) == 94)
2492 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2493 XSETFASTINT (indices
[depth
], i
);
2494 charset
= XFASTINT (indices
[0]) - 128;
2496 && (!CHARSET_DEFINED_P (charset
)
2497 || charset
== CHARSET_8_BIT_CONTROL
2498 || charset
== CHARSET_8_BIT_GRAPHIC
))
2501 if (SUB_CHAR_TABLE_P (elt
))
2504 error ("Too deep char table");
2505 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2512 elt
= XCHAR_TABLE (subtable
)->defalt
;
2513 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2514 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2515 c
= MAKE_CHAR (charset
, c1
, c2
);
2517 (*c_function
) (arg
, make_number (c
), elt
);
2519 call2 (function
, make_number (c
), elt
);
2524 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2526 /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2527 FUNCTION is called with two arguments--a key and a value.
2528 The key is always a possible IDX argument to `aref'. */
2529 (function
, char_table
))
2530 Lisp_Object function
, char_table
;
2532 /* The depth of char table is at most 3. */
2533 Lisp_Object indices
[3];
2535 CHECK_CHAR_TABLE (char_table
, 1);
2537 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2541 /* Return a value for character C in char-table TABLE. Store the
2542 actual index for that value in *IDX. Ignore the default value of
2546 char_table_ref_and_index (table
, c
, idx
)
2550 int charset
, c1
, c2
;
2553 if (SINGLE_BYTE_CHAR_P (c
))
2556 return XCHAR_TABLE (table
)->contents
[c
];
2558 SPLIT_CHAR (c
, charset
, c1
, c2
);
2559 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2560 *idx
= MAKE_CHAR (charset
, 0, 0);
2561 if (!SUB_CHAR_TABLE_P (elt
))
2563 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2564 return XCHAR_TABLE (elt
)->defalt
;
2565 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2566 *idx
= MAKE_CHAR (charset
, c1
, 0);
2567 if (!SUB_CHAR_TABLE_P (elt
))
2569 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2570 return XCHAR_TABLE (elt
)->defalt
;
2572 return XCHAR_TABLE (elt
)->contents
[c2
];
2582 Lisp_Object args
[2];
2585 return Fnconc (2, args
);
2587 return Fnconc (2, &s1
);
2588 #endif /* NO_ARG_ARRAY */
2591 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2592 /* Concatenate any number of lists by altering them.
2593 Only the last argument is not altered, and need not be a list. */
2598 register int argnum
;
2599 register Lisp_Object tail
, tem
, val
;
2603 for (argnum
= 0; argnum
< nargs
; argnum
++)
2606 if (NILP (tem
)) continue;
2611 if (argnum
+ 1 == nargs
) break;
2614 tem
= wrong_type_argument (Qlistp
, tem
);
2623 tem
= args
[argnum
+ 1];
2624 Fsetcdr (tail
, tem
);
2626 args
[argnum
+ 1] = tail
;
2632 /* This is the guts of all mapping functions.
2633 Apply FN to each element of SEQ, one by one,
2634 storing the results into elements of VALS, a C vector of Lisp_Objects.
2635 LENI is the length of VALS, which should also be the length of SEQ. */
2638 mapcar1 (leni
, vals
, fn
, seq
)
2641 Lisp_Object fn
, seq
;
2643 register Lisp_Object tail
;
2646 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2650 /* Don't let vals contain any garbage when GC happens. */
2651 for (i
= 0; i
< leni
; i
++)
2654 GCPRO3 (dummy
, fn
, seq
);
2656 gcpro1
.nvars
= leni
;
2660 /* We need not explicitly protect `tail' because it is used only on lists, and
2661 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2665 for (i
= 0; i
< leni
; i
++)
2667 dummy
= XVECTOR (seq
)->contents
[i
];
2668 dummy
= call1 (fn
, dummy
);
2673 else if (BOOL_VECTOR_P (seq
))
2675 for (i
= 0; i
< leni
; i
++)
2678 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2679 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2684 dummy
= call1 (fn
, dummy
);
2689 else if (STRINGP (seq
))
2693 for (i
= 0, i_byte
= 0; i
< leni
;)
2698 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2699 XSETFASTINT (dummy
, c
);
2700 dummy
= call1 (fn
, dummy
);
2702 vals
[i_before
] = dummy
;
2705 else /* Must be a list, since Flength did not get an error */
2708 for (i
= 0; i
< leni
; i
++)
2710 dummy
= call1 (fn
, Fcar (tail
));
2720 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2721 /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2722 In between each pair of results, stick in SEPARATOR. Thus, " " as
2723 SEPARATOR results in spaces between the values returned by FUNCTION.
2724 SEQUENCE may be a list, a vector, a bool-vector, or a string. */
2725 (function
, sequence
, separator
))
2726 Lisp_Object function
, sequence
, separator
;
2731 register Lisp_Object
*args
;
2733 struct gcpro gcpro1
;
2735 len
= Flength (sequence
);
2737 nargs
= leni
+ leni
- 1;
2738 if (nargs
< 0) return build_string ("");
2740 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2743 mapcar1 (leni
, args
, function
, sequence
);
2746 for (i
= leni
- 1; i
>= 0; i
--)
2747 args
[i
+ i
] = args
[i
];
2749 for (i
= 1; i
< nargs
; i
+= 2)
2750 args
[i
] = separator
;
2752 return Fconcat (nargs
, args
);
2755 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2756 /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2757 The result is a list just as long as SEQUENCE.
2758 SEQUENCE may be a list, a vector, a bool-vector, or a string. */
2759 (function
, sequence
))
2760 Lisp_Object function
, sequence
;
2762 register Lisp_Object len
;
2764 register Lisp_Object
*args
;
2766 len
= Flength (sequence
);
2767 leni
= XFASTINT (len
);
2768 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2770 mapcar1 (leni
, args
, function
, sequence
);
2772 return Flist (leni
, args
);
2775 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2776 /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2777 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2778 SEQUENCE may be a list, a vector, a bool-vector, or a string. */
2779 (function
, sequence
))
2780 Lisp_Object function
, sequence
;
2784 leni
= XFASTINT (Flength (sequence
));
2785 mapcar1 (leni
, 0, function
, sequence
);
2790 /* Anything that calls this function must protect from GC! */
2792 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2793 /* Ask user a "y or n" question. Return t if answer is "y".
2794 Takes one argument, which is the string to display to ask the question.
2795 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2796 No confirmation of the answer is requested; a single character is enough.
2797 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2798 the bindings in `query-replace-map'; see the documentation of that variable
2799 for more information. In this case, the useful bindings are `act', `skip',
2800 `recenter', and `quit'.\)
2802 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2803 is nil and `use-dialog-box' is non-nil. */
2807 register Lisp_Object obj
, key
, def
, map
;
2808 register int answer
;
2809 Lisp_Object xprompt
;
2810 Lisp_Object args
[2];
2811 struct gcpro gcpro1
, gcpro2
;
2812 int count
= specpdl_ptr
- specpdl
;
2814 specbind (Qcursor_in_echo_area
, Qt
);
2816 map
= Fsymbol_value (intern ("query-replace-map"));
2818 CHECK_STRING (prompt
, 0);
2820 GCPRO2 (prompt
, xprompt
);
2822 #ifdef HAVE_X_WINDOWS
2823 if (display_hourglass_p
)
2824 cancel_hourglass ();
2831 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2835 Lisp_Object pane
, menu
;
2836 redisplay_preserve_echo_area (3);
2837 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2838 Fcons (Fcons (build_string ("No"), Qnil
),
2840 menu
= Fcons (prompt
, pane
);
2841 obj
= Fx_popup_dialog (Qt
, menu
);
2842 answer
= !NILP (obj
);
2845 #endif /* HAVE_MENUS */
2846 cursor_in_echo_area
= 1;
2847 choose_minibuf_frame ();
2848 message_with_string ("%s(y or n) ", xprompt
, 0);
2850 if (minibuffer_auto_raise
)
2852 Lisp_Object mini_frame
;
2854 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2856 Fraise_frame (mini_frame
);
2859 obj
= read_filtered_event (1, 0, 0, 0);
2860 cursor_in_echo_area
= 0;
2861 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2864 key
= Fmake_vector (make_number (1), obj
);
2865 def
= Flookup_key (map
, key
, Qt
);
2867 if (EQ (def
, intern ("skip")))
2872 else if (EQ (def
, intern ("act")))
2877 else if (EQ (def
, intern ("recenter")))
2883 else if (EQ (def
, intern ("quit")))
2885 /* We want to exit this command for exit-prefix,
2886 and this is the only way to do it. */
2887 else if (EQ (def
, intern ("exit-prefix")))
2892 /* If we don't clear this, then the next call to read_char will
2893 return quit_char again, and we'll enter an infinite loop. */
2898 if (EQ (xprompt
, prompt
))
2900 args
[0] = build_string ("Please answer y or n. ");
2902 xprompt
= Fconcat (2, args
);
2907 if (! noninteractive
)
2909 cursor_in_echo_area
= -1;
2910 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2914 unbind_to (count
, Qnil
);
2915 return answer
? Qt
: Qnil
;
2918 /* This is how C code calls `yes-or-no-p' and allows the user
2921 Anything that calls this function must protect from GC! */
2924 do_yes_or_no_p (prompt
)
2927 return call1 (intern ("yes-or-no-p"), prompt
);
2930 /* Anything that calls this function must protect from GC! */
2932 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2933 /* Ask user a yes-or-no question. Return t if answer is yes.
2934 Takes one argument, which is the string to display to ask the question.
2935 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2936 The user must confirm the answer with RET,
2937 and can edit it until it has been confirmed.
2939 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2940 is nil, and `use-dialog-box' is non-nil. */
2944 register Lisp_Object ans
;
2945 Lisp_Object args
[2];
2946 struct gcpro gcpro1
;
2948 CHECK_STRING (prompt
, 0);
2951 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2955 Lisp_Object pane
, menu
, obj
;
2956 redisplay_preserve_echo_area (4);
2957 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2958 Fcons (Fcons (build_string ("No"), Qnil
),
2961 menu
= Fcons (prompt
, pane
);
2962 obj
= Fx_popup_dialog (Qt
, menu
);
2966 #endif /* HAVE_MENUS */
2969 args
[1] = build_string ("(yes or no) ");
2970 prompt
= Fconcat (2, args
);
2976 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2977 Qyes_or_no_p_history
, Qnil
,
2979 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2984 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2992 message ("Please answer yes or no.");
2993 Fsleep_for (make_number (2), Qnil
);
2997 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2998 /* Return list of 1 minute, 5 minute and 15 minute load averages.
3000 Each of the three load averages is multiplied by 100, then converted
3003 When USE-FLOATS is non-nil, floats will be used instead of integers.
3004 These floats are not multiplied by 100.
3006 If the 5-minute or 15-minute load averages are not available, return a
3007 shortened list, containing only those averages which are available. */
3009 Lisp_Object use_floats
;
3012 int loads
= getloadavg (load_ave
, 3);
3013 Lisp_Object ret
= Qnil
;
3016 error ("load-average not implemented for this operating system");
3020 Lisp_Object load
= (NILP (use_floats
) ?
3021 make_number ((int) (100.0 * load_ave
[loads
]))
3022 : make_float (load_ave
[loads
]));
3023 ret
= Fcons (load
, ret
);
3029 Lisp_Object Vfeatures
, Qsubfeatures
;
3030 extern Lisp_Object Vafter_load_alist
;
3032 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3033 /* Returns t if FEATURE is present in this Emacs.
3035 Use this to conditionalize execution of lisp code based on the
3036 presence or absence of emacs or environment extensions.
3037 Use `provide' to declare that a feature is available. This function
3038 looks at the value of the variable `features'. The optional argument
3039 SUBFEATURE can be used to check a specific subfeature of FEATURE. */
3040 (feature
, subfeature
))
3041 Lisp_Object feature
, subfeature
;
3043 register Lisp_Object tem
;
3044 CHECK_SYMBOL (feature
, 0);
3045 tem
= Fmemq (feature
, Vfeatures
);
3046 if (!NILP (tem
) && !NILP (subfeature
))
3047 tem
= Fmemq (subfeature
, Fget (feature
, Qsubfeatures
));
3048 return (NILP (tem
)) ? Qnil
: Qt
;
3051 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3052 /* Announce that FEATURE is a feature of the current Emacs.
3053 The optional argument SUBFEATURES should be a list of symbols listing
3054 particular subfeatures supported in this version of FEATURE. */
3055 (feature
, subfeatures
))
3056 Lisp_Object feature
, subfeatures
;
3058 register Lisp_Object tem
;
3059 CHECK_SYMBOL (feature
, 0);
3060 if (!NILP (Vautoload_queue
))
3061 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3062 tem
= Fmemq (feature
, Vfeatures
);
3064 Vfeatures
= Fcons (feature
, Vfeatures
);
3065 if (!NILP (subfeatures
))
3066 Fput (feature
, Qsubfeatures
, subfeatures
);
3067 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3069 /* Run any load-hooks for this file. */
3070 tem
= Fassq (feature
, Vafter_load_alist
);
3072 Fprogn (Fcdr (tem
));
3077 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3078 /* If feature FEATURE is not loaded, load it from FILENAME.
3079 If FEATURE is not a member of the list `features', then the feature
3080 is not loaded; so load the file FILENAME.
3081 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3082 and `load' will try to load this name appended with the suffix `.elc',
3083 `.el' or the unmodified name, in that order.
3084 If the optional third argument NOERROR is non-nil,
3085 then return nil if the file is not found instead of signaling an error.
3086 Normally the return value is FEATURE.
3087 The normal messages at start and end of loading FILENAME are suppressed. */
3088 (feature
, filename
, noerror
))
3089 Lisp_Object feature
, filename
, noerror
;
3091 register Lisp_Object tem
;
3092 CHECK_SYMBOL (feature
, 0);
3093 tem
= Fmemq (feature
, Vfeatures
);
3095 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3099 int count
= specpdl_ptr
- specpdl
;
3101 /* Value saved here is to be restored into Vautoload_queue */
3102 record_unwind_protect (un_autoload
, Vautoload_queue
);
3103 Vautoload_queue
= Qt
;
3105 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3106 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3107 /* If load failed entirely, return nil. */
3109 return unbind_to (count
, Qnil
);
3111 tem
= Fmemq (feature
, Vfeatures
);
3113 error ("Required feature %s was not provided",
3114 XSYMBOL (feature
)->name
->data
);
3116 /* Once loading finishes, don't undo it. */
3117 Vautoload_queue
= Qt
;
3118 feature
= unbind_to (count
, feature
);
3123 /* Primitives for work of the "widget" library.
3124 In an ideal world, this section would not have been necessary.
3125 However, lisp function calls being as slow as they are, it turns
3126 out that some functions in the widget library (wid-edit.el) are the
3127 bottleneck of Widget operation. Here is their translation to C,
3128 for the sole reason of efficiency. */
3130 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3131 /* Return non-nil if PLIST has the property PROP.
3132 PLIST is a property list, which is a list of the form
3133 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3134 Unlike `plist-get', this allows you to distinguish between a missing
3135 property and a property with the value nil.
3136 The value is actually the tail of PLIST whose car is PROP. */
3138 Lisp_Object plist
, prop
;
3140 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3143 plist
= XCDR (plist
);
3144 plist
= CDR (plist
);
3149 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3150 /* In WIDGET, set PROPERTY to VALUE.
3151 The value can later be retrieved with `widget-get'. */
3152 (widget
, property
, value
))
3153 Lisp_Object widget
, property
, value
;
3155 CHECK_CONS (widget
, 1);
3156 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
3160 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3161 /* In WIDGET, get the value of PROPERTY.
3162 The value could either be specified when the widget was created, or
3163 later with `widget-put'. */
3165 Lisp_Object widget
, property
;
3173 CHECK_CONS (widget
, 1);
3174 tmp
= Fplist_member (XCDR (widget
), property
);
3180 tmp
= XCAR (widget
);
3183 widget
= Fget (tmp
, Qwidget_type
);
3187 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3188 /* Apply the value of WIDGET's PROPERTY to the widget itself.
3189 ARGS are passed as extra arguments to the function. */
3194 /* This function can GC. */
3195 Lisp_Object newargs
[3];
3196 struct gcpro gcpro1
, gcpro2
;
3199 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3200 newargs
[1] = args
[0];
3201 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3202 GCPRO2 (newargs
[0], newargs
[2]);
3203 result
= Fapply (3, newargs
);
3208 /* base64 encode/decode functions (RFC 2045).
3209 Based on code from GNU recode. */
3211 #define MIME_LINE_LENGTH 76
3213 #define IS_ASCII(Character) \
3215 #define IS_BASE64(Character) \
3216 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3217 #define IS_BASE64_IGNORABLE(Character) \
3218 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3219 || (Character) == '\f' || (Character) == '\r')
3221 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3222 character or return retval if there are no characters left to
3224 #define READ_QUADRUPLET_BYTE(retval) \
3229 if (nchars_return) \
3230 *nchars_return = nchars; \
3235 while (IS_BASE64_IGNORABLE (c))
3237 /* Don't use alloca for regions larger than this, lest we overflow
3239 #define MAX_ALLOCA 16*1024
3241 /* Table of characters coding the 64 values. */
3242 static char base64_value_to_char
[64] =
3244 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3245 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3246 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3247 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3248 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3249 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3250 '8', '9', '+', '/' /* 60-63 */
3253 /* Table of base64 values for first 128 characters. */
3254 static short base64_char_to_value
[128] =
3256 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3257 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3258 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3259 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3260 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3261 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3262 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3263 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3264 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3265 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3266 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3267 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3268 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3271 /* The following diagram shows the logical steps by which three octets
3272 get transformed into four base64 characters.
3274 .--------. .--------. .--------.
3275 |aaaaaabb| |bbbbcccc| |ccdddddd|
3276 `--------' `--------' `--------'
3278 .--------+--------+--------+--------.
3279 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3280 `--------+--------+--------+--------'
3282 .--------+--------+--------+--------.
3283 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3284 `--------+--------+--------+--------'
3286 The octets are divided into 6 bit chunks, which are then encoded into
3287 base64 characters. */
3290 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3291 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3293 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3295 /* Base64-encode the region between BEG and END.
3296 Return the length of the encoded text.
3297 Optional third argument NO-LINE-BREAK means do not break long lines
3298 into shorter lines. */
3299 (beg
, end
, no_line_break
))
3300 Lisp_Object beg
, end
, no_line_break
;
3303 int allength
, length
;
3304 int ibeg
, iend
, encoded_length
;
3307 validate_region (&beg
, &end
);
3309 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3310 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3311 move_gap_both (XFASTINT (beg
), ibeg
);
3313 /* We need to allocate enough room for encoding the text.
3314 We need 33 1/3% more space, plus a newline every 76
3315 characters, and then we round up. */
3316 length
= iend
- ibeg
;
3317 allength
= length
+ length
/3 + 1;
3318 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3320 if (allength
<= MAX_ALLOCA
)
3321 encoded
= (char *) alloca (allength
);
3323 encoded
= (char *) xmalloc (allength
);
3324 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3325 NILP (no_line_break
),
3326 !NILP (current_buffer
->enable_multibyte_characters
));
3327 if (encoded_length
> allength
)
3330 if (encoded_length
< 0)
3332 /* The encoding wasn't possible. */
3333 if (length
> MAX_ALLOCA
)
3335 error ("Multibyte character in data for base64 encoding");
3338 /* Now we have encoded the region, so we insert the new contents
3339 and delete the old. (Insert first in order to preserve markers.) */
3340 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3341 insert (encoded
, encoded_length
);
3342 if (allength
> MAX_ALLOCA
)
3344 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3346 /* If point was outside of the region, restore it exactly; else just
3347 move to the beginning of the region. */
3348 if (old_pos
>= XFASTINT (end
))
3349 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3350 else if (old_pos
> XFASTINT (beg
))
3351 old_pos
= XFASTINT (beg
);
3354 /* We return the length of the encoded text. */
3355 return make_number (encoded_length
);
3358 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3360 /* Base64-encode STRING and return the result.
3361 Optional second argument NO-LINE-BREAK means do not break long lines
3362 into shorter lines. */
3363 (string
, no_line_break
))
3364 Lisp_Object string
, no_line_break
;
3366 int allength
, length
, encoded_length
;
3368 Lisp_Object encoded_string
;
3370 CHECK_STRING (string
, 1);
3372 /* We need to allocate enough room for encoding the text.
3373 We need 33 1/3% more space, plus a newline every 76
3374 characters, and then we round up. */
3375 length
= STRING_BYTES (XSTRING (string
));
3376 allength
= length
+ length
/3 + 1;
3377 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3379 /* We need to allocate enough room for decoding the text. */
3380 if (allength
<= MAX_ALLOCA
)
3381 encoded
= (char *) alloca (allength
);
3383 encoded
= (char *) xmalloc (allength
);
3385 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3386 encoded
, length
, NILP (no_line_break
),
3387 STRING_MULTIBYTE (string
));
3388 if (encoded_length
> allength
)
3391 if (encoded_length
< 0)
3393 /* The encoding wasn't possible. */
3394 if (length
> MAX_ALLOCA
)
3396 error ("Multibyte character in data for base64 encoding");
3399 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3400 if (allength
> MAX_ALLOCA
)
3403 return encoded_string
;
3407 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3414 int counter
= 0, i
= 0;
3424 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3432 /* Wrap line every 76 characters. */
3436 if (counter
< MIME_LINE_LENGTH
/ 4)
3445 /* Process first byte of a triplet. */
3447 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3448 value
= (0x03 & c
) << 4;
3450 /* Process second byte of a triplet. */
3454 *e
++ = base64_value_to_char
[value
];
3462 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3470 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3471 value
= (0x0f & c
) << 2;
3473 /* Process third byte of a triplet. */
3477 *e
++ = base64_value_to_char
[value
];
3484 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3492 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3493 *e
++ = base64_value_to_char
[0x3f & c
];
3500 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3502 /* Base64-decode the region between BEG and END.
3503 Return the length of the decoded text.
3504 If the region can't be decoded, signal an error and don't modify the buffer. */
3506 Lisp_Object beg
, end
;
3508 int ibeg
, iend
, length
, allength
;
3513 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3515 validate_region (&beg
, &end
);
3517 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3518 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3520 length
= iend
- ibeg
;
3522 /* We need to allocate enough room for decoding the text. If we are
3523 working on a multibyte buffer, each decoded code may occupy at
3525 allength
= multibyte
? length
* 2 : length
;
3526 if (allength
<= MAX_ALLOCA
)
3527 decoded
= (char *) alloca (allength
);
3529 decoded
= (char *) xmalloc (allength
);
3531 move_gap_both (XFASTINT (beg
), ibeg
);
3532 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3533 multibyte
, &inserted_chars
);
3534 if (decoded_length
> allength
)
3537 if (decoded_length
< 0)
3539 /* The decoding wasn't possible. */
3540 if (allength
> MAX_ALLOCA
)
3542 error ("Invalid base64 data");
3545 /* Now we have decoded the region, so we insert the new contents
3546 and delete the old. (Insert first in order to preserve markers.) */
3547 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3548 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3549 if (allength
> MAX_ALLOCA
)
3551 /* Delete the original text. */
3552 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3553 iend
+ decoded_length
, 1);
3555 /* If point was outside of the region, restore it exactly; else just
3556 move to the beginning of the region. */
3557 if (old_pos
>= XFASTINT (end
))
3558 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3559 else if (old_pos
> XFASTINT (beg
))
3560 old_pos
= XFASTINT (beg
);
3561 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3563 return make_number (inserted_chars
);
3566 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3568 /* Base64-decode STRING and return the result. */
3573 int length
, decoded_length
;
3574 Lisp_Object decoded_string
;
3576 CHECK_STRING (string
, 1);
3578 length
= STRING_BYTES (XSTRING (string
));
3579 /* We need to allocate enough room for decoding the text. */
3580 if (length
<= MAX_ALLOCA
)
3581 decoded
= (char *) alloca (length
);
3583 decoded
= (char *) xmalloc (length
);
3585 /* The decoded result should be unibyte. */
3586 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3588 if (decoded_length
> length
)
3590 else if (decoded_length
>= 0)
3591 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3593 decoded_string
= Qnil
;
3595 if (length
> MAX_ALLOCA
)
3597 if (!STRINGP (decoded_string
))
3598 error ("Invalid base64 data");
3600 return decoded_string
;
3603 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3604 MULTIBYTE is nonzero, the decoded result should be in multibyte
3605 form. If NCHARS_RETRUN is not NULL, store the number of produced
3606 characters in *NCHARS_RETURN. */
3609 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3619 unsigned long value
;
3624 /* Process first byte of a quadruplet. */
3626 READ_QUADRUPLET_BYTE (e
-to
);
3630 value
= base64_char_to_value
[c
] << 18;
3632 /* Process second byte of a quadruplet. */
3634 READ_QUADRUPLET_BYTE (-1);
3638 value
|= base64_char_to_value
[c
] << 12;
3640 c
= (unsigned char) (value
>> 16);
3642 e
+= CHAR_STRING (c
, e
);
3647 /* Process third byte of a quadruplet. */
3649 READ_QUADRUPLET_BYTE (-1);
3653 READ_QUADRUPLET_BYTE (-1);
3662 value
|= base64_char_to_value
[c
] << 6;
3664 c
= (unsigned char) (0xff & value
>> 8);
3666 e
+= CHAR_STRING (c
, e
);
3671 /* Process fourth byte of a quadruplet. */
3673 READ_QUADRUPLET_BYTE (-1);
3680 value
|= base64_char_to_value
[c
];
3682 c
= (unsigned char) (0xff & value
);
3684 e
+= CHAR_STRING (c
, e
);
3693 /***********************************************************************
3695 ***** Hash Tables *****
3697 ***********************************************************************/
3699 /* Implemented by gerd@gnu.org. This hash table implementation was
3700 inspired by CMUCL hash tables. */
3704 1. For small tables, association lists are probably faster than
3705 hash tables because they have lower overhead.
3707 For uses of hash tables where the O(1) behavior of table
3708 operations is not a requirement, it might therefore be a good idea
3709 not to hash. Instead, we could just do a linear search in the
3710 key_and_value vector of the hash table. This could be done
3711 if a `:linear-search t' argument is given to make-hash-table. */
3714 /* Value is the key part of entry IDX in hash table H. */
3716 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3718 /* Value is the value part of entry IDX in hash table H. */
3720 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3722 /* Value is the index of the next entry following the one at IDX
3725 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3727 /* Value is the hash code computed for entry IDX in hash table H. */
3729 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3731 /* Value is the index of the element in hash table H that is the
3732 start of the collision list at index IDX in the index vector of H. */
3734 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3736 /* Value is the size of hash table H. */
3738 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3740 /* The list of all weak hash tables. Don't staticpro this one. */
3742 Lisp_Object Vweak_hash_tables
;
3744 /* Various symbols. */
3746 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3747 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3748 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3750 /* Function prototypes. */
3752 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3753 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3754 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3755 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3756 Lisp_Object
, unsigned));
3757 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3758 Lisp_Object
, unsigned));
3759 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3760 unsigned, Lisp_Object
, unsigned));
3761 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3762 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3763 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3764 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3766 static unsigned sxhash_string
P_ ((unsigned char *, int));
3767 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3768 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3769 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3770 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3774 /***********************************************************************
3776 ***********************************************************************/
3778 /* If OBJ is a Lisp hash table, return a pointer to its struct
3779 Lisp_Hash_Table. Otherwise, signal an error. */
3781 static struct Lisp_Hash_Table
*
3782 check_hash_table (obj
)
3785 CHECK_HASH_TABLE (obj
, 0);
3786 return XHASH_TABLE (obj
);
3790 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3794 next_almost_prime (n
)
3807 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3808 which USED[I] is non-zero. If found at index I in ARGS, set
3809 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3810 -1. This function is used to extract a keyword/argument pair from
3811 a DEFUN parameter list. */
3814 get_key_arg (key
, nargs
, args
, used
)
3822 for (i
= 0; i
< nargs
- 1; ++i
)
3823 if (!used
[i
] && EQ (args
[i
], key
))
3838 /* Return a Lisp vector which has the same contents as VEC but has
3839 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3840 vector that are not copied from VEC are set to INIT. */
3843 larger_vector (vec
, new_size
, init
)
3848 struct Lisp_Vector
*v
;
3851 xassert (VECTORP (vec
));
3852 old_size
= XVECTOR (vec
)->size
;
3853 xassert (new_size
>= old_size
);
3855 v
= allocate_vector (new_size
);
3856 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3857 old_size
* sizeof *v
->contents
);
3858 for (i
= old_size
; i
< new_size
; ++i
)
3859 v
->contents
[i
] = init
;
3860 XSETVECTOR (vec
, v
);
3865 /***********************************************************************
3867 ***********************************************************************/
3869 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3870 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3871 KEY2 are the same. */
3874 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3875 struct Lisp_Hash_Table
*h
;
3876 Lisp_Object key1
, key2
;
3877 unsigned hash1
, hash2
;
3879 return (FLOATP (key1
)
3881 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3885 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3886 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3887 KEY2 are the same. */
3890 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3891 struct Lisp_Hash_Table
*h
;
3892 Lisp_Object key1
, key2
;
3893 unsigned hash1
, hash2
;
3895 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3899 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3900 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3901 if KEY1 and KEY2 are the same. */
3904 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3905 struct Lisp_Hash_Table
*h
;
3906 Lisp_Object key1
, key2
;
3907 unsigned hash1
, hash2
;
3911 Lisp_Object args
[3];
3913 args
[0] = h
->user_cmp_function
;
3916 return !NILP (Ffuncall (3, args
));
3923 /* Value is a hash code for KEY for use in hash table H which uses
3924 `eq' to compare keys. The hash code returned is guaranteed to fit
3925 in a Lisp integer. */
3929 struct Lisp_Hash_Table
*h
;
3932 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3933 xassert ((hash
& ~VALMASK
) == 0);
3938 /* Value is a hash code for KEY for use in hash table H which uses
3939 `eql' to compare keys. The hash code returned is guaranteed to fit
3940 in a Lisp integer. */
3944 struct Lisp_Hash_Table
*h
;
3949 hash
= sxhash (key
, 0);
3951 hash
= XUINT (key
) ^ XGCTYPE (key
);
3952 xassert ((hash
& ~VALMASK
) == 0);
3957 /* Value is a hash code for KEY for use in hash table H which uses
3958 `equal' to compare keys. The hash code returned is guaranteed to fit
3959 in a Lisp integer. */
3962 hashfn_equal (h
, key
)
3963 struct Lisp_Hash_Table
*h
;
3966 unsigned hash
= sxhash (key
, 0);
3967 xassert ((hash
& ~VALMASK
) == 0);
3972 /* Value is a hash code for KEY for use in hash table H which uses as
3973 user-defined function to compare keys. The hash code returned is
3974 guaranteed to fit in a Lisp integer. */
3977 hashfn_user_defined (h
, key
)
3978 struct Lisp_Hash_Table
*h
;
3981 Lisp_Object args
[2], hash
;
3983 args
[0] = h
->user_hash_function
;
3985 hash
= Ffuncall (2, args
);
3986 if (!INTEGERP (hash
))
3988 list2 (build_string ("Invalid hash code returned from \
3989 user-supplied hash function"),
3991 return XUINT (hash
);
3995 /* Create and initialize a new hash table.
3997 TEST specifies the test the hash table will use to compare keys.
3998 It must be either one of the predefined tests `eq', `eql' or
3999 `equal' or a symbol denoting a user-defined test named TEST with
4000 test and hash functions USER_TEST and USER_HASH.
4002 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4004 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4005 new size when it becomes full is computed by adding REHASH_SIZE to
4006 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4007 table's new size is computed by multiplying its old size with
4010 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4011 be resized when the ratio of (number of entries in the table) /
4012 (table size) is >= REHASH_THRESHOLD.
4014 WEAK specifies the weakness of the table. If non-nil, it must be
4015 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4018 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4019 user_test
, user_hash
)
4020 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4021 Lisp_Object user_test
, user_hash
;
4023 struct Lisp_Hash_Table
*h
;
4025 int index_size
, i
, sz
;
4027 /* Preconditions. */
4028 xassert (SYMBOLP (test
));
4029 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4030 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4031 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4032 xassert (FLOATP (rehash_threshold
)
4033 && XFLOATINT (rehash_threshold
) > 0
4034 && XFLOATINT (rehash_threshold
) <= 1.0);
4036 if (XFASTINT (size
) == 0)
4037 size
= make_number (1);
4039 /* Allocate a table and initialize it. */
4040 h
= allocate_hash_table ();
4042 /* Initialize hash table slots. */
4043 sz
= XFASTINT (size
);
4046 if (EQ (test
, Qeql
))
4048 h
->cmpfn
= cmpfn_eql
;
4049 h
->hashfn
= hashfn_eql
;
4051 else if (EQ (test
, Qeq
))
4054 h
->hashfn
= hashfn_eq
;
4056 else if (EQ (test
, Qequal
))
4058 h
->cmpfn
= cmpfn_equal
;
4059 h
->hashfn
= hashfn_equal
;
4063 h
->user_cmp_function
= user_test
;
4064 h
->user_hash_function
= user_hash
;
4065 h
->cmpfn
= cmpfn_user_defined
;
4066 h
->hashfn
= hashfn_user_defined
;
4070 h
->rehash_threshold
= rehash_threshold
;
4071 h
->rehash_size
= rehash_size
;
4072 h
->count
= make_number (0);
4073 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4074 h
->hash
= Fmake_vector (size
, Qnil
);
4075 h
->next
= Fmake_vector (size
, Qnil
);
4076 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4077 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4078 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4080 /* Set up the free list. */
4081 for (i
= 0; i
< sz
- 1; ++i
)
4082 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4083 h
->next_free
= make_number (0);
4085 XSET_HASH_TABLE (table
, h
);
4086 xassert (HASH_TABLE_P (table
));
4087 xassert (XHASH_TABLE (table
) == h
);
4089 /* Maybe add this hash table to the list of all weak hash tables. */
4091 h
->next_weak
= Qnil
;
4094 h
->next_weak
= Vweak_hash_tables
;
4095 Vweak_hash_tables
= table
;
4102 /* Return a copy of hash table H1. Keys and values are not copied,
4103 only the table itself is. */
4106 copy_hash_table (h1
)
4107 struct Lisp_Hash_Table
*h1
;
4110 struct Lisp_Hash_Table
*h2
;
4111 struct Lisp_Vector
*v
, *next
;
4113 h2
= allocate_hash_table ();
4114 next
= h2
->vec_next
;
4115 bcopy (h1
, h2
, sizeof *h2
);
4116 h2
->vec_next
= next
;
4117 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4118 h2
->hash
= Fcopy_sequence (h1
->hash
);
4119 h2
->next
= Fcopy_sequence (h1
->next
);
4120 h2
->index
= Fcopy_sequence (h1
->index
);
4121 XSET_HASH_TABLE (table
, h2
);
4123 /* Maybe add this hash table to the list of all weak hash tables. */
4124 if (!NILP (h2
->weak
))
4126 h2
->next_weak
= Vweak_hash_tables
;
4127 Vweak_hash_tables
= table
;
4134 /* Resize hash table H if it's too full. If H cannot be resized
4135 because it's already too large, throw an error. */
4138 maybe_resize_hash_table (h
)
4139 struct Lisp_Hash_Table
*h
;
4141 if (NILP (h
->next_free
))
4143 int old_size
= HASH_TABLE_SIZE (h
);
4144 int i
, new_size
, index_size
;
4146 if (INTEGERP (h
->rehash_size
))
4147 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4149 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4150 new_size
= max (old_size
+ 1, new_size
);
4151 index_size
= next_almost_prime ((int)
4153 / XFLOATINT (h
->rehash_threshold
)));
4154 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4155 error ("Hash table too large to resize");
4157 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4158 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4159 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4160 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4162 /* Update the free list. Do it so that new entries are added at
4163 the end of the free list. This makes some operations like
4165 for (i
= old_size
; i
< new_size
- 1; ++i
)
4166 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4168 if (!NILP (h
->next_free
))
4170 Lisp_Object last
, next
;
4172 last
= h
->next_free
;
4173 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4177 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4180 XSETFASTINT (h
->next_free
, old_size
);
4183 for (i
= 0; i
< old_size
; ++i
)
4184 if (!NILP (HASH_HASH (h
, i
)))
4186 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4187 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4188 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4189 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4195 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4196 the hash code of KEY. Value is the index of the entry in H
4197 matching KEY, or -1 if not found. */
4200 hash_lookup (h
, key
, hash
)
4201 struct Lisp_Hash_Table
*h
;
4206 int start_of_bucket
;
4209 hash_code
= h
->hashfn (h
, key
);
4213 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4214 idx
= HASH_INDEX (h
, start_of_bucket
);
4216 /* We need not gcpro idx since it's either an integer or nil. */
4219 int i
= XFASTINT (idx
);
4220 if (EQ (key
, HASH_KEY (h
, i
))
4222 && h
->cmpfn (h
, key
, hash_code
,
4223 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4225 idx
= HASH_NEXT (h
, i
);
4228 return NILP (idx
) ? -1 : XFASTINT (idx
);
4232 /* Put an entry into hash table H that associates KEY with VALUE.
4233 HASH is a previously computed hash code of KEY.
4234 Value is the index of the entry in H matching KEY. */
4237 hash_put (h
, key
, value
, hash
)
4238 struct Lisp_Hash_Table
*h
;
4239 Lisp_Object key
, value
;
4242 int start_of_bucket
, i
;
4244 xassert ((hash
& ~VALMASK
) == 0);
4246 /* Increment count after resizing because resizing may fail. */
4247 maybe_resize_hash_table (h
);
4248 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4250 /* Store key/value in the key_and_value vector. */
4251 i
= XFASTINT (h
->next_free
);
4252 h
->next_free
= HASH_NEXT (h
, i
);
4253 HASH_KEY (h
, i
) = key
;
4254 HASH_VALUE (h
, i
) = value
;
4256 /* Remember its hash code. */
4257 HASH_HASH (h
, i
) = make_number (hash
);
4259 /* Add new entry to its collision chain. */
4260 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4261 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4262 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4267 /* Remove the entry matching KEY from hash table H, if there is one. */
4270 hash_remove (h
, key
)
4271 struct Lisp_Hash_Table
*h
;
4275 int start_of_bucket
;
4276 Lisp_Object idx
, prev
;
4278 hash_code
= h
->hashfn (h
, key
);
4279 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4280 idx
= HASH_INDEX (h
, start_of_bucket
);
4283 /* We need not gcpro idx, prev since they're either integers or nil. */
4286 int i
= XFASTINT (idx
);
4288 if (EQ (key
, HASH_KEY (h
, i
))
4290 && h
->cmpfn (h
, key
, hash_code
,
4291 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4293 /* Take entry out of collision chain. */
4295 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4297 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4299 /* Clear slots in key_and_value and add the slots to
4301 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4302 HASH_NEXT (h
, i
) = h
->next_free
;
4303 h
->next_free
= make_number (i
);
4304 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4305 xassert (XINT (h
->count
) >= 0);
4311 idx
= HASH_NEXT (h
, i
);
4317 /* Clear hash table H. */
4321 struct Lisp_Hash_Table
*h
;
4323 if (XFASTINT (h
->count
) > 0)
4325 int i
, size
= HASH_TABLE_SIZE (h
);
4327 for (i
= 0; i
< size
; ++i
)
4329 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4330 HASH_KEY (h
, i
) = Qnil
;
4331 HASH_VALUE (h
, i
) = Qnil
;
4332 HASH_HASH (h
, i
) = Qnil
;
4335 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4336 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4338 h
->next_free
= make_number (0);
4339 h
->count
= make_number (0);
4345 /************************************************************************
4347 ************************************************************************/
4349 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4350 entries from the table that don't survive the current GC.
4351 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4352 non-zero if anything was marked. */
4355 sweep_weak_table (h
, remove_entries_p
)
4356 struct Lisp_Hash_Table
*h
;
4357 int remove_entries_p
;
4359 int bucket
, n
, marked
;
4361 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4364 for (bucket
= 0; bucket
< n
; ++bucket
)
4366 Lisp_Object idx
, next
, prev
;
4368 /* Follow collision chain, removing entries that
4369 don't survive this garbage collection. */
4371 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4373 int i
= XFASTINT (idx
);
4374 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4375 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4378 if (EQ (h
->weak
, Qkey
))
4379 remove_p
= !key_known_to_survive_p
;
4380 else if (EQ (h
->weak
, Qvalue
))
4381 remove_p
= !value_known_to_survive_p
;
4382 else if (EQ (h
->weak
, Qkey_or_value
))
4383 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4384 else if (EQ (h
->weak
, Qkey_and_value
))
4385 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4389 next
= HASH_NEXT (h
, i
);
4391 if (remove_entries_p
)
4395 /* Take out of collision chain. */
4397 HASH_INDEX (h
, bucket
) = next
;
4399 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4401 /* Add to free list. */
4402 HASH_NEXT (h
, i
) = h
->next_free
;
4405 /* Clear key, value, and hash. */
4406 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4407 HASH_HASH (h
, i
) = Qnil
;
4409 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4416 /* Make sure key and value survive. */
4417 if (!key_known_to_survive_p
)
4419 mark_object (&HASH_KEY (h
, i
));
4423 if (!value_known_to_survive_p
)
4425 mark_object (&HASH_VALUE (h
, i
));
4436 /* Remove elements from weak hash tables that don't survive the
4437 current garbage collection. Remove weak tables that don't survive
4438 from Vweak_hash_tables. Called from gc_sweep. */
4441 sweep_weak_hash_tables ()
4443 Lisp_Object table
, used
, next
;
4444 struct Lisp_Hash_Table
*h
;
4447 /* Mark all keys and values that are in use. Keep on marking until
4448 there is no more change. This is necessary for cases like
4449 value-weak table A containing an entry X -> Y, where Y is used in a
4450 key-weak table B, Z -> Y. If B comes after A in the list of weak
4451 tables, X -> Y might be removed from A, although when looking at B
4452 one finds that it shouldn't. */
4456 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4458 h
= XHASH_TABLE (table
);
4459 if (h
->size
& ARRAY_MARK_FLAG
)
4460 marked
|= sweep_weak_table (h
, 0);
4465 /* Remove tables and entries that aren't used. */
4466 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4468 h
= XHASH_TABLE (table
);
4469 next
= h
->next_weak
;
4471 if (h
->size
& ARRAY_MARK_FLAG
)
4473 /* TABLE is marked as used. Sweep its contents. */
4474 if (XFASTINT (h
->count
) > 0)
4475 sweep_weak_table (h
, 1);
4477 /* Add table to the list of used weak hash tables. */
4478 h
->next_weak
= used
;
4483 Vweak_hash_tables
= used
;
4488 /***********************************************************************
4489 Hash Code Computation
4490 ***********************************************************************/
4492 /* Maximum depth up to which to dive into Lisp structures. */
4494 #define SXHASH_MAX_DEPTH 3
4496 /* Maximum length up to which to take list and vector elements into
4499 #define SXHASH_MAX_LEN 7
4501 /* Combine two integers X and Y for hashing. */
4503 #define SXHASH_COMBINE(X, Y) \
4504 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4508 /* Return a hash for string PTR which has length LEN. The hash
4509 code returned is guaranteed to fit in a Lisp integer. */
4512 sxhash_string (ptr
, len
)
4516 unsigned char *p
= ptr
;
4517 unsigned char *end
= p
+ len
;
4526 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4529 return hash
& VALMASK
;
4533 /* Return a hash for list LIST. DEPTH is the current depth in the
4534 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4537 sxhash_list (list
, depth
)
4544 if (depth
< SXHASH_MAX_DEPTH
)
4546 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4547 list
= XCDR (list
), ++i
)
4549 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4550 hash
= SXHASH_COMBINE (hash
, hash2
);
4557 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4558 the Lisp structure. */
4561 sxhash_vector (vec
, depth
)
4565 unsigned hash
= XVECTOR (vec
)->size
;
4568 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4569 for (i
= 0; i
< n
; ++i
)
4571 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4572 hash
= SXHASH_COMBINE (hash
, hash2
);
4579 /* Return a hash for bool-vector VECTOR. */
4582 sxhash_bool_vector (vec
)
4585 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4588 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4589 for (i
= 0; i
< n
; ++i
)
4590 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4596 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4597 structure. Value is an unsigned integer clipped to VALMASK. */
4606 if (depth
> SXHASH_MAX_DEPTH
)
4609 switch (XTYPE (obj
))
4616 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4617 XSYMBOL (obj
)->name
->size
);
4625 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4628 /* This can be everything from a vector to an overlay. */
4629 case Lisp_Vectorlike
:
4631 /* According to the CL HyperSpec, two arrays are equal only if
4632 they are `eq', except for strings and bit-vectors. In
4633 Emacs, this works differently. We have to compare element
4635 hash
= sxhash_vector (obj
, depth
);
4636 else if (BOOL_VECTOR_P (obj
))
4637 hash
= sxhash_bool_vector (obj
);
4639 /* Others are `equal' if they are `eq', so let's take their
4645 hash
= sxhash_list (obj
, depth
);
4650 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4651 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4652 for (hash
= 0; p
< e
; ++p
)
4653 hash
= SXHASH_COMBINE (hash
, *p
);
4661 return hash
& VALMASK
;
4666 /***********************************************************************
4668 ***********************************************************************/
4671 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4672 /* Compute a hash code for OBJ and return it as integer. */
4676 unsigned hash
= sxhash (obj
, 0);;
4677 return make_number (hash
);
4681 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4682 /* Create and return a new hash table.
4684 Arguments are specified as keyword/argument pairs. The following
4685 arguments are defined:
4687 :test TEST -- TEST must be a symbol that specifies how to compare
4688 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4689 `equal'. User-supplied test and hash functions can be specified via
4690 `define-hash-table-test'.
4692 :size SIZE -- A hint as to how many elements will be put in the table.
4695 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4696 fills up. If REHASH-SIZE is an integer, add that many space. If it
4697 is a float, it must be > 1.0, and the new size is computed by
4698 multiplying the old size with that factor. Default is 1.5.
4700 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4701 Resize the hash table when ratio of the number of entries in the
4702 table. Default is 0.8.
4704 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4705 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4706 returned is a weak table. Key/value pairs are removed from a weak
4707 hash table when there are no non-weak references pointing to their
4708 key, value, one of key or value, or both key and value, depending on
4709 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4715 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4716 Lisp_Object user_test
, user_hash
;
4720 /* The vector `used' is used to keep track of arguments that
4721 have been consumed. */
4722 used
= (char *) alloca (nargs
* sizeof *used
);
4723 bzero (used
, nargs
* sizeof *used
);
4725 /* See if there's a `:test TEST' among the arguments. */
4726 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4727 test
= i
< 0 ? Qeql
: args
[i
];
4728 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4730 /* See if it is a user-defined test. */
4733 prop
= Fget (test
, Qhash_table_test
);
4734 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4735 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4737 user_test
= Fnth (make_number (0), prop
);
4738 user_hash
= Fnth (make_number (1), prop
);
4741 user_test
= user_hash
= Qnil
;
4743 /* See if there's a `:size SIZE' argument. */
4744 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4745 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4746 if (!INTEGERP (size
) || XINT (size
) < 0)
4748 list2 (build_string ("Invalid hash table size"),
4751 /* Look for `:rehash-size SIZE'. */
4752 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4753 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4754 if (!NUMBERP (rehash_size
)
4755 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4756 || XFLOATINT (rehash_size
) <= 1.0)
4758 list2 (build_string ("Invalid hash table rehash size"),
4761 /* Look for `:rehash-threshold THRESHOLD'. */
4762 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4763 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4764 if (!FLOATP (rehash_threshold
)
4765 || XFLOATINT (rehash_threshold
) <= 0.0
4766 || XFLOATINT (rehash_threshold
) > 1.0)
4768 list2 (build_string ("Invalid hash table rehash threshold"),
4771 /* Look for `:weakness WEAK'. */
4772 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4773 weak
= i
< 0 ? Qnil
: args
[i
];
4775 weak
= Qkey_and_value
;
4778 && !EQ (weak
, Qvalue
)
4779 && !EQ (weak
, Qkey_or_value
)
4780 && !EQ (weak
, Qkey_and_value
))
4781 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4784 /* Now, all args should have been used up, or there's a problem. */
4785 for (i
= 0; i
< nargs
; ++i
)
4788 list2 (build_string ("Invalid argument list"), args
[i
]));
4790 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4791 user_test
, user_hash
);
4795 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4796 /* Return a copy of hash table TABLE. */
4800 return copy_hash_table (check_hash_table (table
));
4804 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4805 /* Create a new hash table.
4807 Optional first argument TEST specifies how to compare keys in the
4808 table. Predefined tests are `eq', `eql', and `equal'. Default is
4809 `eql'. New tests can be defined with `define-hash-table-test'. */
4813 Lisp_Object args
[2];
4815 args
[1] = NILP (test
) ? Qeql
: test
;
4816 return Fmake_hash_table (2, args
);
4820 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4821 /* Return the number of elements in TABLE. */
4825 return check_hash_table (table
)->count
;
4829 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4830 Shash_table_rehash_size
, 1, 1, 0,
4831 /* Return the current rehash size of TABLE. */
4835 return check_hash_table (table
)->rehash_size
;
4839 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4840 Shash_table_rehash_threshold
, 1, 1, 0,
4841 /* Return the current rehash threshold of TABLE. */
4845 return check_hash_table (table
)->rehash_threshold
;
4849 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4850 /* Return the size of TABLE.
4851 The size can be used as an argument to `make-hash-table' to create
4852 a hash table than can hold as many elements of TABLE holds
4853 without need for resizing. */
4857 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4858 return make_number (HASH_TABLE_SIZE (h
));
4862 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4863 /* Return the test TABLE uses. */
4867 return check_hash_table (table
)->test
;
4871 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4873 /* Return the weakness of TABLE. */
4877 return check_hash_table (table
)->weak
;
4881 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4882 /* Return t if OBJ is a Lisp hash table object. */
4886 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4890 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4891 /* Clear hash table TABLE. */
4895 hash_clear (check_hash_table (table
));
4900 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4901 /* Look up KEY in TABLE and return its associated value.
4902 If KEY is not found, return DFLT which defaults to nil. */
4904 Lisp_Object key
, table
, dflt
;
4906 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4907 int i
= hash_lookup (h
, key
, NULL
);
4908 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4912 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4913 /* Associate KEY with VALUE in hash table TABLE.
4914 If KEY is already present in table, replace its current value with
4916 (key
, value
, table
))
4917 Lisp_Object key
, value
, table
;
4919 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4923 i
= hash_lookup (h
, key
, &hash
);
4925 HASH_VALUE (h
, i
) = value
;
4927 hash_put (h
, key
, value
, hash
);
4933 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4934 /* Remove KEY from TABLE. */
4936 Lisp_Object key
, table
;
4938 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4939 hash_remove (h
, key
);
4944 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4945 /* Call FUNCTION for all entries in hash table TABLE.
4946 FUNCTION is called with 2 arguments KEY and VALUE. */
4948 Lisp_Object function
, table
;
4950 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4951 Lisp_Object args
[3];
4954 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4955 if (!NILP (HASH_HASH (h
, i
)))
4958 args
[1] = HASH_KEY (h
, i
);
4959 args
[2] = HASH_VALUE (h
, i
);
4967 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4968 Sdefine_hash_table_test
, 3, 3, 0,
4969 /* Define a new hash table test with name NAME, a symbol.
4971 In hash tables created with NAME specified as test, use TEST to
4972 compare keys, and HASH for computing hash codes of keys.
4974 TEST must be a function taking two arguments and returning non-nil if
4975 both arguments are the same. HASH must be a function taking one
4976 argument and return an integer that is the hash code of the argument.
4977 Hash code computation should use the whole value range of integers,
4978 including negative integers. */
4980 Lisp_Object name
, test
, hash
;
4982 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4987 /************************************************************************
4989 ************************************************************************/
4994 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4995 /* Return MD5 message digest of OBJECT, a buffer or string.
4997 A message digest is a cryptographic checksum of a document, and the
4998 algorithm to calculate it is defined in RFC 1321.
5000 The two optional arguments START and END are character positions
5001 specifying for which part of OBJECT the message digest should be
5002 computed. If nil or omitted, the digest is computed for the whole
5005 The MD5 message digest is computed from the result of encoding the
5006 text in a coding system, not directly from the internal Emacs form of
5007 the text. The optional fourth argument CODING-SYSTEM specifies which
5008 coding system to encode the text with. It should be the same coding
5009 system that you used or will use when actually writing the text into a
5012 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5013 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5014 system would be chosen by default for writing this text into a file.
5016 If OBJECT is a string, the most preferred coding system (see the
5017 command `prefer-coding-system') is used.
5019 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5020 guesswork fails. Normally, an error is signaled in such case. */
5021 (object
, start
, end
, coding_system
, noerror
))
5022 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5024 unsigned char digest
[16];
5025 unsigned char value
[33];
5029 int start_char
= 0, end_char
= 0;
5030 int start_byte
= 0, end_byte
= 0;
5032 register struct buffer
*bp
;
5035 if (STRINGP (object
))
5037 if (NILP (coding_system
))
5039 /* Decide the coding-system to encode the data with. */
5041 if (STRING_MULTIBYTE (object
))
5042 /* use default, we can't guess correct value */
5043 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5045 coding_system
= Qraw_text
;
5048 if (NILP (Fcoding_system_p (coding_system
)))
5050 /* Invalid coding system. */
5052 if (!NILP (noerror
))
5053 coding_system
= Qraw_text
;
5056 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5059 if (STRING_MULTIBYTE (object
))
5060 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5062 size
= XSTRING (object
)->size
;
5063 size_byte
= STRING_BYTES (XSTRING (object
));
5067 CHECK_NUMBER (start
, 1);
5069 start_char
= XINT (start
);
5074 start_byte
= string_char_to_byte (object
, start_char
);
5080 end_byte
= size_byte
;
5084 CHECK_NUMBER (end
, 2);
5086 end_char
= XINT (end
);
5091 end_byte
= string_char_to_byte (object
, end_char
);
5094 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5095 args_out_of_range_3 (object
, make_number (start_char
),
5096 make_number (end_char
));
5100 CHECK_BUFFER (object
, 0);
5102 bp
= XBUFFER (object
);
5108 CHECK_NUMBER_COERCE_MARKER (start
, 0);
5116 CHECK_NUMBER_COERCE_MARKER (end
, 1);
5121 temp
= b
, b
= e
, e
= temp
;
5123 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5124 args_out_of_range (start
, end
);
5126 if (NILP (coding_system
))
5128 /* Decide the coding-system to encode the data with.
5129 See fileio.c:Fwrite-region */
5131 if (!NILP (Vcoding_system_for_write
))
5132 coding_system
= Vcoding_system_for_write
;
5135 int force_raw_text
= 0;
5137 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5138 if (NILP (coding_system
)
5139 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5141 coding_system
= Qnil
;
5142 if (NILP (current_buffer
->enable_multibyte_characters
))
5146 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5148 /* Check file-coding-system-alist. */
5149 Lisp_Object args
[4], val
;
5151 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5152 args
[3] = Fbuffer_file_name(object
);
5153 val
= Ffind_operation_coding_system (4, args
);
5154 if (CONSP (val
) && !NILP (XCDR (val
)))
5155 coding_system
= XCDR (val
);
5158 if (NILP (coding_system
)
5159 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5161 /* If we still have not decided a coding system, use the
5162 default value of buffer-file-coding-system. */
5163 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5167 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5168 /* Confirm that VAL can surely encode the current region. */
5169 coding_system
= call3 (Vselect_safe_coding_system_function
,
5170 make_number (b
), make_number (e
),
5174 coding_system
= Qraw_text
;
5177 if (NILP (Fcoding_system_p (coding_system
)))
5179 /* Invalid coding system. */
5181 if (!NILP (noerror
))
5182 coding_system
= Qraw_text
;
5185 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5189 object
= make_buffer_string (b
, e
, 0);
5191 if (STRING_MULTIBYTE (object
))
5192 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5195 md5_buffer (XSTRING (object
)->data
+ start_byte
,
5196 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
5199 for (i
= 0; i
< 16; i
++)
5200 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5203 return make_string (value
, 32);
5210 /* Hash table stuff. */
5211 Qhash_table_p
= intern ("hash-table-p");
5212 staticpro (&Qhash_table_p
);
5213 Qeq
= intern ("eq");
5215 Qeql
= intern ("eql");
5217 Qequal
= intern ("equal");
5218 staticpro (&Qequal
);
5219 QCtest
= intern (":test");
5220 staticpro (&QCtest
);
5221 QCsize
= intern (":size");
5222 staticpro (&QCsize
);
5223 QCrehash_size
= intern (":rehash-size");
5224 staticpro (&QCrehash_size
);
5225 QCrehash_threshold
= intern (":rehash-threshold");
5226 staticpro (&QCrehash_threshold
);
5227 QCweakness
= intern (":weakness");
5228 staticpro (&QCweakness
);
5229 Qkey
= intern ("key");
5231 Qvalue
= intern ("value");
5232 staticpro (&Qvalue
);
5233 Qhash_table_test
= intern ("hash-table-test");
5234 staticpro (&Qhash_table_test
);
5235 Qkey_or_value
= intern ("key-or-value");
5236 staticpro (&Qkey_or_value
);
5237 Qkey_and_value
= intern ("key-and-value");
5238 staticpro (&Qkey_and_value
);
5241 defsubr (&Smake_hash_table
);
5242 defsubr (&Scopy_hash_table
);
5243 defsubr (&Smakehash
);
5244 defsubr (&Shash_table_count
);
5245 defsubr (&Shash_table_rehash_size
);
5246 defsubr (&Shash_table_rehash_threshold
);
5247 defsubr (&Shash_table_size
);
5248 defsubr (&Shash_table_test
);
5249 defsubr (&Shash_table_weakness
);
5250 defsubr (&Shash_table_p
);
5251 defsubr (&Sclrhash
);
5252 defsubr (&Sgethash
);
5253 defsubr (&Sputhash
);
5254 defsubr (&Sremhash
);
5255 defsubr (&Smaphash
);
5256 defsubr (&Sdefine_hash_table_test
);
5258 Qstring_lessp
= intern ("string-lessp");
5259 staticpro (&Qstring_lessp
);
5260 Qprovide
= intern ("provide");
5261 staticpro (&Qprovide
);
5262 Qrequire
= intern ("require");
5263 staticpro (&Qrequire
);
5264 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5265 staticpro (&Qyes_or_no_p_history
);
5266 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5267 staticpro (&Qcursor_in_echo_area
);
5268 Qwidget_type
= intern ("widget-type");
5269 staticpro (&Qwidget_type
);
5271 staticpro (&string_char_byte_cache_string
);
5272 string_char_byte_cache_string
= Qnil
;
5274 Fset (Qyes_or_no_p_history
, Qnil
);
5276 DEFVAR_LISP ("features", &Vfeatures
5277 /* A list of symbols which are the features of the executing emacs.
5278 Used by `featurep' and `require', and altered by `provide'. */);
5280 Qsubfeatures
= intern ("subfeatures");
5281 staticpro (&Qsubfeatures
);
5283 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
5284 /* *Non-nil means mouse commands use dialog boxes to ask questions.
5285 This applies to y-or-n and yes-or-no questions asked by commands
5286 invoked by mouse clicks and mouse menu items. */);
5289 defsubr (&Sidentity
);
5292 defsubr (&Ssafe_length
);
5293 defsubr (&Sstring_bytes
);
5294 defsubr (&Sstring_equal
);
5295 defsubr (&Scompare_strings
);
5296 defsubr (&Sstring_lessp
);
5299 defsubr (&Svconcat
);
5300 defsubr (&Scopy_sequence
);
5301 defsubr (&Sstring_make_multibyte
);
5302 defsubr (&Sstring_make_unibyte
);
5303 defsubr (&Sstring_as_multibyte
);
5304 defsubr (&Sstring_as_unibyte
);
5305 defsubr (&Scopy_alist
);
5306 defsubr (&Ssubstring
);
5318 defsubr (&Snreverse
);
5319 defsubr (&Sreverse
);
5321 defsubr (&Splist_get
);
5323 defsubr (&Splist_put
);
5326 defsubr (&Sfillarray
);
5327 defsubr (&Schar_table_subtype
);
5328 defsubr (&Schar_table_parent
);
5329 defsubr (&Sset_char_table_parent
);
5330 defsubr (&Schar_table_extra_slot
);
5331 defsubr (&Sset_char_table_extra_slot
);
5332 defsubr (&Schar_table_range
);
5333 defsubr (&Sset_char_table_range
);
5334 defsubr (&Sset_char_table_default
);
5335 defsubr (&Soptimize_char_table
);
5336 defsubr (&Smap_char_table
);
5340 defsubr (&Smapconcat
);
5341 defsubr (&Sy_or_n_p
);
5342 defsubr (&Syes_or_no_p
);
5343 defsubr (&Sload_average
);
5344 defsubr (&Sfeaturep
);
5345 defsubr (&Srequire
);
5346 defsubr (&Sprovide
);
5347 defsubr (&Splist_member
);
5348 defsubr (&Swidget_put
);
5349 defsubr (&Swidget_get
);
5350 defsubr (&Swidget_apply
);
5351 defsubr (&Sbase64_encode_region
);
5352 defsubr (&Sbase64_decode_region
);
5353 defsubr (&Sbase64_encode_string
);
5354 defsubr (&Sbase64_decode_string
);
5362 Vweak_hash_tables
= Qnil
;