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. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
41 #include "intervals.h"
44 #include "blockinput.h"
45 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
50 #define NULL (void *)0
53 /* Nonzero enables use of dialog boxes for questions
54 asked by mouse commands. */
57 extern int minibuffer_auto_raise
;
58 extern Lisp_Object minibuf_window
;
60 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
61 Lisp_Object Qyes_or_no_p_history
;
62 Lisp_Object Qcursor_in_echo_area
;
63 Lisp_Object Qwidget_type
;
65 extern Lisp_Object Qinput_method_function
;
67 static int internal_equal ();
69 extern long get_random ();
70 extern void seed_random ();
76 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
77 doc
: /* Return the argument unchanged. */)
84 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
85 doc
: /* Return a pseudo-random number.
86 All integers representable in Lisp are equally likely.
87 On most systems, this is 28 bits' worth.
88 With positive integer argument N, return random number in interval [0,N).
89 With argument t, set the random number seed from the current time and pid. */)
94 Lisp_Object lispy_val
;
95 unsigned long denominator
;
98 seed_random (getpid () + time (NULL
));
99 if (NATNUMP (n
) && XFASTINT (n
) != 0)
101 /* Try to take our random number from the higher bits of VAL,
102 not the lower, since (says Gentzel) the low bits of `random'
103 are less random than the higher ones. We do this by using the
104 quotient rather than the remainder. At the high end of the RNG
105 it's possible to get a quotient larger than n; discarding
106 these values eliminates the bias that would otherwise appear
107 when using a large n. */
108 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
110 val
= get_random () / denominator
;
111 while (val
>= XFASTINT (n
));
115 XSETINT (lispy_val
, val
);
119 /* Random data-structure functions */
121 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
122 doc
: /* Return the length of vector, list or string SEQUENCE.
123 A byte-code function object is also allowed.
124 If the string contains multibyte characters, this is not the necessarily
125 the number of bytes in the string; it is the number of characters.
126 To get the number of bytes, use `string-bytes'. */)
128 register Lisp_Object sequence
;
130 register Lisp_Object val
;
134 if (STRINGP (sequence
))
135 XSETFASTINT (val
, XSTRING (sequence
)->size
);
136 else if (VECTORP (sequence
))
137 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
138 else if (CHAR_TABLE_P (sequence
))
139 XSETFASTINT (val
, MAX_CHAR
);
140 else if (BOOL_VECTOR_P (sequence
))
141 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
142 else if (COMPILEDP (sequence
))
143 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
144 else if (CONSP (sequence
))
147 while (CONSP (sequence
))
149 sequence
= XCDR (sequence
);
152 if (!CONSP (sequence
))
155 sequence
= XCDR (sequence
);
160 if (!NILP (sequence
))
161 wrong_type_argument (Qlistp
, sequence
);
163 val
= make_number (i
);
165 else if (NILP (sequence
))
166 XSETFASTINT (val
, 0);
169 sequence
= wrong_type_argument (Qsequencep
, sequence
);
175 /* This does not check for quits. That is safe
176 since it must terminate. */
178 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
179 doc
: /* Return the length of a list, but avoid error or infinite loop.
180 This function never gets an error. If LIST is not really a list,
181 it returns 0. If LIST is circular, it returns a finite value
182 which is at least the number of distinct elements. */)
186 Lisp_Object tail
, halftail
, length
;
189 /* halftail is used to detect circular lists. */
191 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
193 if (EQ (tail
, halftail
) && len
!= 0)
197 halftail
= XCDR (halftail
);
200 XSETINT (length
, len
);
204 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
205 doc
: /* Return the number of bytes in STRING.
206 If STRING is a multibyte string, this is greater than the length of STRING. */)
210 CHECK_STRING (string
);
211 return make_number (STRING_BYTES (XSTRING (string
)));
214 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
215 doc
: /* Return t if two strings have identical contents.
216 Case is significant, but text properties are ignored.
217 Symbols are also allowed; their print names are used instead. */)
219 register Lisp_Object s1
, s2
;
222 s1
= SYMBOL_NAME (s1
);
224 s2
= SYMBOL_NAME (s2
);
228 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
229 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
230 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
235 DEFUN ("compare-strings", Fcompare_strings
,
236 Scompare_strings
, 6, 7, 0,
237 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
238 In string STR1, skip the first START1 characters and stop at END1.
239 In string STR2, skip the first START2 characters and stop at END2.
240 END1 and END2 default to the full lengths of the respective strings.
242 Case is significant in this comparison if IGNORE-CASE is nil.
243 Unibyte strings are converted to multibyte for comparison.
245 The value is t if the strings (or specified portions) match.
246 If string STR1 is less, the value is a negative number N;
247 - 1 - N is the number of characters that match at the beginning.
248 If string STR1 is greater, the value is a positive number N;
249 N - 1 is the number of characters that match at the beginning. */)
250 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
251 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
253 register int end1_char
, end2_char
;
254 register int i1
, i1_byte
, i2
, i2_byte
;
259 start1
= make_number (0);
261 start2
= make_number (0);
262 CHECK_NATNUM (start1
);
263 CHECK_NATNUM (start2
);
272 i1_byte
= string_char_to_byte (str1
, i1
);
273 i2_byte
= string_char_to_byte (str2
, i2
);
275 end1_char
= XSTRING (str1
)->size
;
276 if (! NILP (end1
) && end1_char
> XINT (end1
))
277 end1_char
= XINT (end1
);
279 end2_char
= XSTRING (str2
)->size
;
280 if (! NILP (end2
) && end2_char
> XINT (end2
))
281 end2_char
= XINT (end2
);
283 while (i1
< end1_char
&& i2
< end2_char
)
285 /* When we find a mismatch, we must compare the
286 characters, not just the bytes. */
289 if (STRING_MULTIBYTE (str1
))
290 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
293 c1
= XSTRING (str1
)->data
[i1
++];
294 c1
= unibyte_char_to_multibyte (c1
);
297 if (STRING_MULTIBYTE (str2
))
298 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
301 c2
= XSTRING (str2
)->data
[i2
++];
302 c2
= unibyte_char_to_multibyte (c2
);
308 if (! NILP (ignore_case
))
312 tem
= Fupcase (make_number (c1
));
314 tem
= Fupcase (make_number (c2
));
321 /* Note that I1 has already been incremented
322 past the character that we are comparing;
323 hence we don't add or subtract 1 here. */
325 return make_number (- i1
+ XINT (start1
));
327 return make_number (i1
- XINT (start1
));
331 return make_number (i1
- XINT (start1
) + 1);
333 return make_number (- i1
+ XINT (start1
) - 1);
338 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
339 doc
: /* Return t if first arg string is less than second in lexicographic order.
341 Symbols are also allowed; their print names are used instead. */)
343 register Lisp_Object s1
, s2
;
346 register int i1
, i1_byte
, i2
, i2_byte
;
349 s1
= SYMBOL_NAME (s1
);
351 s2
= SYMBOL_NAME (s2
);
355 i1
= i1_byte
= i2
= i2_byte
= 0;
357 end
= XSTRING (s1
)->size
;
358 if (end
> XSTRING (s2
)->size
)
359 end
= XSTRING (s2
)->size
;
363 /* When we find a mismatch, we must compare the
364 characters, not just the bytes. */
367 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
368 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
371 return c1
< c2
? Qt
: Qnil
;
373 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
376 static Lisp_Object
concat ();
387 return concat (2, args
, Lisp_String
, 0);
389 return concat (2, &s1
, Lisp_String
, 0);
390 #endif /* NO_ARG_ARRAY */
396 Lisp_Object s1
, s2
, s3
;
403 return concat (3, args
, Lisp_String
, 0);
405 return concat (3, &s1
, Lisp_String
, 0);
406 #endif /* NO_ARG_ARRAY */
409 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
410 doc
: /* Concatenate all the arguments and make the result a list.
411 The result is a list whose elements are the elements of all the arguments.
412 Each argument may be a list, vector or string.
413 The last argument is not copied, just used as the tail of the new list.
414 usage: (append &rest SEQUENCES) */)
419 return concat (nargs
, args
, Lisp_Cons
, 1);
422 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
423 doc
: /* Concatenate all the arguments and make the result a string.
424 The result is a string whose elements are the elements of all the arguments.
425 Each argument may be a string or a list or vector of characters (integers).
426 usage: (concat &rest SEQUENCES) */)
431 return concat (nargs
, args
, Lisp_String
, 0);
434 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
435 doc
: /* 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.
438 usage: (vconcat &rest SEQUENCES) */)
443 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
446 /* Retrun a copy of a sub char table ARG. The elements except for a
447 nested sub char table are not copied. */
449 copy_sub_char_table (arg
)
452 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
455 /* Copy all the contents. */
456 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
457 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
458 /* Recursively copy any sub char-tables in the ordinary slots. */
459 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
460 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
461 XCHAR_TABLE (copy
)->contents
[i
]
462 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
468 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
469 doc
: /* Return a copy of a list, vector or string.
470 The elements of a list or vector are not copied; they are shared
471 with the original. */)
475 if (NILP (arg
)) return arg
;
477 if (CHAR_TABLE_P (arg
))
482 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
483 /* Copy all the slots, including the extra ones. */
484 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
485 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
486 * sizeof (Lisp_Object
)));
488 /* Recursively copy any sub char tables in the ordinary slots
489 for multibyte characters. */
490 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
491 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
492 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
493 XCHAR_TABLE (copy
)->contents
[i
]
494 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
499 if (BOOL_VECTOR_P (arg
))
503 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
505 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
506 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
511 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
512 arg
= wrong_type_argument (Qsequencep
, arg
);
513 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
516 /* In string STR of length LEN, see if bytes before STR[I] combine
517 with bytes after STR[I] to form a single character. If so, return
518 the number of bytes after STR[I] which combine in this way.
519 Otherwize, return 0. */
522 count_combining (str
, len
, i
)
526 int j
= i
- 1, bytes
;
528 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
530 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
531 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
533 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
534 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
537 /* This structure holds information of an argument of `concat' that is
538 a string and has text properties to be copied. */
541 int argnum
; /* refer to ARGS (arguments of `concat') */
542 int from
; /* refer to ARGS[argnum] (argument string) */
543 int to
; /* refer to VAL (the target string) */
547 concat (nargs
, args
, target_type
, last_special
)
550 enum Lisp_Type target_type
;
554 register Lisp_Object tail
;
555 register Lisp_Object
this;
557 int toindex_byte
= 0;
558 register int result_len
;
559 register int result_len_byte
;
561 Lisp_Object last_tail
;
564 /* When we make a multibyte string, we can't copy text properties
565 while concatinating each string because the length of resulting
566 string can't be decided until we finish the whole concatination.
567 So, we record strings that have text properties to be copied
568 here, and copy the text properties after the concatination. */
569 struct textprop_rec
*textprops
= NULL
;
570 /* Number of elments in textprops. */
571 int num_textprops
= 0;
575 /* In append, the last arg isn't treated like the others */
576 if (last_special
&& nargs
> 0)
579 last_tail
= args
[nargs
];
584 /* Canonicalize each argument. */
585 for (argnum
= 0; argnum
< nargs
; argnum
++)
588 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
589 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
591 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
595 /* Compute total length in chars of arguments in RESULT_LEN.
596 If desired output is a string, also compute length in bytes
597 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
598 whether the result should be a multibyte string. */
602 for (argnum
= 0; argnum
< nargs
; argnum
++)
606 len
= XFASTINT (Flength (this));
607 if (target_type
== Lisp_String
)
609 /* We must count the number of bytes needed in the string
610 as well as the number of characters. */
616 for (i
= 0; i
< len
; i
++)
618 ch
= XVECTOR (this)->contents
[i
];
620 wrong_type_argument (Qintegerp
, ch
);
621 this_len_byte
= CHAR_BYTES (XINT (ch
));
622 result_len_byte
+= this_len_byte
;
623 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
626 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
627 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
628 else if (CONSP (this))
629 for (; CONSP (this); this = XCDR (this))
633 wrong_type_argument (Qintegerp
, ch
);
634 this_len_byte
= CHAR_BYTES (XINT (ch
));
635 result_len_byte
+= this_len_byte
;
636 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
639 else if (STRINGP (this))
641 if (STRING_MULTIBYTE (this))
644 result_len_byte
+= STRING_BYTES (XSTRING (this));
647 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
648 XSTRING (this)->size
);
655 if (! some_multibyte
)
656 result_len_byte
= result_len
;
658 /* Create the output object. */
659 if (target_type
== Lisp_Cons
)
660 val
= Fmake_list (make_number (result_len
), Qnil
);
661 else if (target_type
== Lisp_Vectorlike
)
662 val
= Fmake_vector (make_number (result_len
), Qnil
);
663 else if (some_multibyte
)
664 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
666 val
= make_uninit_string (result_len
);
668 /* In `append', if all but last arg are nil, return last arg. */
669 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
672 /* Copy the contents of the args into the result. */
674 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
676 toindex
= 0, toindex_byte
= 0;
681 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
683 for (argnum
= 0; argnum
< nargs
; argnum
++)
687 register unsigned int thisindex
= 0;
688 register unsigned int thisindex_byte
= 0;
692 thislen
= Flength (this), thisleni
= XINT (thislen
);
694 /* Between strings of the same kind, copy fast. */
695 if (STRINGP (this) && STRINGP (val
)
696 && STRING_MULTIBYTE (this) == some_multibyte
)
698 int thislen_byte
= STRING_BYTES (XSTRING (this));
701 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
702 STRING_BYTES (XSTRING (this)));
703 combined
= (some_multibyte
&& toindex_byte
> 0
704 ? count_combining (XSTRING (val
)->data
,
705 toindex_byte
+ thislen_byte
,
708 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
710 textprops
[num_textprops
].argnum
= argnum
;
711 /* We ignore text properties on characters being combined. */
712 textprops
[num_textprops
].from
= combined
;
713 textprops
[num_textprops
++].to
= toindex
;
715 toindex_byte
+= thislen_byte
;
716 toindex
+= thisleni
- combined
;
717 XSTRING (val
)->size
-= combined
;
719 /* Copy a single-byte string to a multibyte string. */
720 else if (STRINGP (this) && STRINGP (val
))
722 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
724 textprops
[num_textprops
].argnum
= argnum
;
725 textprops
[num_textprops
].from
= 0;
726 textprops
[num_textprops
++].to
= toindex
;
728 toindex_byte
+= copy_text (XSTRING (this)->data
,
729 XSTRING (val
)->data
+ toindex_byte
,
730 XSTRING (this)->size
, 0, 1);
734 /* Copy element by element. */
737 register Lisp_Object elt
;
739 /* Fetch next element of `this' arg into `elt', or break if
740 `this' is exhausted. */
741 if (NILP (this)) break;
743 elt
= XCAR (this), this = XCDR (this);
744 else if (thisindex
>= thisleni
)
746 else if (STRINGP (this))
749 if (STRING_MULTIBYTE (this))
751 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
754 XSETFASTINT (elt
, c
);
758 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
760 && (XINT (elt
) >= 0240
761 || (XINT (elt
) >= 0200
762 && ! NILP (Vnonascii_translation_table
)))
763 && XINT (elt
) < 0400)
765 c
= unibyte_char_to_multibyte (XINT (elt
));
770 else if (BOOL_VECTOR_P (this))
773 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
774 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
781 elt
= XVECTOR (this)->contents
[thisindex
++];
783 /* Store this element into the result. */
790 else if (VECTORP (val
))
791 XVECTOR (val
)->contents
[toindex
++] = elt
;
795 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
799 += CHAR_STRING (XINT (elt
),
800 XSTRING (val
)->data
+ toindex_byte
);
802 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
805 && count_combining (XSTRING (val
)->data
,
806 toindex_byte
, toindex_byte
- 1))
807 XSTRING (val
)->size
--;
812 /* If we have any multibyte characters,
813 we already decided to make a multibyte string. */
816 /* P exists as a variable
817 to avoid a bug on the Masscomp C compiler. */
818 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
820 toindex_byte
+= CHAR_STRING (c
, p
);
827 XSETCDR (prev
, last_tail
);
829 if (num_textprops
> 0)
832 int last_to_end
= -1;
834 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
836 this = args
[textprops
[argnum
].argnum
];
837 props
= text_property_list (this,
839 make_number (XSTRING (this)->size
),
841 /* If successive arguments have properites, be sure that the
842 value of `composition' property be the copy. */
843 if (last_to_end
== textprops
[argnum
].to
)
844 make_composition_value_copy (props
);
845 add_text_properties_from_list (val
, props
,
846 make_number (textprops
[argnum
].to
));
847 last_to_end
= textprops
[argnum
].to
+ XSTRING (this)->size
;
853 static Lisp_Object string_char_byte_cache_string
;
854 static int string_char_byte_cache_charpos
;
855 static int string_char_byte_cache_bytepos
;
858 clear_string_char_byte_cache ()
860 string_char_byte_cache_string
= Qnil
;
863 /* Return the character index corresponding to CHAR_INDEX in STRING. */
866 string_char_to_byte (string
, char_index
)
871 int best_below
, best_below_byte
;
872 int best_above
, best_above_byte
;
874 if (! STRING_MULTIBYTE (string
))
877 best_below
= best_below_byte
= 0;
878 best_above
= XSTRING (string
)->size
;
879 best_above_byte
= STRING_BYTES (XSTRING (string
));
881 if (EQ (string
, string_char_byte_cache_string
))
883 if (string_char_byte_cache_charpos
< char_index
)
885 best_below
= string_char_byte_cache_charpos
;
886 best_below_byte
= string_char_byte_cache_bytepos
;
890 best_above
= string_char_byte_cache_charpos
;
891 best_above_byte
= string_char_byte_cache_bytepos
;
895 if (char_index
- best_below
< best_above
- char_index
)
897 while (best_below
< char_index
)
900 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
901 best_below
, best_below_byte
);
904 i_byte
= best_below_byte
;
908 while (best_above
> char_index
)
910 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
911 unsigned char *pbeg
= pend
- best_above_byte
;
912 unsigned char *p
= pend
- 1;
915 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
916 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
917 if (bytes
== pend
- p
)
918 best_above_byte
-= bytes
;
919 else if (bytes
> pend
- p
)
920 best_above_byte
-= (pend
- p
);
926 i_byte
= best_above_byte
;
929 string_char_byte_cache_bytepos
= i_byte
;
930 string_char_byte_cache_charpos
= i
;
931 string_char_byte_cache_string
= string
;
936 /* Return the character index corresponding to BYTE_INDEX in STRING. */
939 string_byte_to_char (string
, byte_index
)
944 int best_below
, best_below_byte
;
945 int best_above
, best_above_byte
;
947 if (! STRING_MULTIBYTE (string
))
950 best_below
= best_below_byte
= 0;
951 best_above
= XSTRING (string
)->size
;
952 best_above_byte
= STRING_BYTES (XSTRING (string
));
954 if (EQ (string
, string_char_byte_cache_string
))
956 if (string_char_byte_cache_bytepos
< byte_index
)
958 best_below
= string_char_byte_cache_charpos
;
959 best_below_byte
= string_char_byte_cache_bytepos
;
963 best_above
= string_char_byte_cache_charpos
;
964 best_above_byte
= string_char_byte_cache_bytepos
;
968 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
970 while (best_below_byte
< byte_index
)
973 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
974 best_below
, best_below_byte
);
977 i_byte
= best_below_byte
;
981 while (best_above_byte
> byte_index
)
983 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
984 unsigned char *pbeg
= pend
- best_above_byte
;
985 unsigned char *p
= pend
- 1;
988 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
989 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
990 if (bytes
== pend
- p
)
991 best_above_byte
-= bytes
;
992 else if (bytes
> pend
- p
)
993 best_above_byte
-= (pend
- p
);
999 i_byte
= best_above_byte
;
1002 string_char_byte_cache_bytepos
= i_byte
;
1003 string_char_byte_cache_charpos
= i
;
1004 string_char_byte_cache_string
= string
;
1009 /* Convert STRING to a multibyte string.
1010 Single-byte characters 0240 through 0377 are converted
1011 by adding nonascii_insert_offset to each. */
1014 string_make_multibyte (string
)
1020 if (STRING_MULTIBYTE (string
))
1023 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1024 XSTRING (string
)->size
);
1025 /* If all the chars are ASCII, they won't need any more bytes
1026 once converted. In that case, we can return STRING itself. */
1027 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1030 buf
= (unsigned char *) alloca (nbytes
);
1031 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1034 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1037 /* Convert STRING to a single-byte string. */
1040 string_make_unibyte (string
)
1045 if (! STRING_MULTIBYTE (string
))
1048 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1050 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1053 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1056 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1058 doc
: /* Return the multibyte equivalent of STRING.
1059 The function `unibyte-char-to-multibyte' is used to convert
1060 each unibyte character to a multibyte character. */)
1064 CHECK_STRING (string
);
1066 return string_make_multibyte (string
);
1069 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1071 doc
: /* Return the unibyte equivalent of STRING.
1072 Multibyte character codes are converted to unibyte
1073 by using just the low 8 bits. */)
1077 CHECK_STRING (string
);
1079 return string_make_unibyte (string
);
1082 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1084 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1085 If STRING is unibyte, the result is STRING itself.
1086 Otherwise it is a newly created string, with no text properties.
1087 If STRING is multibyte and contains a character of charset
1088 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1089 corresponding single byte. */)
1093 CHECK_STRING (string
);
1095 if (STRING_MULTIBYTE (string
))
1097 int bytes
= STRING_BYTES (XSTRING (string
));
1098 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1100 bcopy (XSTRING (string
)->data
, str
, bytes
);
1101 bytes
= str_as_unibyte (str
, bytes
);
1102 string
= make_unibyte_string (str
, bytes
);
1108 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1110 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1111 If STRING is multibyte, the result is STRING itself.
1112 Otherwise it is a newly created string, with no text properties.
1113 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1114 part of a multibyte form), it is converted to the corresponding
1115 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1119 CHECK_STRING (string
);
1121 if (! STRING_MULTIBYTE (string
))
1123 Lisp_Object new_string
;
1126 parse_str_as_multibyte (XSTRING (string
)->data
,
1127 STRING_BYTES (XSTRING (string
)),
1129 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1130 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1131 STRING_BYTES (XSTRING (string
)));
1132 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1133 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1134 STRING_BYTES (XSTRING (string
)), NULL
);
1135 string
= new_string
;
1136 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1141 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1142 doc
: /* Return a copy of ALIST.
1143 This is an alist which represents the same mapping from objects to objects,
1144 but does not share the alist structure with ALIST.
1145 The objects mapped (cars and cdrs of elements of the alist)
1146 are shared, however.
1147 Elements of ALIST that are not conses are also shared. */)
1151 register Lisp_Object tem
;
1156 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1157 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1159 register Lisp_Object car
;
1163 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1168 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1169 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1170 TO may be nil or omitted; then the substring runs to the end of STRING.
1171 If FROM or TO is negative, it counts from the end.
1173 This function allows vectors as well as strings. */)
1176 register Lisp_Object from
, to
;
1181 int from_char
, to_char
;
1182 int from_byte
= 0, to_byte
= 0;
1184 if (! (STRINGP (string
) || VECTORP (string
)))
1185 wrong_type_argument (Qarrayp
, string
);
1187 CHECK_NUMBER (from
);
1189 if (STRINGP (string
))
1191 size
= XSTRING (string
)->size
;
1192 size_byte
= STRING_BYTES (XSTRING (string
));
1195 size
= XVECTOR (string
)->size
;
1200 to_byte
= size_byte
;
1206 to_char
= XINT (to
);
1210 if (STRINGP (string
))
1211 to_byte
= string_char_to_byte (string
, to_char
);
1214 from_char
= XINT (from
);
1217 if (STRINGP (string
))
1218 from_byte
= string_char_to_byte (string
, from_char
);
1220 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1221 args_out_of_range_3 (string
, make_number (from_char
),
1222 make_number (to_char
));
1224 if (STRINGP (string
))
1226 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1227 to_char
- from_char
, to_byte
- from_byte
,
1228 STRING_MULTIBYTE (string
));
1229 copy_text_properties (make_number (from_char
), make_number (to_char
),
1230 string
, make_number (0), res
, Qnil
);
1233 res
= Fvector (to_char
- from_char
,
1234 XVECTOR (string
)->contents
+ from_char
);
1240 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1241 doc
: /* Return a substring of STRING, without text properties.
1242 It starts at index FROM and ending before TO.
1243 TO may be nil or omitted; then the substring runs to the end of STRING.
1244 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1245 If FROM or TO is negative, it counts from the end.
1247 With one argument, just copy STRING without its properties. */)
1250 register Lisp_Object from
, to
;
1252 int size
, size_byte
;
1253 int from_char
, to_char
;
1254 int from_byte
, to_byte
;
1256 CHECK_STRING (string
);
1258 size
= XSTRING (string
)->size
;
1259 size_byte
= STRING_BYTES (XSTRING (string
));
1262 from_char
= from_byte
= 0;
1265 CHECK_NUMBER (from
);
1266 from_char
= XINT (from
);
1270 from_byte
= string_char_to_byte (string
, from_char
);
1276 to_byte
= size_byte
;
1282 to_char
= XINT (to
);
1286 to_byte
= string_char_to_byte (string
, to_char
);
1289 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1290 args_out_of_range_3 (string
, make_number (from_char
),
1291 make_number (to_char
));
1293 return make_specified_string (XSTRING (string
)->data
+ from_byte
,
1294 to_char
- from_char
, to_byte
- from_byte
,
1295 STRING_MULTIBYTE (string
));
1298 /* Extract a substring of STRING, giving start and end positions
1299 both in characters and in bytes. */
1302 substring_both (string
, from
, from_byte
, to
, to_byte
)
1304 int from
, from_byte
, to
, to_byte
;
1310 if (! (STRINGP (string
) || VECTORP (string
)))
1311 wrong_type_argument (Qarrayp
, string
);
1313 if (STRINGP (string
))
1315 size
= XSTRING (string
)->size
;
1316 size_byte
= STRING_BYTES (XSTRING (string
));
1319 size
= XVECTOR (string
)->size
;
1321 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1322 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1324 if (STRINGP (string
))
1326 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1327 to
- from
, to_byte
- from_byte
,
1328 STRING_MULTIBYTE (string
));
1329 copy_text_properties (make_number (from
), make_number (to
),
1330 string
, make_number (0), res
, Qnil
);
1333 res
= Fvector (to
- from
,
1334 XVECTOR (string
)->contents
+ from
);
1339 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1340 doc
: /* Take cdr N times on LIST, returns the result. */)
1343 register Lisp_Object list
;
1345 register int i
, num
;
1348 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1352 wrong_type_argument (Qlistp
, list
);
1358 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1359 doc
: /* Return the Nth element of LIST.
1360 N counts from zero. If LIST is not that long, nil is returned. */)
1362 Lisp_Object n
, list
;
1364 return Fcar (Fnthcdr (n
, list
));
1367 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1368 doc
: /* Return element of SEQUENCE at index N. */)
1370 register Lisp_Object sequence
, n
;
1375 if (CONSP (sequence
) || NILP (sequence
))
1376 return Fcar (Fnthcdr (n
, sequence
));
1377 else if (STRINGP (sequence
) || VECTORP (sequence
)
1378 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1379 return Faref (sequence
, n
);
1381 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1385 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1386 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1387 The value is actually the tail of LIST whose car is ELT. */)
1389 register Lisp_Object elt
;
1392 register Lisp_Object tail
;
1393 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1395 register Lisp_Object tem
;
1397 wrong_type_argument (Qlistp
, list
);
1399 if (! NILP (Fequal (elt
, tem
)))
1406 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1407 doc
: /* Return non-nil if ELT is an element of LIST.
1408 Comparison done with EQ. The value is actually the tail of LIST
1409 whose car is ELT. */)
1411 Lisp_Object elt
, list
;
1415 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1419 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1423 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1430 if (!CONSP (list
) && !NILP (list
))
1431 list
= wrong_type_argument (Qlistp
, list
);
1436 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1437 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1438 The value is actually the element of LIST whose car is KEY.
1439 Elements of LIST that are not conses are ignored. */)
1441 Lisp_Object key
, list
;
1448 || (CONSP (XCAR (list
))
1449 && EQ (XCAR (XCAR (list
)), key
)))
1454 || (CONSP (XCAR (list
))
1455 && EQ (XCAR (XCAR (list
)), key
)))
1460 || (CONSP (XCAR (list
))
1461 && EQ (XCAR (XCAR (list
)), key
)))
1469 result
= XCAR (list
);
1470 else if (NILP (list
))
1473 result
= wrong_type_argument (Qlistp
, list
);
1478 /* Like Fassq but never report an error and do not allow quits.
1479 Use only on lists known never to be circular. */
1482 assq_no_quit (key
, list
)
1483 Lisp_Object key
, list
;
1486 && (!CONSP (XCAR (list
))
1487 || !EQ (XCAR (XCAR (list
)), key
)))
1490 return CONSP (list
) ? XCAR (list
) : Qnil
;
1493 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1494 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1495 The value is actually the element of LIST whose car equals KEY. */)
1497 Lisp_Object key
, list
;
1499 Lisp_Object result
, car
;
1504 || (CONSP (XCAR (list
))
1505 && (car
= XCAR (XCAR (list
)),
1506 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1511 || (CONSP (XCAR (list
))
1512 && (car
= XCAR (XCAR (list
)),
1513 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1518 || (CONSP (XCAR (list
))
1519 && (car
= XCAR (XCAR (list
)),
1520 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1528 result
= XCAR (list
);
1529 else if (NILP (list
))
1532 result
= wrong_type_argument (Qlistp
, list
);
1537 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1538 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1539 The value is actually the element of LIST whose cdr is KEY. */)
1541 register Lisp_Object key
;
1549 || (CONSP (XCAR (list
))
1550 && EQ (XCDR (XCAR (list
)), key
)))
1555 || (CONSP (XCAR (list
))
1556 && EQ (XCDR (XCAR (list
)), key
)))
1561 || (CONSP (XCAR (list
))
1562 && EQ (XCDR (XCAR (list
)), key
)))
1571 else if (CONSP (list
))
1572 result
= XCAR (list
);
1574 result
= wrong_type_argument (Qlistp
, list
);
1579 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1580 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1581 The value is actually the element of LIST whose cdr equals KEY. */)
1583 Lisp_Object key
, list
;
1585 Lisp_Object result
, cdr
;
1590 || (CONSP (XCAR (list
))
1591 && (cdr
= XCDR (XCAR (list
)),
1592 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1597 || (CONSP (XCAR (list
))
1598 && (cdr
= XCDR (XCAR (list
)),
1599 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1604 || (CONSP (XCAR (list
))
1605 && (cdr
= XCDR (XCAR (list
)),
1606 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1614 result
= XCAR (list
);
1615 else if (NILP (list
))
1618 result
= wrong_type_argument (Qlistp
, list
);
1623 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1624 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1625 The modified LIST is returned. Comparison is done with `eq'.
1626 If the first member of LIST is ELT, there is no way to remove it by side effect;
1627 therefore, write `(setq foo (delq element foo))'
1628 to be sure of changing the value of `foo'. */)
1630 register Lisp_Object elt
;
1633 register Lisp_Object tail
, prev
;
1634 register Lisp_Object tem
;
1638 while (!NILP (tail
))
1641 wrong_type_argument (Qlistp
, list
);
1648 Fsetcdr (prev
, XCDR (tail
));
1658 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1659 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1660 SEQ must be a list, a vector, or a string.
1661 The modified SEQ is returned. Comparison is done with `equal'.
1662 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1663 is not a side effect; it is simply using a different sequence.
1664 Therefore, write `(setq foo (delete element foo))'
1665 to be sure of changing the value of `foo'. */)
1667 Lisp_Object elt
, seq
;
1673 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1674 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1677 if (n
!= ASIZE (seq
))
1679 struct Lisp_Vector
*p
= allocate_vector (n
);
1681 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1682 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1683 p
->contents
[n
++] = AREF (seq
, i
);
1685 XSETVECTOR (seq
, p
);
1688 else if (STRINGP (seq
))
1690 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1693 for (i
= nchars
= nbytes
= ibyte
= 0;
1694 i
< XSTRING (seq
)->size
;
1695 ++i
, ibyte
+= cbytes
)
1697 if (STRING_MULTIBYTE (seq
))
1699 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1700 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1701 cbytes
= CHAR_BYTES (c
);
1705 c
= XSTRING (seq
)->data
[i
];
1709 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1716 if (nchars
!= XSTRING (seq
)->size
)
1720 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1721 if (!STRING_MULTIBYTE (seq
))
1722 SET_STRING_BYTES (XSTRING (tem
), -1);
1724 for (i
= nchars
= nbytes
= ibyte
= 0;
1725 i
< XSTRING (seq
)->size
;
1726 ++i
, ibyte
+= cbytes
)
1728 if (STRING_MULTIBYTE (seq
))
1730 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1731 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1732 cbytes
= CHAR_BYTES (c
);
1736 c
= XSTRING (seq
)->data
[i
];
1740 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1742 unsigned char *from
= &XSTRING (seq
)->data
[ibyte
];
1743 unsigned char *to
= &XSTRING (tem
)->data
[nbytes
];
1749 for (n
= cbytes
; n
--; )
1759 Lisp_Object tail
, prev
;
1761 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1764 wrong_type_argument (Qlistp
, seq
);
1766 if (!NILP (Fequal (elt
, XCAR (tail
))))
1771 Fsetcdr (prev
, XCDR (tail
));
1782 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1783 doc
: /* Reverse LIST by modifying cdr pointers.
1784 Returns the beginning of the reversed list. */)
1788 register Lisp_Object prev
, tail
, next
;
1790 if (NILP (list
)) return list
;
1793 while (!NILP (tail
))
1797 wrong_type_argument (Qlistp
, list
);
1799 Fsetcdr (tail
, prev
);
1806 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1807 doc
: /* Reverse LIST, copying. Returns the beginning of the reversed list.
1808 See also the function `nreverse', which is used more often. */)
1814 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1815 new = Fcons (XCAR (list
), new);
1817 wrong_type_argument (Qconsp
, list
);
1821 Lisp_Object
merge ();
1823 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1824 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1825 Returns the sorted list. LIST is modified by side effects.
1826 PREDICATE is called with two elements of LIST, and should return t
1827 if the first element is "less" than the second. */)
1829 Lisp_Object list
, predicate
;
1831 Lisp_Object front
, back
;
1832 register Lisp_Object len
, tem
;
1833 struct gcpro gcpro1
, gcpro2
;
1834 register int length
;
1837 len
= Flength (list
);
1838 length
= XINT (len
);
1842 XSETINT (len
, (length
/ 2) - 1);
1843 tem
= Fnthcdr (len
, list
);
1845 Fsetcdr (tem
, Qnil
);
1847 GCPRO2 (front
, back
);
1848 front
= Fsort (front
, predicate
);
1849 back
= Fsort (back
, predicate
);
1851 return merge (front
, back
, predicate
);
1855 merge (org_l1
, org_l2
, pred
)
1856 Lisp_Object org_l1
, org_l2
;
1860 register Lisp_Object tail
;
1862 register Lisp_Object l1
, l2
;
1863 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1870 /* It is sufficient to protect org_l1 and org_l2.
1871 When l1 and l2 are updated, we copy the new values
1872 back into the org_ vars. */
1873 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1893 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1909 Fsetcdr (tail
, tem
);
1915 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1916 doc
: /* Extract a value from a property list.
1917 PLIST is a property list, which is a list of the form
1918 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1919 corresponding to the given PROP, or nil if PROP is not
1920 one of the properties on the list. */)
1928 CONSP (tail
) && CONSP (XCDR (tail
));
1929 tail
= XCDR (XCDR (tail
)))
1931 if (EQ (prop
, XCAR (tail
)))
1932 return XCAR (XCDR (tail
));
1934 /* This function can be called asynchronously
1935 (setup_coding_system). Don't QUIT in that case. */
1936 if (!interrupt_input_blocked
)
1941 wrong_type_argument (Qlistp
, prop
);
1946 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1947 doc
: /* Return the value of SYMBOL's PROPNAME property.
1948 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1950 Lisp_Object symbol
, propname
;
1952 CHECK_SYMBOL (symbol
);
1953 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1956 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1957 doc
: /* Change value in PLIST of PROP to VAL.
1958 PLIST is a property list, which is a list of the form
1959 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1960 If PROP is already a property on the list, its value is set to VAL,
1961 otherwise the new PROP VAL pair is added. The new plist is returned;
1962 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1963 The PLIST is modified by side effects. */)
1966 register Lisp_Object prop
;
1969 register Lisp_Object tail
, prev
;
1970 Lisp_Object newcell
;
1972 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1973 tail
= XCDR (XCDR (tail
)))
1975 if (EQ (prop
, XCAR (tail
)))
1977 Fsetcar (XCDR (tail
), val
);
1984 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1988 Fsetcdr (XCDR (prev
), newcell
);
1992 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1993 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1994 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1995 (symbol
, propname
, value
)
1996 Lisp_Object symbol
, propname
, value
;
1998 CHECK_SYMBOL (symbol
);
1999 XSYMBOL (symbol
)->plist
2000 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2004 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2005 doc
: /* Extract a value from a property list, comparing with `equal'.
2006 PLIST is a property list, which is a list of the form
2007 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2008 corresponding to the given PROP, or nil if PROP is not
2009 one of the properties on the list. */)
2017 CONSP (tail
) && CONSP (XCDR (tail
));
2018 tail
= XCDR (XCDR (tail
)))
2020 if (! NILP (Fequal (prop
, XCAR (tail
))))
2021 return XCAR (XCDR (tail
));
2027 wrong_type_argument (Qlistp
, prop
);
2032 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2033 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2034 PLIST is a property list, which is a list of the form
2035 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2036 If PROP is already a property on the list, its value is set to VAL,
2037 otherwise the new PROP VAL pair is added. The new plist is returned;
2038 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2039 The PLIST is modified by side effects. */)
2042 register Lisp_Object prop
;
2045 register Lisp_Object tail
, prev
;
2046 Lisp_Object newcell
;
2048 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2049 tail
= XCDR (XCDR (tail
)))
2051 if (! NILP (Fequal (prop
, XCAR (tail
))))
2053 Fsetcar (XCDR (tail
), val
);
2060 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2064 Fsetcdr (XCDR (prev
), newcell
);
2068 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2069 doc
: /* Return t if two Lisp objects have similar structure and contents.
2070 They must have the same data type.
2071 Conses are compared by comparing the cars and the cdrs.
2072 Vectors and strings are compared element by element.
2073 Numbers are compared by value, but integers cannot equal floats.
2074 (Use `=' if you want integers and floats to be able to be equal.)
2075 Symbols must match exactly. */)
2077 register Lisp_Object o1
, o2
;
2079 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2083 internal_equal (o1
, o2
, depth
)
2084 register Lisp_Object o1
, o2
;
2088 error ("Stack overflow in equal");
2094 if (XTYPE (o1
) != XTYPE (o2
))
2100 return (extract_float (o1
) == extract_float (o2
));
2103 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2110 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2114 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2116 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2119 o1
= XOVERLAY (o1
)->plist
;
2120 o2
= XOVERLAY (o2
)->plist
;
2125 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2126 && (XMARKER (o1
)->buffer
== 0
2127 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2131 case Lisp_Vectorlike
:
2133 register int i
, size
;
2134 size
= XVECTOR (o1
)->size
;
2135 /* Pseudovectors have the type encoded in the size field, so this test
2136 actually checks that the objects have the same type as well as the
2138 if (XVECTOR (o2
)->size
!= size
)
2140 /* Boolvectors are compared much like strings. */
2141 if (BOOL_VECTOR_P (o1
))
2144 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2146 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2148 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2153 if (WINDOW_CONFIGURATIONP (o1
))
2154 return compare_window_configurations (o1
, o2
, 0);
2156 /* Aside from them, only true vectors, char-tables, and compiled
2157 functions are sensible to compare, so eliminate the others now. */
2158 if (size
& PSEUDOVECTOR_FLAG
)
2160 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2162 size
&= PSEUDOVECTOR_SIZE_MASK
;
2164 for (i
= 0; i
< size
; i
++)
2167 v1
= XVECTOR (o1
)->contents
[i
];
2168 v2
= XVECTOR (o2
)->contents
[i
];
2169 if (!internal_equal (v1
, v2
, depth
+ 1))
2177 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
2179 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
2181 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
2182 STRING_BYTES (XSTRING (o1
))))
2188 case Lisp_Type_Limit
:
2195 extern Lisp_Object
Fmake_char_internal ();
2197 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2198 doc
: /* Store each element of ARRAY with ITEM.
2199 ARRAY is a vector, string, char-table, or bool-vector. */)
2201 Lisp_Object array
, item
;
2203 register int size
, index
, charval
;
2205 if (VECTORP (array
))
2207 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2208 size
= XVECTOR (array
)->size
;
2209 for (index
= 0; index
< size
; index
++)
2212 else if (CHAR_TABLE_P (array
))
2214 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2215 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2216 for (index
= 0; index
< size
; index
++)
2218 XCHAR_TABLE (array
)->defalt
= Qnil
;
2220 else if (STRINGP (array
))
2222 register unsigned char *p
= XSTRING (array
)->data
;
2223 CHECK_NUMBER (item
);
2224 charval
= XINT (item
);
2225 size
= XSTRING (array
)->size
;
2226 if (STRING_MULTIBYTE (array
))
2228 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2229 int len
= CHAR_STRING (charval
, str
);
2230 int size_byte
= STRING_BYTES (XSTRING (array
));
2231 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2234 if (size
!= size_byte
)
2237 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2238 if (len
!= this_len
)
2239 error ("Attempt to change byte length of a string");
2242 for (i
= 0; i
< size_byte
; i
++)
2243 *p
++ = str
[i
% len
];
2246 for (index
= 0; index
< size
; index
++)
2249 else if (BOOL_VECTOR_P (array
))
2251 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2253 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2255 charval
= (! NILP (item
) ? -1 : 0);
2256 for (index
= 0; index
< size_in_chars
; index
++)
2261 array
= wrong_type_argument (Qarrayp
, array
);
2267 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2269 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2271 Lisp_Object char_table
;
2273 CHECK_CHAR_TABLE (char_table
);
2275 return XCHAR_TABLE (char_table
)->purpose
;
2278 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2280 doc
: /* Return the parent char-table of CHAR-TABLE.
2281 The value is either nil or another char-table.
2282 If CHAR-TABLE holds nil for a given character,
2283 then the actual applicable value is inherited from the parent char-table
2284 \(or from its parents, if necessary). */)
2286 Lisp_Object char_table
;
2288 CHECK_CHAR_TABLE (char_table
);
2290 return XCHAR_TABLE (char_table
)->parent
;
2293 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2295 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2296 PARENT must be either nil or another char-table. */)
2297 (char_table
, parent
)
2298 Lisp_Object char_table
, parent
;
2302 CHECK_CHAR_TABLE (char_table
);
2306 CHECK_CHAR_TABLE (parent
);
2308 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2309 if (EQ (temp
, char_table
))
2310 error ("Attempt to make a chartable be its own parent");
2313 XCHAR_TABLE (char_table
)->parent
= parent
;
2318 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2320 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2322 Lisp_Object char_table
, n
;
2324 CHECK_CHAR_TABLE (char_table
);
2327 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2328 args_out_of_range (char_table
, n
);
2330 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2333 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2334 Sset_char_table_extra_slot
,
2336 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2337 (char_table
, n
, value
)
2338 Lisp_Object char_table
, n
, value
;
2340 CHECK_CHAR_TABLE (char_table
);
2343 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2344 args_out_of_range (char_table
, n
);
2346 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2349 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2351 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2352 RANGE should be nil (for the default value)
2353 a vector which identifies a character set or a row of a character set,
2354 a character set name, or a character code. */)
2356 Lisp_Object char_table
, range
;
2358 CHECK_CHAR_TABLE (char_table
);
2360 if (EQ (range
, Qnil
))
2361 return XCHAR_TABLE (char_table
)->defalt
;
2362 else if (INTEGERP (range
))
2363 return Faref (char_table
, range
);
2364 else if (SYMBOLP (range
))
2366 Lisp_Object charset_info
;
2368 charset_info
= Fget (range
, Qcharset
);
2369 CHECK_VECTOR (charset_info
);
2371 return Faref (char_table
,
2372 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2375 else if (VECTORP (range
))
2377 if (XVECTOR (range
)->size
== 1)
2378 return Faref (char_table
,
2379 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2382 int size
= XVECTOR (range
)->size
;
2383 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2384 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2385 size
<= 1 ? Qnil
: val
[1],
2386 size
<= 2 ? Qnil
: val
[2]);
2387 return Faref (char_table
, ch
);
2391 error ("Invalid RANGE argument to `char-table-range'");
2395 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2397 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2398 RANGE should be t (for all characters), nil (for the default value)
2399 a vector which identifies a character set or a row of a character set,
2400 a coding system, or a character code. */)
2401 (char_table
, range
, value
)
2402 Lisp_Object char_table
, range
, value
;
2406 CHECK_CHAR_TABLE (char_table
);
2409 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2410 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2411 else if (EQ (range
, Qnil
))
2412 XCHAR_TABLE (char_table
)->defalt
= value
;
2413 else if (SYMBOLP (range
))
2415 Lisp_Object charset_info
;
2417 charset_info
= Fget (range
, Qcharset
);
2418 CHECK_VECTOR (charset_info
);
2420 return Faset (char_table
,
2421 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2425 else if (INTEGERP (range
))
2426 Faset (char_table
, range
, value
);
2427 else if (VECTORP (range
))
2429 if (XVECTOR (range
)->size
== 1)
2430 return Faset (char_table
,
2431 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2435 int size
= XVECTOR (range
)->size
;
2436 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2437 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2438 size
<= 1 ? Qnil
: val
[1],
2439 size
<= 2 ? Qnil
: val
[2]);
2440 return Faset (char_table
, ch
, value
);
2444 error ("Invalid RANGE argument to `set-char-table-range'");
2449 DEFUN ("set-char-table-default", Fset_char_table_default
,
2450 Sset_char_table_default
, 3, 3, 0,
2451 doc
: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
2452 The generic character specifies the group of characters.
2453 See also the documentation of make-char. */)
2454 (char_table
, ch
, value
)
2455 Lisp_Object char_table
, ch
, value
;
2457 int c
, charset
, code1
, code2
;
2460 CHECK_CHAR_TABLE (char_table
);
2464 SPLIT_CHAR (c
, charset
, code1
, code2
);
2466 /* Since we may want to set the default value for a character set
2467 not yet defined, we check only if the character set is in the
2468 valid range or not, instead of it is already defined or not. */
2469 if (! CHARSET_VALID_P (charset
))
2470 invalid_character (c
);
2472 if (charset
== CHARSET_ASCII
)
2473 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2475 /* Even if C is not a generic char, we had better behave as if a
2476 generic char is specified. */
2477 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2479 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2482 if (SUB_CHAR_TABLE_P (temp
))
2483 XCHAR_TABLE (temp
)->defalt
= value
;
2485 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2488 if (SUB_CHAR_TABLE_P (temp
))
2491 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2492 = make_sub_char_table (temp
));
2493 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2494 if (SUB_CHAR_TABLE_P (temp
))
2495 XCHAR_TABLE (temp
)->defalt
= value
;
2497 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2501 /* Look up the element in TABLE at index CH,
2502 and return it as an integer.
2503 If the element is nil, return CH itself.
2504 (Actually we do that for any non-integer.) */
2507 char_table_translate (table
, ch
)
2512 value
= Faref (table
, make_number (ch
));
2513 if (! INTEGERP (value
))
2515 return XINT (value
);
2519 optimize_sub_char_table (table
, chars
)
2527 from
= 33, to
= 127;
2529 from
= 32, to
= 128;
2531 if (!SUB_CHAR_TABLE_P (*table
))
2533 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2534 for (; from
< to
; from
++)
2535 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2540 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2541 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2549 CHECK_CHAR_TABLE (table
);
2551 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2553 elt
= XCHAR_TABLE (table
)->contents
[i
];
2554 if (!SUB_CHAR_TABLE_P (elt
))
2556 dim
= CHARSET_DIMENSION (i
- 128);
2558 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2559 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2560 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2566 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2567 character or group of characters that share a value.
2568 DEPTH is the current depth in the originally specified
2569 chartable, and INDICES contains the vector indices
2570 for the levels our callers have descended.
2572 ARG is passed to C_FUNCTION when that is called. */
2575 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2576 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2577 Lisp_Object function
, subtable
, arg
, *indices
;
2584 /* At first, handle ASCII and 8-bit European characters. */
2585 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2587 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2589 (*c_function
) (arg
, make_number (i
), elt
);
2591 call2 (function
, make_number (i
), elt
);
2593 #if 0 /* If the char table has entries for higher characters,
2594 we should report them. */
2595 if (NILP (current_buffer
->enable_multibyte_characters
))
2598 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2602 int charset
= XFASTINT (indices
[0]) - 128;
2605 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2606 if (CHARSET_CHARS (charset
) == 94)
2615 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2616 XSETFASTINT (indices
[depth
], i
);
2617 charset
= XFASTINT (indices
[0]) - 128;
2619 && (!CHARSET_DEFINED_P (charset
)
2620 || charset
== CHARSET_8_BIT_CONTROL
2621 || charset
== CHARSET_8_BIT_GRAPHIC
))
2624 if (SUB_CHAR_TABLE_P (elt
))
2627 error ("Too deep char table");
2628 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2635 elt
= XCHAR_TABLE (subtable
)->defalt
;
2636 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2637 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2638 c
= MAKE_CHAR (charset
, c1
, c2
);
2640 (*c_function
) (arg
, make_number (c
), elt
);
2642 call2 (function
, make_number (c
), elt
);
2647 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2649 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2650 FUNCTION is called with two arguments--a key and a value.
2651 The key is always a possible IDX argument to `aref'. */)
2652 (function
, char_table
)
2653 Lisp_Object function
, char_table
;
2655 /* The depth of char table is at most 3. */
2656 Lisp_Object indices
[3];
2658 CHECK_CHAR_TABLE (char_table
);
2660 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2664 /* Return a value for character C in char-table TABLE. Store the
2665 actual index for that value in *IDX. Ignore the default value of
2669 char_table_ref_and_index (table
, c
, idx
)
2673 int charset
, c1
, c2
;
2676 if (SINGLE_BYTE_CHAR_P (c
))
2679 return XCHAR_TABLE (table
)->contents
[c
];
2681 SPLIT_CHAR (c
, charset
, c1
, c2
);
2682 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2683 *idx
= MAKE_CHAR (charset
, 0, 0);
2684 if (!SUB_CHAR_TABLE_P (elt
))
2686 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2687 return XCHAR_TABLE (elt
)->defalt
;
2688 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2689 *idx
= MAKE_CHAR (charset
, c1
, 0);
2690 if (!SUB_CHAR_TABLE_P (elt
))
2692 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2693 return XCHAR_TABLE (elt
)->defalt
;
2695 return XCHAR_TABLE (elt
)->contents
[c2
];
2705 Lisp_Object args
[2];
2708 return Fnconc (2, args
);
2710 return Fnconc (2, &s1
);
2711 #endif /* NO_ARG_ARRAY */
2714 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2715 doc
: /* Concatenate any number of lists by altering them.
2716 Only the last argument is not altered, and need not be a list.
2717 usage: (nconc &rest LISTS) */)
2722 register int argnum
;
2723 register Lisp_Object tail
, tem
, val
;
2727 for (argnum
= 0; argnum
< nargs
; argnum
++)
2730 if (NILP (tem
)) continue;
2735 if (argnum
+ 1 == nargs
) break;
2738 tem
= wrong_type_argument (Qlistp
, tem
);
2747 tem
= args
[argnum
+ 1];
2748 Fsetcdr (tail
, tem
);
2750 args
[argnum
+ 1] = tail
;
2756 /* This is the guts of all mapping functions.
2757 Apply FN to each element of SEQ, one by one,
2758 storing the results into elements of VALS, a C vector of Lisp_Objects.
2759 LENI is the length of VALS, which should also be the length of SEQ. */
2762 mapcar1 (leni
, vals
, fn
, seq
)
2765 Lisp_Object fn
, seq
;
2767 register Lisp_Object tail
;
2770 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2774 /* Don't let vals contain any garbage when GC happens. */
2775 for (i
= 0; i
< leni
; i
++)
2778 GCPRO3 (dummy
, fn
, seq
);
2780 gcpro1
.nvars
= leni
;
2784 /* We need not explicitly protect `tail' because it is used only on lists, and
2785 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2789 for (i
= 0; i
< leni
; i
++)
2791 dummy
= XVECTOR (seq
)->contents
[i
];
2792 dummy
= call1 (fn
, dummy
);
2797 else if (BOOL_VECTOR_P (seq
))
2799 for (i
= 0; i
< leni
; i
++)
2802 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2803 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2808 dummy
= call1 (fn
, dummy
);
2813 else if (STRINGP (seq
))
2817 for (i
= 0, i_byte
= 0; i
< leni
;)
2822 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2823 XSETFASTINT (dummy
, c
);
2824 dummy
= call1 (fn
, dummy
);
2826 vals
[i_before
] = dummy
;
2829 else /* Must be a list, since Flength did not get an error */
2832 for (i
= 0; i
< leni
; i
++)
2834 dummy
= call1 (fn
, Fcar (tail
));
2844 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2845 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2846 In between each pair of results, stick in SEPARATOR. Thus, " " as
2847 SEPARATOR results in spaces between the values returned by FUNCTION.
2848 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2849 (function
, sequence
, separator
)
2850 Lisp_Object function
, sequence
, separator
;
2855 register Lisp_Object
*args
;
2857 struct gcpro gcpro1
;
2859 len
= Flength (sequence
);
2861 nargs
= leni
+ leni
- 1;
2862 if (nargs
< 0) return build_string ("");
2864 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2867 mapcar1 (leni
, args
, function
, sequence
);
2870 for (i
= leni
- 1; i
>= 0; i
--)
2871 args
[i
+ i
] = args
[i
];
2873 for (i
= 1; i
< nargs
; i
+= 2)
2874 args
[i
] = separator
;
2876 return Fconcat (nargs
, args
);
2879 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2880 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2881 The result is a list just as long as SEQUENCE.
2882 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2883 (function
, sequence
)
2884 Lisp_Object function
, sequence
;
2886 register Lisp_Object len
;
2888 register Lisp_Object
*args
;
2890 len
= Flength (sequence
);
2891 leni
= XFASTINT (len
);
2892 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2894 mapcar1 (leni
, args
, function
, sequence
);
2896 return Flist (leni
, args
);
2899 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2900 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2901 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2902 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2903 (function
, sequence
)
2904 Lisp_Object function
, sequence
;
2908 leni
= XFASTINT (Flength (sequence
));
2909 mapcar1 (leni
, 0, function
, sequence
);
2914 /* Anything that calls this function must protect from GC! */
2916 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2917 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2918 Takes one argument, which is the string to display to ask the question.
2919 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2920 No confirmation of the answer is requested; a single character is enough.
2921 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2922 the bindings in `query-replace-map'; see the documentation of that variable
2923 for more information. In this case, the useful bindings are `act', `skip',
2924 `recenter', and `quit'.\)
2926 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2927 is nil and `use-dialog-box' is non-nil. */)
2931 register Lisp_Object obj
, key
, def
, map
;
2932 register int answer
;
2933 Lisp_Object xprompt
;
2934 Lisp_Object args
[2];
2935 struct gcpro gcpro1
, gcpro2
;
2936 int count
= specpdl_ptr
- specpdl
;
2938 specbind (Qcursor_in_echo_area
, Qt
);
2940 map
= Fsymbol_value (intern ("query-replace-map"));
2942 CHECK_STRING (prompt
);
2944 GCPRO2 (prompt
, xprompt
);
2946 #ifdef HAVE_X_WINDOWS
2947 if (display_hourglass_p
)
2948 cancel_hourglass ();
2955 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2959 Lisp_Object pane
, menu
;
2960 redisplay_preserve_echo_area (3);
2961 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2962 Fcons (Fcons (build_string ("No"), Qnil
),
2964 menu
= Fcons (prompt
, pane
);
2965 obj
= Fx_popup_dialog (Qt
, menu
);
2966 answer
= !NILP (obj
);
2969 #endif /* HAVE_MENUS */
2970 cursor_in_echo_area
= 1;
2971 choose_minibuf_frame ();
2974 Lisp_Object pargs
[3];
2976 /* Colorize prompt according to `minibuffer-prompt' face. */
2977 pargs
[0] = build_string ("%s(y or n) ");
2978 pargs
[1] = intern ("face");
2979 pargs
[2] = intern ("minibuffer-prompt");
2980 args
[0] = Fpropertize (3, pargs
);
2985 if (minibuffer_auto_raise
)
2987 Lisp_Object mini_frame
;
2989 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2991 Fraise_frame (mini_frame
);
2994 obj
= read_filtered_event (1, 0, 0, 0);
2995 cursor_in_echo_area
= 0;
2996 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2999 key
= Fmake_vector (make_number (1), obj
);
3000 def
= Flookup_key (map
, key
, Qt
);
3002 if (EQ (def
, intern ("skip")))
3007 else if (EQ (def
, intern ("act")))
3012 else if (EQ (def
, intern ("recenter")))
3018 else if (EQ (def
, intern ("quit")))
3020 /* We want to exit this command for exit-prefix,
3021 and this is the only way to do it. */
3022 else if (EQ (def
, intern ("exit-prefix")))
3027 /* If we don't clear this, then the next call to read_char will
3028 return quit_char again, and we'll enter an infinite loop. */
3033 if (EQ (xprompt
, prompt
))
3035 args
[0] = build_string ("Please answer y or n. ");
3037 xprompt
= Fconcat (2, args
);
3042 if (! noninteractive
)
3044 cursor_in_echo_area
= -1;
3045 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3049 unbind_to (count
, Qnil
);
3050 return answer
? Qt
: Qnil
;
3053 /* This is how C code calls `yes-or-no-p' and allows the user
3056 Anything that calls this function must protect from GC! */
3059 do_yes_or_no_p (prompt
)
3062 return call1 (intern ("yes-or-no-p"), prompt
);
3065 /* Anything that calls this function must protect from GC! */
3067 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3068 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3069 Takes one argument, which is the string to display to ask the question.
3070 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3071 The user must confirm the answer with RET,
3072 and can edit it until it has been confirmed.
3074 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3075 is nil, and `use-dialog-box' is non-nil. */)
3079 register Lisp_Object ans
;
3080 Lisp_Object args
[2];
3081 struct gcpro gcpro1
;
3083 CHECK_STRING (prompt
);
3086 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3090 Lisp_Object pane
, menu
, obj
;
3091 redisplay_preserve_echo_area (4);
3092 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3093 Fcons (Fcons (build_string ("No"), Qnil
),
3096 menu
= Fcons (prompt
, pane
);
3097 obj
= Fx_popup_dialog (Qt
, menu
);
3101 #endif /* HAVE_MENUS */
3104 args
[1] = build_string ("(yes or no) ");
3105 prompt
= Fconcat (2, args
);
3111 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3112 Qyes_or_no_p_history
, Qnil
,
3114 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
3119 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
3127 message ("Please answer yes or no.");
3128 Fsleep_for (make_number (2), Qnil
);
3132 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3133 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3135 Each of the three load averages is multiplied by 100, then converted
3138 When USE-FLOATS is non-nil, floats will be used instead of integers.
3139 These floats are not multiplied by 100.
3141 If the 5-minute or 15-minute load averages are not available, return a
3142 shortened list, containing only those averages which are available. */)
3144 Lisp_Object use_floats
;
3147 int loads
= getloadavg (load_ave
, 3);
3148 Lisp_Object ret
= Qnil
;
3151 error ("load-average not implemented for this operating system");
3155 Lisp_Object load
= (NILP (use_floats
) ?
3156 make_number ((int) (100.0 * load_ave
[loads
]))
3157 : make_float (load_ave
[loads
]));
3158 ret
= Fcons (load
, ret
);
3164 Lisp_Object Vfeatures
, Qsubfeatures
;
3165 extern Lisp_Object Vafter_load_alist
;
3167 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3168 doc
: /* Returns t if FEATURE is present in this Emacs.
3170 Use this to conditionalize execution of lisp code based on the
3171 presence or absence of emacs or environment extensions.
3172 Use `provide' to declare that a feature is available. This function
3173 looks at the value of the variable `features'. The optional argument
3174 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3175 (feature
, subfeature
)
3176 Lisp_Object feature
, subfeature
;
3178 register Lisp_Object tem
;
3179 CHECK_SYMBOL (feature
);
3180 tem
= Fmemq (feature
, Vfeatures
);
3181 if (!NILP (tem
) && !NILP (subfeature
))
3182 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3183 return (NILP (tem
)) ? Qnil
: Qt
;
3186 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3187 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3188 The optional argument SUBFEATURES should be a list of symbols listing
3189 particular subfeatures supported in this version of FEATURE. */)
3190 (feature
, subfeatures
)
3191 Lisp_Object feature
, subfeatures
;
3193 register Lisp_Object tem
;
3194 CHECK_SYMBOL (feature
);
3195 CHECK_LIST (subfeatures
);
3196 if (!NILP (Vautoload_queue
))
3197 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3198 tem
= Fmemq (feature
, Vfeatures
);
3200 Vfeatures
= Fcons (feature
, Vfeatures
);
3201 if (!NILP (subfeatures
))
3202 Fput (feature
, Qsubfeatures
, subfeatures
);
3203 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3205 /* Run any load-hooks for this file. */
3206 tem
= Fassq (feature
, Vafter_load_alist
);
3208 Fprogn (Fcdr (tem
));
3213 /* `require' and its subroutines. */
3215 /* List of features currently being require'd, innermost first. */
3217 Lisp_Object require_nesting_list
;
3220 require_unwind (old_value
)
3221 Lisp_Object old_value
;
3223 return require_nesting_list
= old_value
;
3226 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3227 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3228 If FEATURE is not a member of the list `features', then the feature
3229 is not loaded; so load the file FILENAME.
3230 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3231 and `load' will try to load this name appended with the suffix `.elc',
3232 `.el' or the unmodified name, in that order.
3233 If the optional third argument NOERROR is non-nil,
3234 then return nil if the file is not found instead of signaling an error.
3235 Normally the return value is FEATURE.
3236 The normal messages at start and end of loading FILENAME are suppressed. */)
3237 (feature
, filename
, noerror
)
3238 Lisp_Object feature
, filename
, noerror
;
3240 register Lisp_Object tem
;
3241 struct gcpro gcpro1
, gcpro2
;
3243 CHECK_SYMBOL (feature
);
3245 tem
= Fmemq (feature
, Vfeatures
);
3247 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3251 int count
= specpdl_ptr
- specpdl
;
3254 /* This is to make sure that loadup.el gives a clear picture
3255 of what files are preloaded and when. */
3256 if (! NILP (Vpurify_flag
))
3257 error ("(require %s) while preparing to dump",
3258 XSTRING (SYMBOL_NAME (feature
))->data
);
3260 /* A certain amount of recursive `require' is legitimate,
3261 but if we require the same feature recursively 3 times,
3263 tem
= require_nesting_list
;
3264 while (! NILP (tem
))
3266 if (! NILP (Fequal (feature
, XCAR (tem
))))
3271 error ("Recursive `require' for feature `%s'",
3272 XSTRING (SYMBOL_NAME (feature
))->data
);
3274 /* Update the list for any nested `require's that occur. */
3275 record_unwind_protect (require_unwind
, require_nesting_list
);
3276 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3278 /* Value saved here is to be restored into Vautoload_queue */
3279 record_unwind_protect (un_autoload
, Vautoload_queue
);
3280 Vautoload_queue
= Qt
;
3282 /* Load the file. */
3283 GCPRO2 (feature
, filename
);
3284 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3285 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3288 /* If load failed entirely, return nil. */
3290 return unbind_to (count
, Qnil
);
3292 tem
= Fmemq (feature
, Vfeatures
);
3294 error ("Required feature `%s' was not provided",
3295 XSTRING (SYMBOL_NAME (feature
))->data
);
3297 /* Once loading finishes, don't undo it. */
3298 Vautoload_queue
= Qt
;
3299 feature
= unbind_to (count
, feature
);
3305 /* Primitives for work of the "widget" library.
3306 In an ideal world, this section would not have been necessary.
3307 However, lisp function calls being as slow as they are, it turns
3308 out that some functions in the widget library (wid-edit.el) are the
3309 bottleneck of Widget operation. Here is their translation to C,
3310 for the sole reason of efficiency. */
3312 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3313 doc
: /* Return non-nil if PLIST has the property PROP.
3314 PLIST is a property list, which is a list of the form
3315 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3316 Unlike `plist-get', this allows you to distinguish between a missing
3317 property and a property with the value nil.
3318 The value is actually the tail of PLIST whose car is PROP. */)
3320 Lisp_Object plist
, prop
;
3322 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3325 plist
= XCDR (plist
);
3326 plist
= CDR (plist
);
3331 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3332 doc
: /* In WIDGET, set PROPERTY to VALUE.
3333 The value can later be retrieved with `widget-get'. */)
3334 (widget
, property
, value
)
3335 Lisp_Object widget
, property
, value
;
3337 CHECK_CONS (widget
);
3338 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3342 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3343 doc
: /* In WIDGET, get the value of PROPERTY.
3344 The value could either be specified when the widget was created, or
3345 later with `widget-put'. */)
3347 Lisp_Object widget
, property
;
3355 CHECK_CONS (widget
);
3356 tmp
= Fplist_member (XCDR (widget
), property
);
3362 tmp
= XCAR (widget
);
3365 widget
= Fget (tmp
, Qwidget_type
);
3369 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3370 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3371 ARGS are passed as extra arguments to the function.
3372 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3377 /* This function can GC. */
3378 Lisp_Object newargs
[3];
3379 struct gcpro gcpro1
, gcpro2
;
3382 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3383 newargs
[1] = args
[0];
3384 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3385 GCPRO2 (newargs
[0], newargs
[2]);
3386 result
= Fapply (3, newargs
);
3391 /* base64 encode/decode functions (RFC 2045).
3392 Based on code from GNU recode. */
3394 #define MIME_LINE_LENGTH 76
3396 #define IS_ASCII(Character) \
3398 #define IS_BASE64(Character) \
3399 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3400 #define IS_BASE64_IGNORABLE(Character) \
3401 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3402 || (Character) == '\f' || (Character) == '\r')
3404 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3405 character or return retval if there are no characters left to
3407 #define READ_QUADRUPLET_BYTE(retval) \
3412 if (nchars_return) \
3413 *nchars_return = nchars; \
3418 while (IS_BASE64_IGNORABLE (c))
3420 /* Don't use alloca for regions larger than this, lest we overflow
3422 #define MAX_ALLOCA 16*1024
3424 /* Table of characters coding the 64 values. */
3425 static char base64_value_to_char
[64] =
3427 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3428 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3429 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3430 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3431 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3432 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3433 '8', '9', '+', '/' /* 60-63 */
3436 /* Table of base64 values for first 128 characters. */
3437 static short base64_char_to_value
[128] =
3439 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3440 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3441 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3442 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3443 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3444 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3445 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3446 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3447 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3448 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3449 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3450 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3451 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3454 /* The following diagram shows the logical steps by which three octets
3455 get transformed into four base64 characters.
3457 .--------. .--------. .--------.
3458 |aaaaaabb| |bbbbcccc| |ccdddddd|
3459 `--------' `--------' `--------'
3461 .--------+--------+--------+--------.
3462 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3463 `--------+--------+--------+--------'
3465 .--------+--------+--------+--------.
3466 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3467 `--------+--------+--------+--------'
3469 The octets are divided into 6 bit chunks, which are then encoded into
3470 base64 characters. */
3473 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3474 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3476 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3478 doc
: /* Base64-encode the region between BEG and END.
3479 Return the length of the encoded text.
3480 Optional third argument NO-LINE-BREAK means do not break long lines
3481 into shorter lines. */)
3482 (beg
, end
, no_line_break
)
3483 Lisp_Object beg
, end
, no_line_break
;
3486 int allength
, length
;
3487 int ibeg
, iend
, encoded_length
;
3490 validate_region (&beg
, &end
);
3492 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3493 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3494 move_gap_both (XFASTINT (beg
), ibeg
);
3496 /* We need to allocate enough room for encoding the text.
3497 We need 33 1/3% more space, plus a newline every 76
3498 characters, and then we round up. */
3499 length
= iend
- ibeg
;
3500 allength
= length
+ length
/3 + 1;
3501 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3503 if (allength
<= MAX_ALLOCA
)
3504 encoded
= (char *) alloca (allength
);
3506 encoded
= (char *) xmalloc (allength
);
3507 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3508 NILP (no_line_break
),
3509 !NILP (current_buffer
->enable_multibyte_characters
));
3510 if (encoded_length
> allength
)
3513 if (encoded_length
< 0)
3515 /* The encoding wasn't possible. */
3516 if (length
> MAX_ALLOCA
)
3518 error ("Multibyte character in data for base64 encoding");
3521 /* Now we have encoded the region, so we insert the new contents
3522 and delete the old. (Insert first in order to preserve markers.) */
3523 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3524 insert (encoded
, encoded_length
);
3525 if (allength
> MAX_ALLOCA
)
3527 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3529 /* If point was outside of the region, restore it exactly; else just
3530 move to the beginning of the region. */
3531 if (old_pos
>= XFASTINT (end
))
3532 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3533 else if (old_pos
> XFASTINT (beg
))
3534 old_pos
= XFASTINT (beg
);
3537 /* We return the length of the encoded text. */
3538 return make_number (encoded_length
);
3541 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3543 doc
: /* Base64-encode STRING and return the result.
3544 Optional second argument NO-LINE-BREAK means do not break long lines
3545 into shorter lines. */)
3546 (string
, no_line_break
)
3547 Lisp_Object string
, no_line_break
;
3549 int allength
, length
, encoded_length
;
3551 Lisp_Object encoded_string
;
3553 CHECK_STRING (string
);
3555 /* We need to allocate enough room for encoding the text.
3556 We need 33 1/3% more space, plus a newline every 76
3557 characters, and then we round up. */
3558 length
= STRING_BYTES (XSTRING (string
));
3559 allength
= length
+ length
/3 + 1;
3560 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3562 /* We need to allocate enough room for decoding the text. */
3563 if (allength
<= MAX_ALLOCA
)
3564 encoded
= (char *) alloca (allength
);
3566 encoded
= (char *) xmalloc (allength
);
3568 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3569 encoded
, length
, NILP (no_line_break
),
3570 STRING_MULTIBYTE (string
));
3571 if (encoded_length
> allength
)
3574 if (encoded_length
< 0)
3576 /* The encoding wasn't possible. */
3577 if (length
> MAX_ALLOCA
)
3579 error ("Multibyte character in data for base64 encoding");
3582 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3583 if (allength
> MAX_ALLOCA
)
3586 return encoded_string
;
3590 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3597 int counter
= 0, i
= 0;
3607 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3615 /* Wrap line every 76 characters. */
3619 if (counter
< MIME_LINE_LENGTH
/ 4)
3628 /* Process first byte of a triplet. */
3630 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3631 value
= (0x03 & c
) << 4;
3633 /* Process second byte of a triplet. */
3637 *e
++ = base64_value_to_char
[value
];
3645 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3653 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3654 value
= (0x0f & c
) << 2;
3656 /* Process third byte of a triplet. */
3660 *e
++ = base64_value_to_char
[value
];
3667 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3675 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3676 *e
++ = base64_value_to_char
[0x3f & c
];
3683 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3685 doc
: /* Base64-decode the region between BEG and END.
3686 Return the length of the decoded text.
3687 If the region can't be decoded, signal an error and don't modify the buffer. */)
3689 Lisp_Object beg
, end
;
3691 int ibeg
, iend
, length
, allength
;
3696 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3698 validate_region (&beg
, &end
);
3700 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3701 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3703 length
= iend
- ibeg
;
3705 /* We need to allocate enough room for decoding the text. If we are
3706 working on a multibyte buffer, each decoded code may occupy at
3708 allength
= multibyte
? length
* 2 : length
;
3709 if (allength
<= MAX_ALLOCA
)
3710 decoded
= (char *) alloca (allength
);
3712 decoded
= (char *) xmalloc (allength
);
3714 move_gap_both (XFASTINT (beg
), ibeg
);
3715 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3716 multibyte
, &inserted_chars
);
3717 if (decoded_length
> allength
)
3720 if (decoded_length
< 0)
3722 /* The decoding wasn't possible. */
3723 if (allength
> MAX_ALLOCA
)
3725 error ("Invalid base64 data");
3728 /* Now we have decoded the region, so we insert the new contents
3729 and delete the old. (Insert first in order to preserve markers.) */
3730 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3731 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3732 if (allength
> MAX_ALLOCA
)
3734 /* Delete the original text. */
3735 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3736 iend
+ decoded_length
, 1);
3738 /* If point was outside of the region, restore it exactly; else just
3739 move to the beginning of the region. */
3740 if (old_pos
>= XFASTINT (end
))
3741 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3742 else if (old_pos
> XFASTINT (beg
))
3743 old_pos
= XFASTINT (beg
);
3744 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3746 return make_number (inserted_chars
);
3749 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3751 doc
: /* Base64-decode STRING and return the result. */)
3756 int length
, decoded_length
;
3757 Lisp_Object decoded_string
;
3759 CHECK_STRING (string
);
3761 length
= STRING_BYTES (XSTRING (string
));
3762 /* We need to allocate enough room for decoding the text. */
3763 if (length
<= MAX_ALLOCA
)
3764 decoded
= (char *) alloca (length
);
3766 decoded
= (char *) xmalloc (length
);
3768 /* The decoded result should be unibyte. */
3769 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3771 if (decoded_length
> length
)
3773 else if (decoded_length
>= 0)
3774 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3776 decoded_string
= Qnil
;
3778 if (length
> MAX_ALLOCA
)
3780 if (!STRINGP (decoded_string
))
3781 error ("Invalid base64 data");
3783 return decoded_string
;
3786 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3787 MULTIBYTE is nonzero, the decoded result should be in multibyte
3788 form. If NCHARS_RETRUN is not NULL, store the number of produced
3789 characters in *NCHARS_RETURN. */
3792 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3802 unsigned long value
;
3807 /* Process first byte of a quadruplet. */
3809 READ_QUADRUPLET_BYTE (e
-to
);
3813 value
= base64_char_to_value
[c
] << 18;
3815 /* Process second byte of a quadruplet. */
3817 READ_QUADRUPLET_BYTE (-1);
3821 value
|= base64_char_to_value
[c
] << 12;
3823 c
= (unsigned char) (value
>> 16);
3825 e
+= CHAR_STRING (c
, e
);
3830 /* Process third byte of a quadruplet. */
3832 READ_QUADRUPLET_BYTE (-1);
3836 READ_QUADRUPLET_BYTE (-1);
3845 value
|= base64_char_to_value
[c
] << 6;
3847 c
= (unsigned char) (0xff & value
>> 8);
3849 e
+= CHAR_STRING (c
, e
);
3854 /* Process fourth byte of a quadruplet. */
3856 READ_QUADRUPLET_BYTE (-1);
3863 value
|= base64_char_to_value
[c
];
3865 c
= (unsigned char) (0xff & value
);
3867 e
+= CHAR_STRING (c
, e
);
3876 /***********************************************************************
3878 ***** Hash Tables *****
3880 ***********************************************************************/
3882 /* Implemented by gerd@gnu.org. This hash table implementation was
3883 inspired by CMUCL hash tables. */
3887 1. For small tables, association lists are probably faster than
3888 hash tables because they have lower overhead.
3890 For uses of hash tables where the O(1) behavior of table
3891 operations is not a requirement, it might therefore be a good idea
3892 not to hash. Instead, we could just do a linear search in the
3893 key_and_value vector of the hash table. This could be done
3894 if a `:linear-search t' argument is given to make-hash-table. */
3897 /* Value is the key part of entry IDX in hash table H. */
3899 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3901 /* Value is the value part of entry IDX in hash table H. */
3903 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3905 /* Value is the index of the next entry following the one at IDX
3908 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3910 /* Value is the hash code computed for entry IDX in hash table H. */
3912 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3914 /* Value is the index of the element in hash table H that is the
3915 start of the collision list at index IDX in the index vector of H. */
3917 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3919 /* Value is the size of hash table H. */
3921 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3923 /* The list of all weak hash tables. Don't staticpro this one. */
3925 Lisp_Object Vweak_hash_tables
;
3927 /* Various symbols. */
3929 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3930 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3931 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3933 /* Function prototypes. */
3935 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3936 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3937 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3938 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3939 Lisp_Object
, unsigned));
3940 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3941 Lisp_Object
, unsigned));
3942 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3943 unsigned, Lisp_Object
, unsigned));
3944 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3945 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3946 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3947 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3949 static unsigned sxhash_string
P_ ((unsigned char *, int));
3950 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3951 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3952 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3953 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3957 /***********************************************************************
3959 ***********************************************************************/
3961 /* If OBJ is a Lisp hash table, return a pointer to its struct
3962 Lisp_Hash_Table. Otherwise, signal an error. */
3964 static struct Lisp_Hash_Table
*
3965 check_hash_table (obj
)
3968 CHECK_HASH_TABLE (obj
);
3969 return XHASH_TABLE (obj
);
3973 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3977 next_almost_prime (n
)
3990 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3991 which USED[I] is non-zero. If found at index I in ARGS, set
3992 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3993 -1. This function is used to extract a keyword/argument pair from
3994 a DEFUN parameter list. */
3997 get_key_arg (key
, nargs
, args
, used
)
4005 for (i
= 0; i
< nargs
- 1; ++i
)
4006 if (!used
[i
] && EQ (args
[i
], key
))
4021 /* Return a Lisp vector which has the same contents as VEC but has
4022 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4023 vector that are not copied from VEC are set to INIT. */
4026 larger_vector (vec
, new_size
, init
)
4031 struct Lisp_Vector
*v
;
4034 xassert (VECTORP (vec
));
4035 old_size
= XVECTOR (vec
)->size
;
4036 xassert (new_size
>= old_size
);
4038 v
= allocate_vector (new_size
);
4039 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4040 old_size
* sizeof *v
->contents
);
4041 for (i
= old_size
; i
< new_size
; ++i
)
4042 v
->contents
[i
] = init
;
4043 XSETVECTOR (vec
, v
);
4048 /***********************************************************************
4050 ***********************************************************************/
4052 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4053 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4054 KEY2 are the same. */
4057 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4058 struct Lisp_Hash_Table
*h
;
4059 Lisp_Object key1
, key2
;
4060 unsigned hash1
, hash2
;
4062 return (FLOATP (key1
)
4064 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4068 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4069 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4070 KEY2 are the same. */
4073 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4074 struct Lisp_Hash_Table
*h
;
4075 Lisp_Object key1
, key2
;
4076 unsigned hash1
, hash2
;
4078 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4082 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4083 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4084 if KEY1 and KEY2 are the same. */
4087 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4088 struct Lisp_Hash_Table
*h
;
4089 Lisp_Object key1
, key2
;
4090 unsigned hash1
, hash2
;
4094 Lisp_Object args
[3];
4096 args
[0] = h
->user_cmp_function
;
4099 return !NILP (Ffuncall (3, args
));
4106 /* Value is a hash code for KEY for use in hash table H which uses
4107 `eq' to compare keys. The hash code returned is guaranteed to fit
4108 in a Lisp integer. */
4112 struct Lisp_Hash_Table
*h
;
4115 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4116 xassert ((hash
& ~VALMASK
) == 0);
4121 /* Value is a hash code for KEY for use in hash table H which uses
4122 `eql' to compare keys. The hash code returned is guaranteed to fit
4123 in a Lisp integer. */
4127 struct Lisp_Hash_Table
*h
;
4132 hash
= sxhash (key
, 0);
4134 hash
= XUINT (key
) ^ XGCTYPE (key
);
4135 xassert ((hash
& ~VALMASK
) == 0);
4140 /* Value is a hash code for KEY for use in hash table H which uses
4141 `equal' to compare keys. The hash code returned is guaranteed to fit
4142 in a Lisp integer. */
4145 hashfn_equal (h
, key
)
4146 struct Lisp_Hash_Table
*h
;
4149 unsigned hash
= sxhash (key
, 0);
4150 xassert ((hash
& ~VALMASK
) == 0);
4155 /* Value is a hash code for KEY for use in hash table H which uses as
4156 user-defined function to compare keys. The hash code returned is
4157 guaranteed to fit in a Lisp integer. */
4160 hashfn_user_defined (h
, key
)
4161 struct Lisp_Hash_Table
*h
;
4164 Lisp_Object args
[2], hash
;
4166 args
[0] = h
->user_hash_function
;
4168 hash
= Ffuncall (2, args
);
4169 if (!INTEGERP (hash
))
4171 list2 (build_string ("Invalid hash code returned from \
4172 user-supplied hash function"),
4174 return XUINT (hash
);
4178 /* Create and initialize a new hash table.
4180 TEST specifies the test the hash table will use to compare keys.
4181 It must be either one of the predefined tests `eq', `eql' or
4182 `equal' or a symbol denoting a user-defined test named TEST with
4183 test and hash functions USER_TEST and USER_HASH.
4185 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4187 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4188 new size when it becomes full is computed by adding REHASH_SIZE to
4189 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4190 table's new size is computed by multiplying its old size with
4193 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4194 be resized when the ratio of (number of entries in the table) /
4195 (table size) is >= REHASH_THRESHOLD.
4197 WEAK specifies the weakness of the table. If non-nil, it must be
4198 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4201 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4202 user_test
, user_hash
)
4203 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4204 Lisp_Object user_test
, user_hash
;
4206 struct Lisp_Hash_Table
*h
;
4208 int index_size
, i
, sz
;
4210 /* Preconditions. */
4211 xassert (SYMBOLP (test
));
4212 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4213 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4214 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4215 xassert (FLOATP (rehash_threshold
)
4216 && XFLOATINT (rehash_threshold
) > 0
4217 && XFLOATINT (rehash_threshold
) <= 1.0);
4219 if (XFASTINT (size
) == 0)
4220 size
= make_number (1);
4222 /* Allocate a table and initialize it. */
4223 h
= allocate_hash_table ();
4225 /* Initialize hash table slots. */
4226 sz
= XFASTINT (size
);
4229 if (EQ (test
, Qeql
))
4231 h
->cmpfn
= cmpfn_eql
;
4232 h
->hashfn
= hashfn_eql
;
4234 else if (EQ (test
, Qeq
))
4237 h
->hashfn
= hashfn_eq
;
4239 else if (EQ (test
, Qequal
))
4241 h
->cmpfn
= cmpfn_equal
;
4242 h
->hashfn
= hashfn_equal
;
4246 h
->user_cmp_function
= user_test
;
4247 h
->user_hash_function
= user_hash
;
4248 h
->cmpfn
= cmpfn_user_defined
;
4249 h
->hashfn
= hashfn_user_defined
;
4253 h
->rehash_threshold
= rehash_threshold
;
4254 h
->rehash_size
= rehash_size
;
4255 h
->count
= make_number (0);
4256 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4257 h
->hash
= Fmake_vector (size
, Qnil
);
4258 h
->next
= Fmake_vector (size
, Qnil
);
4259 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4260 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4261 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4263 /* Set up the free list. */
4264 for (i
= 0; i
< sz
- 1; ++i
)
4265 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4266 h
->next_free
= make_number (0);
4268 XSET_HASH_TABLE (table
, h
);
4269 xassert (HASH_TABLE_P (table
));
4270 xassert (XHASH_TABLE (table
) == h
);
4272 /* Maybe add this hash table to the list of all weak hash tables. */
4274 h
->next_weak
= Qnil
;
4277 h
->next_weak
= Vweak_hash_tables
;
4278 Vweak_hash_tables
= table
;
4285 /* Return a copy of hash table H1. Keys and values are not copied,
4286 only the table itself is. */
4289 copy_hash_table (h1
)
4290 struct Lisp_Hash_Table
*h1
;
4293 struct Lisp_Hash_Table
*h2
;
4294 struct Lisp_Vector
*next
;
4296 h2
= allocate_hash_table ();
4297 next
= h2
->vec_next
;
4298 bcopy (h1
, h2
, sizeof *h2
);
4299 h2
->vec_next
= next
;
4300 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4301 h2
->hash
= Fcopy_sequence (h1
->hash
);
4302 h2
->next
= Fcopy_sequence (h1
->next
);
4303 h2
->index
= Fcopy_sequence (h1
->index
);
4304 XSET_HASH_TABLE (table
, h2
);
4306 /* Maybe add this hash table to the list of all weak hash tables. */
4307 if (!NILP (h2
->weak
))
4309 h2
->next_weak
= Vweak_hash_tables
;
4310 Vweak_hash_tables
= table
;
4317 /* Resize hash table H if it's too full. If H cannot be resized
4318 because it's already too large, throw an error. */
4321 maybe_resize_hash_table (h
)
4322 struct Lisp_Hash_Table
*h
;
4324 if (NILP (h
->next_free
))
4326 int old_size
= HASH_TABLE_SIZE (h
);
4327 int i
, new_size
, index_size
;
4329 if (INTEGERP (h
->rehash_size
))
4330 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4332 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4333 new_size
= max (old_size
+ 1, new_size
);
4334 index_size
= next_almost_prime ((int)
4336 / XFLOATINT (h
->rehash_threshold
)));
4337 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4338 error ("Hash table too large to resize");
4340 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4341 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4342 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4343 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4345 /* Update the free list. Do it so that new entries are added at
4346 the end of the free list. This makes some operations like
4348 for (i
= old_size
; i
< new_size
- 1; ++i
)
4349 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4351 if (!NILP (h
->next_free
))
4353 Lisp_Object last
, next
;
4355 last
= h
->next_free
;
4356 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4360 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4363 XSETFASTINT (h
->next_free
, old_size
);
4366 for (i
= 0; i
< old_size
; ++i
)
4367 if (!NILP (HASH_HASH (h
, i
)))
4369 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4370 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4371 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4372 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4378 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4379 the hash code of KEY. Value is the index of the entry in H
4380 matching KEY, or -1 if not found. */
4383 hash_lookup (h
, key
, hash
)
4384 struct Lisp_Hash_Table
*h
;
4389 int start_of_bucket
;
4392 hash_code
= h
->hashfn (h
, key
);
4396 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4397 idx
= HASH_INDEX (h
, start_of_bucket
);
4399 /* We need not gcpro idx since it's either an integer or nil. */
4402 int i
= XFASTINT (idx
);
4403 if (EQ (key
, HASH_KEY (h
, i
))
4405 && h
->cmpfn (h
, key
, hash_code
,
4406 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4408 idx
= HASH_NEXT (h
, i
);
4411 return NILP (idx
) ? -1 : XFASTINT (idx
);
4415 /* Put an entry into hash table H that associates KEY with VALUE.
4416 HASH is a previously computed hash code of KEY.
4417 Value is the index of the entry in H matching KEY. */
4420 hash_put (h
, key
, value
, hash
)
4421 struct Lisp_Hash_Table
*h
;
4422 Lisp_Object key
, value
;
4425 int start_of_bucket
, i
;
4427 xassert ((hash
& ~VALMASK
) == 0);
4429 /* Increment count after resizing because resizing may fail. */
4430 maybe_resize_hash_table (h
);
4431 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4433 /* Store key/value in the key_and_value vector. */
4434 i
= XFASTINT (h
->next_free
);
4435 h
->next_free
= HASH_NEXT (h
, i
);
4436 HASH_KEY (h
, i
) = key
;
4437 HASH_VALUE (h
, i
) = value
;
4439 /* Remember its hash code. */
4440 HASH_HASH (h
, i
) = make_number (hash
);
4442 /* Add new entry to its collision chain. */
4443 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4444 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4445 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4450 /* Remove the entry matching KEY from hash table H, if there is one. */
4453 hash_remove (h
, key
)
4454 struct Lisp_Hash_Table
*h
;
4458 int start_of_bucket
;
4459 Lisp_Object idx
, prev
;
4461 hash_code
= h
->hashfn (h
, key
);
4462 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4463 idx
= HASH_INDEX (h
, start_of_bucket
);
4466 /* We need not gcpro idx, prev since they're either integers or nil. */
4469 int i
= XFASTINT (idx
);
4471 if (EQ (key
, HASH_KEY (h
, i
))
4473 && h
->cmpfn (h
, key
, hash_code
,
4474 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4476 /* Take entry out of collision chain. */
4478 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4480 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4482 /* Clear slots in key_and_value and add the slots to
4484 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4485 HASH_NEXT (h
, i
) = h
->next_free
;
4486 h
->next_free
= make_number (i
);
4487 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4488 xassert (XINT (h
->count
) >= 0);
4494 idx
= HASH_NEXT (h
, i
);
4500 /* Clear hash table H. */
4504 struct Lisp_Hash_Table
*h
;
4506 if (XFASTINT (h
->count
) > 0)
4508 int i
, size
= HASH_TABLE_SIZE (h
);
4510 for (i
= 0; i
< size
; ++i
)
4512 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4513 HASH_KEY (h
, i
) = Qnil
;
4514 HASH_VALUE (h
, i
) = Qnil
;
4515 HASH_HASH (h
, i
) = Qnil
;
4518 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4519 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4521 h
->next_free
= make_number (0);
4522 h
->count
= make_number (0);
4528 /************************************************************************
4530 ************************************************************************/
4532 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4533 entries from the table that don't survive the current GC.
4534 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4535 non-zero if anything was marked. */
4538 sweep_weak_table (h
, remove_entries_p
)
4539 struct Lisp_Hash_Table
*h
;
4540 int remove_entries_p
;
4542 int bucket
, n
, marked
;
4544 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4547 for (bucket
= 0; bucket
< n
; ++bucket
)
4549 Lisp_Object idx
, next
, prev
;
4551 /* Follow collision chain, removing entries that
4552 don't survive this garbage collection. */
4554 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4556 int i
= XFASTINT (idx
);
4557 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4558 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4561 if (EQ (h
->weak
, Qkey
))
4562 remove_p
= !key_known_to_survive_p
;
4563 else if (EQ (h
->weak
, Qvalue
))
4564 remove_p
= !value_known_to_survive_p
;
4565 else if (EQ (h
->weak
, Qkey_or_value
))
4566 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4567 else if (EQ (h
->weak
, Qkey_and_value
))
4568 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4572 next
= HASH_NEXT (h
, i
);
4574 if (remove_entries_p
)
4578 /* Take out of collision chain. */
4580 HASH_INDEX (h
, bucket
) = next
;
4582 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4584 /* Add to free list. */
4585 HASH_NEXT (h
, i
) = h
->next_free
;
4588 /* Clear key, value, and hash. */
4589 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4590 HASH_HASH (h
, i
) = Qnil
;
4592 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4599 /* Make sure key and value survive. */
4600 if (!key_known_to_survive_p
)
4602 mark_object (&HASH_KEY (h
, i
));
4606 if (!value_known_to_survive_p
)
4608 mark_object (&HASH_VALUE (h
, i
));
4619 /* Remove elements from weak hash tables that don't survive the
4620 current garbage collection. Remove weak tables that don't survive
4621 from Vweak_hash_tables. Called from gc_sweep. */
4624 sweep_weak_hash_tables ()
4626 Lisp_Object table
, used
, next
;
4627 struct Lisp_Hash_Table
*h
;
4630 /* Mark all keys and values that are in use. Keep on marking until
4631 there is no more change. This is necessary for cases like
4632 value-weak table A containing an entry X -> Y, where Y is used in a
4633 key-weak table B, Z -> Y. If B comes after A in the list of weak
4634 tables, X -> Y might be removed from A, although when looking at B
4635 one finds that it shouldn't. */
4639 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4641 h
= XHASH_TABLE (table
);
4642 if (h
->size
& ARRAY_MARK_FLAG
)
4643 marked
|= sweep_weak_table (h
, 0);
4648 /* Remove tables and entries that aren't used. */
4649 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4651 h
= XHASH_TABLE (table
);
4652 next
= h
->next_weak
;
4654 if (h
->size
& ARRAY_MARK_FLAG
)
4656 /* TABLE is marked as used. Sweep its contents. */
4657 if (XFASTINT (h
->count
) > 0)
4658 sweep_weak_table (h
, 1);
4660 /* Add table to the list of used weak hash tables. */
4661 h
->next_weak
= used
;
4666 Vweak_hash_tables
= used
;
4671 /***********************************************************************
4672 Hash Code Computation
4673 ***********************************************************************/
4675 /* Maximum depth up to which to dive into Lisp structures. */
4677 #define SXHASH_MAX_DEPTH 3
4679 /* Maximum length up to which to take list and vector elements into
4682 #define SXHASH_MAX_LEN 7
4684 /* Combine two integers X and Y for hashing. */
4686 #define SXHASH_COMBINE(X, Y) \
4687 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4691 /* Return a hash for string PTR which has length LEN. The hash
4692 code returned is guaranteed to fit in a Lisp integer. */
4695 sxhash_string (ptr
, len
)
4699 unsigned char *p
= ptr
;
4700 unsigned char *end
= p
+ len
;
4709 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4712 return hash
& VALMASK
;
4716 /* Return a hash for list LIST. DEPTH is the current depth in the
4717 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4720 sxhash_list (list
, depth
)
4727 if (depth
< SXHASH_MAX_DEPTH
)
4729 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4730 list
= XCDR (list
), ++i
)
4732 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4733 hash
= SXHASH_COMBINE (hash
, hash2
);
4740 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4741 the Lisp structure. */
4744 sxhash_vector (vec
, depth
)
4748 unsigned hash
= XVECTOR (vec
)->size
;
4751 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4752 for (i
= 0; i
< n
; ++i
)
4754 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4755 hash
= SXHASH_COMBINE (hash
, hash2
);
4762 /* Return a hash for bool-vector VECTOR. */
4765 sxhash_bool_vector (vec
)
4768 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4771 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4772 for (i
= 0; i
< n
; ++i
)
4773 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4779 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4780 structure. Value is an unsigned integer clipped to VALMASK. */
4789 if (depth
> SXHASH_MAX_DEPTH
)
4792 switch (XTYPE (obj
))
4799 hash
= sxhash_string (XSTRING (SYMBOL_NAME (obj
))->data
,
4800 XSTRING (SYMBOL_NAME (obj
))->size
);
4808 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4811 /* This can be everything from a vector to an overlay. */
4812 case Lisp_Vectorlike
:
4814 /* According to the CL HyperSpec, two arrays are equal only if
4815 they are `eq', except for strings and bit-vectors. In
4816 Emacs, this works differently. We have to compare element
4818 hash
= sxhash_vector (obj
, depth
);
4819 else if (BOOL_VECTOR_P (obj
))
4820 hash
= sxhash_bool_vector (obj
);
4822 /* Others are `equal' if they are `eq', so let's take their
4828 hash
= sxhash_list (obj
, depth
);
4833 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4834 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4835 for (hash
= 0; p
< e
; ++p
)
4836 hash
= SXHASH_COMBINE (hash
, *p
);
4844 return hash
& VALMASK
;
4849 /***********************************************************************
4851 ***********************************************************************/
4854 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4855 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4859 unsigned hash
= sxhash (obj
, 0);;
4860 return make_number (hash
);
4864 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4865 doc
: /* Create and return a new hash table.
4867 Arguments are specified as keyword/argument pairs. The following
4868 arguments are defined:
4870 :test TEST -- TEST must be a symbol that specifies how to compare
4871 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4872 `equal'. User-supplied test and hash functions can be specified via
4873 `define-hash-table-test'.
4875 :size SIZE -- A hint as to how many elements will be put in the table.
4878 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4879 fills up. If REHASH-SIZE is an integer, add that many space. If it
4880 is a float, it must be > 1.0, and the new size is computed by
4881 multiplying the old size with that factor. Default is 1.5.
4883 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4884 Resize the hash table when ratio of the number of entries in the
4885 table. Default is 0.8.
4887 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4888 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4889 returned is a weak table. Key/value pairs are removed from a weak
4890 hash table when there are no non-weak references pointing to their
4891 key, value, one of key or value, or both key and value, depending on
4892 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4895 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4900 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4901 Lisp_Object user_test
, user_hash
;
4905 /* The vector `used' is used to keep track of arguments that
4906 have been consumed. */
4907 used
= (char *) alloca (nargs
* sizeof *used
);
4908 bzero (used
, nargs
* sizeof *used
);
4910 /* See if there's a `:test TEST' among the arguments. */
4911 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4912 test
= i
< 0 ? Qeql
: args
[i
];
4913 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4915 /* See if it is a user-defined test. */
4918 prop
= Fget (test
, Qhash_table_test
);
4919 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4920 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4922 user_test
= XCAR (prop
);
4923 user_hash
= XCAR (XCDR (prop
));
4926 user_test
= user_hash
= Qnil
;
4928 /* See if there's a `:size SIZE' argument. */
4929 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4930 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4931 if (!INTEGERP (size
) || XINT (size
) < 0)
4933 list2 (build_string ("Invalid hash table size"),
4936 /* Look for `:rehash-size SIZE'. */
4937 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4938 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4939 if (!NUMBERP (rehash_size
)
4940 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4941 || XFLOATINT (rehash_size
) <= 1.0)
4943 list2 (build_string ("Invalid hash table rehash size"),
4946 /* Look for `:rehash-threshold THRESHOLD'. */
4947 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4948 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4949 if (!FLOATP (rehash_threshold
)
4950 || XFLOATINT (rehash_threshold
) <= 0.0
4951 || XFLOATINT (rehash_threshold
) > 1.0)
4953 list2 (build_string ("Invalid hash table rehash threshold"),
4956 /* Look for `:weakness WEAK'. */
4957 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4958 weak
= i
< 0 ? Qnil
: args
[i
];
4960 weak
= Qkey_and_value
;
4963 && !EQ (weak
, Qvalue
)
4964 && !EQ (weak
, Qkey_or_value
)
4965 && !EQ (weak
, Qkey_and_value
))
4966 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4969 /* Now, all args should have been used up, or there's a problem. */
4970 for (i
= 0; i
< nargs
; ++i
)
4973 list2 (build_string ("Invalid argument list"), args
[i
]));
4975 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4976 user_test
, user_hash
);
4980 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4981 doc
: /* Return a copy of hash table TABLE. */)
4985 return copy_hash_table (check_hash_table (table
));
4989 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4990 doc
: /* Create a new hash table.
4992 Optional first argument TEST specifies how to compare keys in the
4993 table. Predefined tests are `eq', `eql', and `equal'. Default is
4994 `eql'. New tests can be defined with `define-hash-table-test'. */)
4998 Lisp_Object args
[2];
5000 args
[1] = NILP (test
) ? Qeql
: test
;
5001 return Fmake_hash_table (2, args
);
5005 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5006 doc
: /* Return the number of elements in TABLE. */)
5010 return check_hash_table (table
)->count
;
5014 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5015 Shash_table_rehash_size
, 1, 1, 0,
5016 doc
: /* Return the current rehash size of TABLE. */)
5020 return check_hash_table (table
)->rehash_size
;
5024 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5025 Shash_table_rehash_threshold
, 1, 1, 0,
5026 doc
: /* Return the current rehash threshold of TABLE. */)
5030 return check_hash_table (table
)->rehash_threshold
;
5034 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5035 doc
: /* Return the size of TABLE.
5036 The size can be used as an argument to `make-hash-table' to create
5037 a hash table than can hold as many elements of TABLE holds
5038 without need for resizing. */)
5042 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5043 return make_number (HASH_TABLE_SIZE (h
));
5047 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5048 doc
: /* Return the test TABLE uses. */)
5052 return check_hash_table (table
)->test
;
5056 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5058 doc
: /* Return the weakness of TABLE. */)
5062 return check_hash_table (table
)->weak
;
5066 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5067 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5071 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5075 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5076 doc
: /* Clear hash table TABLE. */)
5080 hash_clear (check_hash_table (table
));
5085 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5086 doc
: /* Look up KEY in TABLE and return its associated value.
5087 If KEY is not found, return DFLT which defaults to nil. */)
5089 Lisp_Object key
, table
, dflt
;
5091 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5092 int i
= hash_lookup (h
, key
, NULL
);
5093 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5097 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5098 doc
: /* Associate KEY with VALUE in hash table TABLE.
5099 If KEY is already present in table, replace its current value with
5102 Lisp_Object key
, value
, table
;
5104 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5108 i
= hash_lookup (h
, key
, &hash
);
5110 HASH_VALUE (h
, i
) = value
;
5112 hash_put (h
, key
, value
, hash
);
5118 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5119 doc
: /* Remove KEY from TABLE. */)
5121 Lisp_Object key
, table
;
5123 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5124 hash_remove (h
, key
);
5129 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5130 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5131 FUNCTION is called with 2 arguments KEY and VALUE. */)
5133 Lisp_Object function
, table
;
5135 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5136 Lisp_Object args
[3];
5139 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5140 if (!NILP (HASH_HASH (h
, i
)))
5143 args
[1] = HASH_KEY (h
, i
);
5144 args
[2] = HASH_VALUE (h
, i
);
5152 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5153 Sdefine_hash_table_test
, 3, 3, 0,
5154 doc
: /* Define a new hash table test with name NAME, a symbol.
5156 In hash tables created with NAME specified as test, use TEST to
5157 compare keys, and HASH for computing hash codes of keys.
5159 TEST must be a function taking two arguments and returning non-nil if
5160 both arguments are the same. HASH must be a function taking one
5161 argument and return an integer that is the hash code of the argument.
5162 Hash code computation should use the whole value range of integers,
5163 including negative integers. */)
5165 Lisp_Object name
, test
, hash
;
5167 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5172 /************************************************************************
5174 ************************************************************************/
5179 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5180 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5182 A message digest is a cryptographic checksum of a document, and the
5183 algorithm to calculate it is defined in RFC 1321.
5185 The two optional arguments START and END are character positions
5186 specifying for which part of OBJECT the message digest should be
5187 computed. If nil or omitted, the digest is computed for the whole
5190 The MD5 message digest is computed from the result of encoding the
5191 text in a coding system, not directly from the internal Emacs form of
5192 the text. The optional fourth argument CODING-SYSTEM specifies which
5193 coding system to encode the text with. It should be the same coding
5194 system that you used or will use when actually writing the text into a
5197 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5198 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5199 system would be chosen by default for writing this text into a file.
5201 If OBJECT is a string, the most preferred coding system (see the
5202 command `prefer-coding-system') is used.
5204 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5205 guesswork fails. Normally, an error is signaled in such case. */)
5206 (object
, start
, end
, coding_system
, noerror
)
5207 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5209 unsigned char digest
[16];
5210 unsigned char value
[33];
5214 int start_char
= 0, end_char
= 0;
5215 int start_byte
= 0, end_byte
= 0;
5217 register struct buffer
*bp
;
5220 if (STRINGP (object
))
5222 if (NILP (coding_system
))
5224 /* Decide the coding-system to encode the data with. */
5226 if (STRING_MULTIBYTE (object
))
5227 /* use default, we can't guess correct value */
5228 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5230 coding_system
= Qraw_text
;
5233 if (NILP (Fcoding_system_p (coding_system
)))
5235 /* Invalid coding system. */
5237 if (!NILP (noerror
))
5238 coding_system
= Qraw_text
;
5241 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5244 if (STRING_MULTIBYTE (object
))
5245 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5247 size
= XSTRING (object
)->size
;
5248 size_byte
= STRING_BYTES (XSTRING (object
));
5252 CHECK_NUMBER (start
);
5254 start_char
= XINT (start
);
5259 start_byte
= string_char_to_byte (object
, start_char
);
5265 end_byte
= size_byte
;
5271 end_char
= XINT (end
);
5276 end_byte
= string_char_to_byte (object
, end_char
);
5279 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5280 args_out_of_range_3 (object
, make_number (start_char
),
5281 make_number (end_char
));
5285 CHECK_BUFFER (object
);
5287 bp
= XBUFFER (object
);
5293 CHECK_NUMBER_COERCE_MARKER (start
);
5301 CHECK_NUMBER_COERCE_MARKER (end
);
5306 temp
= b
, b
= e
, e
= temp
;
5308 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5309 args_out_of_range (start
, end
);
5311 if (NILP (coding_system
))
5313 /* Decide the coding-system to encode the data with.
5314 See fileio.c:Fwrite-region */
5316 if (!NILP (Vcoding_system_for_write
))
5317 coding_system
= Vcoding_system_for_write
;
5320 int force_raw_text
= 0;
5322 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5323 if (NILP (coding_system
)
5324 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5326 coding_system
= Qnil
;
5327 if (NILP (current_buffer
->enable_multibyte_characters
))
5331 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5333 /* Check file-coding-system-alist. */
5334 Lisp_Object args
[4], val
;
5336 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5337 args
[3] = Fbuffer_file_name(object
);
5338 val
= Ffind_operation_coding_system (4, args
);
5339 if (CONSP (val
) && !NILP (XCDR (val
)))
5340 coding_system
= XCDR (val
);
5343 if (NILP (coding_system
)
5344 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5346 /* If we still have not decided a coding system, use the
5347 default value of buffer-file-coding-system. */
5348 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5352 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5353 /* Confirm that VAL can surely encode the current region. */
5354 coding_system
= call3 (Vselect_safe_coding_system_function
,
5355 make_number (b
), make_number (e
),
5359 coding_system
= Qraw_text
;
5362 if (NILP (Fcoding_system_p (coding_system
)))
5364 /* Invalid coding system. */
5366 if (!NILP (noerror
))
5367 coding_system
= Qraw_text
;
5370 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5374 object
= make_buffer_string (b
, e
, 0);
5376 if (STRING_MULTIBYTE (object
))
5377 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5380 md5_buffer (XSTRING (object
)->data
+ start_byte
,
5381 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
5384 for (i
= 0; i
< 16; i
++)
5385 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5388 return make_string (value
, 32);
5395 /* Hash table stuff. */
5396 Qhash_table_p
= intern ("hash-table-p");
5397 staticpro (&Qhash_table_p
);
5398 Qeq
= intern ("eq");
5400 Qeql
= intern ("eql");
5402 Qequal
= intern ("equal");
5403 staticpro (&Qequal
);
5404 QCtest
= intern (":test");
5405 staticpro (&QCtest
);
5406 QCsize
= intern (":size");
5407 staticpro (&QCsize
);
5408 QCrehash_size
= intern (":rehash-size");
5409 staticpro (&QCrehash_size
);
5410 QCrehash_threshold
= intern (":rehash-threshold");
5411 staticpro (&QCrehash_threshold
);
5412 QCweakness
= intern (":weakness");
5413 staticpro (&QCweakness
);
5414 Qkey
= intern ("key");
5416 Qvalue
= intern ("value");
5417 staticpro (&Qvalue
);
5418 Qhash_table_test
= intern ("hash-table-test");
5419 staticpro (&Qhash_table_test
);
5420 Qkey_or_value
= intern ("key-or-value");
5421 staticpro (&Qkey_or_value
);
5422 Qkey_and_value
= intern ("key-and-value");
5423 staticpro (&Qkey_and_value
);
5426 defsubr (&Smake_hash_table
);
5427 defsubr (&Scopy_hash_table
);
5428 defsubr (&Smakehash
);
5429 defsubr (&Shash_table_count
);
5430 defsubr (&Shash_table_rehash_size
);
5431 defsubr (&Shash_table_rehash_threshold
);
5432 defsubr (&Shash_table_size
);
5433 defsubr (&Shash_table_test
);
5434 defsubr (&Shash_table_weakness
);
5435 defsubr (&Shash_table_p
);
5436 defsubr (&Sclrhash
);
5437 defsubr (&Sgethash
);
5438 defsubr (&Sputhash
);
5439 defsubr (&Sremhash
);
5440 defsubr (&Smaphash
);
5441 defsubr (&Sdefine_hash_table_test
);
5443 Qstring_lessp
= intern ("string-lessp");
5444 staticpro (&Qstring_lessp
);
5445 Qprovide
= intern ("provide");
5446 staticpro (&Qprovide
);
5447 Qrequire
= intern ("require");
5448 staticpro (&Qrequire
);
5449 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5450 staticpro (&Qyes_or_no_p_history
);
5451 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5452 staticpro (&Qcursor_in_echo_area
);
5453 Qwidget_type
= intern ("widget-type");
5454 staticpro (&Qwidget_type
);
5456 staticpro (&string_char_byte_cache_string
);
5457 string_char_byte_cache_string
= Qnil
;
5459 require_nesting_list
= Qnil
;
5460 staticpro (&require_nesting_list
);
5462 Fset (Qyes_or_no_p_history
, Qnil
);
5464 DEFVAR_LISP ("features", &Vfeatures
,
5465 doc
: /* A list of symbols which are the features of the executing emacs.
5466 Used by `featurep' and `require', and altered by `provide'. */);
5468 Qsubfeatures
= intern ("subfeatures");
5469 staticpro (&Qsubfeatures
);
5471 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5472 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5473 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5474 invoked by mouse clicks and mouse menu items. */);
5477 defsubr (&Sidentity
);
5480 defsubr (&Ssafe_length
);
5481 defsubr (&Sstring_bytes
);
5482 defsubr (&Sstring_equal
);
5483 defsubr (&Scompare_strings
);
5484 defsubr (&Sstring_lessp
);
5487 defsubr (&Svconcat
);
5488 defsubr (&Scopy_sequence
);
5489 defsubr (&Sstring_make_multibyte
);
5490 defsubr (&Sstring_make_unibyte
);
5491 defsubr (&Sstring_as_multibyte
);
5492 defsubr (&Sstring_as_unibyte
);
5493 defsubr (&Scopy_alist
);
5494 defsubr (&Ssubstring
);
5495 defsubr (&Ssubstring_no_properties
);
5507 defsubr (&Snreverse
);
5508 defsubr (&Sreverse
);
5510 defsubr (&Splist_get
);
5512 defsubr (&Splist_put
);
5514 defsubr (&Slax_plist_get
);
5515 defsubr (&Slax_plist_put
);
5517 defsubr (&Sfillarray
);
5518 defsubr (&Schar_table_subtype
);
5519 defsubr (&Schar_table_parent
);
5520 defsubr (&Sset_char_table_parent
);
5521 defsubr (&Schar_table_extra_slot
);
5522 defsubr (&Sset_char_table_extra_slot
);
5523 defsubr (&Schar_table_range
);
5524 defsubr (&Sset_char_table_range
);
5525 defsubr (&Sset_char_table_default
);
5526 defsubr (&Soptimize_char_table
);
5527 defsubr (&Smap_char_table
);
5531 defsubr (&Smapconcat
);
5532 defsubr (&Sy_or_n_p
);
5533 defsubr (&Syes_or_no_p
);
5534 defsubr (&Sload_average
);
5535 defsubr (&Sfeaturep
);
5536 defsubr (&Srequire
);
5537 defsubr (&Sprovide
);
5538 defsubr (&Splist_member
);
5539 defsubr (&Swidget_put
);
5540 defsubr (&Swidget_get
);
5541 defsubr (&Swidget_apply
);
5542 defsubr (&Sbase64_encode_region
);
5543 defsubr (&Sbase64_decode_region
);
5544 defsubr (&Sbase64_encode_string
);
5545 defsubr (&Sbase64_decode_string
);
5553 Vweak_hash_tables
= Qnil
;