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 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
224 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
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 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
351 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
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 is a symbol and VAL is any object.
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 ();
2972 message_with_string ("%s(y or n) ", xprompt
, 0);
2974 if (minibuffer_auto_raise
)
2976 Lisp_Object mini_frame
;
2978 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2980 Fraise_frame (mini_frame
);
2983 obj
= read_filtered_event (1, 0, 0, 0);
2984 cursor_in_echo_area
= 0;
2985 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2988 key
= Fmake_vector (make_number (1), obj
);
2989 def
= Flookup_key (map
, key
, Qt
);
2991 if (EQ (def
, intern ("skip")))
2996 else if (EQ (def
, intern ("act")))
3001 else if (EQ (def
, intern ("recenter")))
3007 else if (EQ (def
, intern ("quit")))
3009 /* We want to exit this command for exit-prefix,
3010 and this is the only way to do it. */
3011 else if (EQ (def
, intern ("exit-prefix")))
3016 /* If we don't clear this, then the next call to read_char will
3017 return quit_char again, and we'll enter an infinite loop. */
3022 if (EQ (xprompt
, prompt
))
3024 args
[0] = build_string ("Please answer y or n. ");
3026 xprompt
= Fconcat (2, args
);
3031 if (! noninteractive
)
3033 cursor_in_echo_area
= -1;
3034 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3038 unbind_to (count
, Qnil
);
3039 return answer
? Qt
: Qnil
;
3042 /* This is how C code calls `yes-or-no-p' and allows the user
3045 Anything that calls this function must protect from GC! */
3048 do_yes_or_no_p (prompt
)
3051 return call1 (intern ("yes-or-no-p"), prompt
);
3054 /* Anything that calls this function must protect from GC! */
3056 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3057 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3058 Takes one argument, which is the string to display to ask the question.
3059 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3060 The user must confirm the answer with RET,
3061 and can edit it until it has been confirmed.
3063 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3064 is nil, and `use-dialog-box' is non-nil. */)
3068 register Lisp_Object ans
;
3069 Lisp_Object args
[2];
3070 struct gcpro gcpro1
;
3072 CHECK_STRING (prompt
);
3075 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3079 Lisp_Object pane
, menu
, obj
;
3080 redisplay_preserve_echo_area (4);
3081 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3082 Fcons (Fcons (build_string ("No"), Qnil
),
3085 menu
= Fcons (prompt
, pane
);
3086 obj
= Fx_popup_dialog (Qt
, menu
);
3090 #endif /* HAVE_MENUS */
3093 args
[1] = build_string ("(yes or no) ");
3094 prompt
= Fconcat (2, args
);
3100 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3101 Qyes_or_no_p_history
, Qnil
,
3103 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
3108 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
3116 message ("Please answer yes or no.");
3117 Fsleep_for (make_number (2), Qnil
);
3121 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3122 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3124 Each of the three load averages is multiplied by 100, then converted
3127 When USE-FLOATS is non-nil, floats will be used instead of integers.
3128 These floats are not multiplied by 100.
3130 If the 5-minute or 15-minute load averages are not available, return a
3131 shortened list, containing only those averages which are available. */)
3133 Lisp_Object use_floats
;
3136 int loads
= getloadavg (load_ave
, 3);
3137 Lisp_Object ret
= Qnil
;
3140 error ("load-average not implemented for this operating system");
3144 Lisp_Object load
= (NILP (use_floats
) ?
3145 make_number ((int) (100.0 * load_ave
[loads
]))
3146 : make_float (load_ave
[loads
]));
3147 ret
= Fcons (load
, ret
);
3153 Lisp_Object Vfeatures
, Qsubfeatures
;
3154 extern Lisp_Object Vafter_load_alist
;
3156 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3157 doc
: /* Returns t if FEATURE is present in this Emacs.
3159 Use this to conditionalize execution of lisp code based on the
3160 presence or absence of emacs or environment extensions.
3161 Use `provide' to declare that a feature is available. This function
3162 looks at the value of the variable `features'. The optional argument
3163 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3164 (feature
, subfeature
)
3165 Lisp_Object feature
, subfeature
;
3167 register Lisp_Object tem
;
3168 CHECK_SYMBOL (feature
);
3169 tem
= Fmemq (feature
, Vfeatures
);
3170 if (!NILP (tem
) && !NILP (subfeature
))
3171 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3172 return (NILP (tem
)) ? Qnil
: Qt
;
3175 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3176 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3177 The optional argument SUBFEATURES should be a list of symbols listing
3178 particular subfeatures supported in this version of FEATURE. */)
3179 (feature
, subfeatures
)
3180 Lisp_Object feature
, subfeatures
;
3182 register Lisp_Object tem
;
3183 CHECK_SYMBOL (feature
);
3184 CHECK_LIST (subfeatures
);
3185 if (!NILP (Vautoload_queue
))
3186 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3187 tem
= Fmemq (feature
, Vfeatures
);
3189 Vfeatures
= Fcons (feature
, Vfeatures
);
3190 if (!NILP (subfeatures
))
3191 Fput (feature
, Qsubfeatures
, subfeatures
);
3192 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3194 /* Run any load-hooks for this file. */
3195 tem
= Fassq (feature
, Vafter_load_alist
);
3197 Fprogn (Fcdr (tem
));
3202 /* `require' and its subroutines. */
3204 /* List of features currently being require'd, innermost first. */
3206 Lisp_Object require_nesting_list
;
3209 require_unwind (old_value
)
3210 Lisp_Object old_value
;
3212 return require_nesting_list
= old_value
;
3215 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3216 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3217 If FEATURE is not a member of the list `features', then the feature
3218 is not loaded; so load the file FILENAME.
3219 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3220 and `load' will try to load this name appended with the suffix `.elc',
3221 `.el' or the unmodified name, in that order.
3222 If the optional third argument NOERROR is non-nil,
3223 then return nil if the file is not found instead of signaling an error.
3224 Normally the return value is FEATURE.
3225 The normal messages at start and end of loading FILENAME are suppressed. */)
3226 (feature
, filename
, noerror
)
3227 Lisp_Object feature
, filename
, noerror
;
3229 register Lisp_Object tem
;
3230 struct gcpro gcpro1
, gcpro2
;
3232 CHECK_SYMBOL (feature
);
3234 tem
= Fmemq (feature
, Vfeatures
);
3236 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3240 int count
= specpdl_ptr
- specpdl
;
3243 /* A certain amount of recursive `require' is legitimate,
3244 but if we require the same feature recursively 3 times,
3246 tem
= require_nesting_list
;
3247 while (! NILP (tem
))
3249 if (! NILP (Fequal (feature
, XCAR (tem
))))
3254 error ("Recursive `require' for feature `%s'",
3255 XSYMBOL (feature
)->name
->data
);
3257 /* Update the list for any nested `require's that occur. */
3258 record_unwind_protect (require_unwind
, require_nesting_list
);
3259 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3261 /* Value saved here is to be restored into Vautoload_queue */
3262 record_unwind_protect (un_autoload
, Vautoload_queue
);
3263 Vautoload_queue
= Qt
;
3265 /* Load the file. */
3266 GCPRO2 (feature
, filename
);
3267 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3268 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3271 /* If load failed entirely, return nil. */
3273 return unbind_to (count
, Qnil
);
3275 tem
= Fmemq (feature
, Vfeatures
);
3277 error ("Required feature `%s' was not provided",
3278 XSYMBOL (feature
)->name
->data
);
3280 /* Once loading finishes, don't undo it. */
3281 Vautoload_queue
= Qt
;
3282 feature
= unbind_to (count
, feature
);
3288 /* Primitives for work of the "widget" library.
3289 In an ideal world, this section would not have been necessary.
3290 However, lisp function calls being as slow as they are, it turns
3291 out that some functions in the widget library (wid-edit.el) are the
3292 bottleneck of Widget operation. Here is their translation to C,
3293 for the sole reason of efficiency. */
3295 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3296 doc
: /* Return non-nil if PLIST has the property PROP.
3297 PLIST is a property list, which is a list of the form
3298 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3299 Unlike `plist-get', this allows you to distinguish between a missing
3300 property and a property with the value nil.
3301 The value is actually the tail of PLIST whose car is PROP. */)
3303 Lisp_Object plist
, prop
;
3305 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3308 plist
= XCDR (plist
);
3309 plist
= CDR (plist
);
3314 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3315 doc
: /* In WIDGET, set PROPERTY to VALUE.
3316 The value can later be retrieved with `widget-get'. */)
3317 (widget
, property
, value
)
3318 Lisp_Object widget
, property
, value
;
3320 CHECK_CONS (widget
);
3321 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3325 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3326 doc
: /* In WIDGET, get the value of PROPERTY.
3327 The value could either be specified when the widget was created, or
3328 later with `widget-put'. */)
3330 Lisp_Object widget
, property
;
3338 CHECK_CONS (widget
);
3339 tmp
= Fplist_member (XCDR (widget
), property
);
3345 tmp
= XCAR (widget
);
3348 widget
= Fget (tmp
, Qwidget_type
);
3352 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3353 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3354 ARGS are passed as extra arguments to the function.
3355 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3360 /* This function can GC. */
3361 Lisp_Object newargs
[3];
3362 struct gcpro gcpro1
, gcpro2
;
3365 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3366 newargs
[1] = args
[0];
3367 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3368 GCPRO2 (newargs
[0], newargs
[2]);
3369 result
= Fapply (3, newargs
);
3374 /* base64 encode/decode functions (RFC 2045).
3375 Based on code from GNU recode. */
3377 #define MIME_LINE_LENGTH 76
3379 #define IS_ASCII(Character) \
3381 #define IS_BASE64(Character) \
3382 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3383 #define IS_BASE64_IGNORABLE(Character) \
3384 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3385 || (Character) == '\f' || (Character) == '\r')
3387 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3388 character or return retval if there are no characters left to
3390 #define READ_QUADRUPLET_BYTE(retval) \
3395 if (nchars_return) \
3396 *nchars_return = nchars; \
3401 while (IS_BASE64_IGNORABLE (c))
3403 /* Don't use alloca for regions larger than this, lest we overflow
3405 #define MAX_ALLOCA 16*1024
3407 /* Table of characters coding the 64 values. */
3408 static char base64_value_to_char
[64] =
3410 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3411 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3412 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3413 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3414 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3415 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3416 '8', '9', '+', '/' /* 60-63 */
3419 /* Table of base64 values for first 128 characters. */
3420 static short base64_char_to_value
[128] =
3422 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3423 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3424 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3425 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3426 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3427 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3428 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3429 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3430 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3431 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3432 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3433 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3434 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3437 /* The following diagram shows the logical steps by which three octets
3438 get transformed into four base64 characters.
3440 .--------. .--------. .--------.
3441 |aaaaaabb| |bbbbcccc| |ccdddddd|
3442 `--------' `--------' `--------'
3444 .--------+--------+--------+--------.
3445 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3446 `--------+--------+--------+--------'
3448 .--------+--------+--------+--------.
3449 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3450 `--------+--------+--------+--------'
3452 The octets are divided into 6 bit chunks, which are then encoded into
3453 base64 characters. */
3456 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3457 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3459 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3461 doc
: /* Base64-encode the region between BEG and END.
3462 Return the length of the encoded text.
3463 Optional third argument NO-LINE-BREAK means do not break long lines
3464 into shorter lines. */)
3465 (beg
, end
, no_line_break
)
3466 Lisp_Object beg
, end
, no_line_break
;
3469 int allength
, length
;
3470 int ibeg
, iend
, encoded_length
;
3473 validate_region (&beg
, &end
);
3475 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3476 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3477 move_gap_both (XFASTINT (beg
), ibeg
);
3479 /* We need to allocate enough room for encoding the text.
3480 We need 33 1/3% more space, plus a newline every 76
3481 characters, and then we round up. */
3482 length
= iend
- ibeg
;
3483 allength
= length
+ length
/3 + 1;
3484 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3486 if (allength
<= MAX_ALLOCA
)
3487 encoded
= (char *) alloca (allength
);
3489 encoded
= (char *) xmalloc (allength
);
3490 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3491 NILP (no_line_break
),
3492 !NILP (current_buffer
->enable_multibyte_characters
));
3493 if (encoded_length
> allength
)
3496 if (encoded_length
< 0)
3498 /* The encoding wasn't possible. */
3499 if (length
> MAX_ALLOCA
)
3501 error ("Multibyte character in data for base64 encoding");
3504 /* Now we have encoded the region, so we insert the new contents
3505 and delete the old. (Insert first in order to preserve markers.) */
3506 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3507 insert (encoded
, encoded_length
);
3508 if (allength
> MAX_ALLOCA
)
3510 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3512 /* If point was outside of the region, restore it exactly; else just
3513 move to the beginning of the region. */
3514 if (old_pos
>= XFASTINT (end
))
3515 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3516 else if (old_pos
> XFASTINT (beg
))
3517 old_pos
= XFASTINT (beg
);
3520 /* We return the length of the encoded text. */
3521 return make_number (encoded_length
);
3524 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3526 doc
: /* Base64-encode STRING and return the result.
3527 Optional second argument NO-LINE-BREAK means do not break long lines
3528 into shorter lines. */)
3529 (string
, no_line_break
)
3530 Lisp_Object string
, no_line_break
;
3532 int allength
, length
, encoded_length
;
3534 Lisp_Object encoded_string
;
3536 CHECK_STRING (string
);
3538 /* We need to allocate enough room for encoding the text.
3539 We need 33 1/3% more space, plus a newline every 76
3540 characters, and then we round up. */
3541 length
= STRING_BYTES (XSTRING (string
));
3542 allength
= length
+ length
/3 + 1;
3543 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3545 /* We need to allocate enough room for decoding the text. */
3546 if (allength
<= MAX_ALLOCA
)
3547 encoded
= (char *) alloca (allength
);
3549 encoded
= (char *) xmalloc (allength
);
3551 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3552 encoded
, length
, NILP (no_line_break
),
3553 STRING_MULTIBYTE (string
));
3554 if (encoded_length
> allength
)
3557 if (encoded_length
< 0)
3559 /* The encoding wasn't possible. */
3560 if (length
> MAX_ALLOCA
)
3562 error ("Multibyte character in data for base64 encoding");
3565 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3566 if (allength
> MAX_ALLOCA
)
3569 return encoded_string
;
3573 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3580 int counter
= 0, i
= 0;
3590 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3598 /* Wrap line every 76 characters. */
3602 if (counter
< MIME_LINE_LENGTH
/ 4)
3611 /* Process first byte of a triplet. */
3613 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3614 value
= (0x03 & c
) << 4;
3616 /* Process second byte of a triplet. */
3620 *e
++ = base64_value_to_char
[value
];
3628 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3636 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3637 value
= (0x0f & c
) << 2;
3639 /* Process third byte of a triplet. */
3643 *e
++ = base64_value_to_char
[value
];
3650 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3658 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3659 *e
++ = base64_value_to_char
[0x3f & c
];
3666 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3668 doc
: /* Base64-decode the region between BEG and END.
3669 Return the length of the decoded text.
3670 If the region can't be decoded, signal an error and don't modify the buffer. */)
3672 Lisp_Object beg
, end
;
3674 int ibeg
, iend
, length
, allength
;
3679 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3681 validate_region (&beg
, &end
);
3683 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3684 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3686 length
= iend
- ibeg
;
3688 /* We need to allocate enough room for decoding the text. If we are
3689 working on a multibyte buffer, each decoded code may occupy at
3691 allength
= multibyte
? length
* 2 : length
;
3692 if (allength
<= MAX_ALLOCA
)
3693 decoded
= (char *) alloca (allength
);
3695 decoded
= (char *) xmalloc (allength
);
3697 move_gap_both (XFASTINT (beg
), ibeg
);
3698 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3699 multibyte
, &inserted_chars
);
3700 if (decoded_length
> allength
)
3703 if (decoded_length
< 0)
3705 /* The decoding wasn't possible. */
3706 if (allength
> MAX_ALLOCA
)
3708 error ("Invalid base64 data");
3711 /* Now we have decoded the region, so we insert the new contents
3712 and delete the old. (Insert first in order to preserve markers.) */
3713 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3714 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3715 if (allength
> MAX_ALLOCA
)
3717 /* Delete the original text. */
3718 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3719 iend
+ decoded_length
, 1);
3721 /* If point was outside of the region, restore it exactly; else just
3722 move to the beginning of the region. */
3723 if (old_pos
>= XFASTINT (end
))
3724 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3725 else if (old_pos
> XFASTINT (beg
))
3726 old_pos
= XFASTINT (beg
);
3727 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3729 return make_number (inserted_chars
);
3732 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3734 doc
: /* Base64-decode STRING and return the result. */)
3739 int length
, decoded_length
;
3740 Lisp_Object decoded_string
;
3742 CHECK_STRING (string
);
3744 length
= STRING_BYTES (XSTRING (string
));
3745 /* We need to allocate enough room for decoding the text. */
3746 if (length
<= MAX_ALLOCA
)
3747 decoded
= (char *) alloca (length
);
3749 decoded
= (char *) xmalloc (length
);
3751 /* The decoded result should be unibyte. */
3752 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3754 if (decoded_length
> length
)
3756 else if (decoded_length
>= 0)
3757 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3759 decoded_string
= Qnil
;
3761 if (length
> MAX_ALLOCA
)
3763 if (!STRINGP (decoded_string
))
3764 error ("Invalid base64 data");
3766 return decoded_string
;
3769 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3770 MULTIBYTE is nonzero, the decoded result should be in multibyte
3771 form. If NCHARS_RETRUN is not NULL, store the number of produced
3772 characters in *NCHARS_RETURN. */
3775 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3785 unsigned long value
;
3790 /* Process first byte of a quadruplet. */
3792 READ_QUADRUPLET_BYTE (e
-to
);
3796 value
= base64_char_to_value
[c
] << 18;
3798 /* Process second byte of a quadruplet. */
3800 READ_QUADRUPLET_BYTE (-1);
3804 value
|= base64_char_to_value
[c
] << 12;
3806 c
= (unsigned char) (value
>> 16);
3808 e
+= CHAR_STRING (c
, e
);
3813 /* Process third byte of a quadruplet. */
3815 READ_QUADRUPLET_BYTE (-1);
3819 READ_QUADRUPLET_BYTE (-1);
3828 value
|= base64_char_to_value
[c
] << 6;
3830 c
= (unsigned char) (0xff & value
>> 8);
3832 e
+= CHAR_STRING (c
, e
);
3837 /* Process fourth byte of a quadruplet. */
3839 READ_QUADRUPLET_BYTE (-1);
3846 value
|= base64_char_to_value
[c
];
3848 c
= (unsigned char) (0xff & value
);
3850 e
+= CHAR_STRING (c
, e
);
3859 /***********************************************************************
3861 ***** Hash Tables *****
3863 ***********************************************************************/
3865 /* Implemented by gerd@gnu.org. This hash table implementation was
3866 inspired by CMUCL hash tables. */
3870 1. For small tables, association lists are probably faster than
3871 hash tables because they have lower overhead.
3873 For uses of hash tables where the O(1) behavior of table
3874 operations is not a requirement, it might therefore be a good idea
3875 not to hash. Instead, we could just do a linear search in the
3876 key_and_value vector of the hash table. This could be done
3877 if a `:linear-search t' argument is given to make-hash-table. */
3880 /* Value is the key part of entry IDX in hash table H. */
3882 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3884 /* Value is the value part of entry IDX in hash table H. */
3886 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3888 /* Value is the index of the next entry following the one at IDX
3891 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3893 /* Value is the hash code computed for entry IDX in hash table H. */
3895 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3897 /* Value is the index of the element in hash table H that is the
3898 start of the collision list at index IDX in the index vector of H. */
3900 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3902 /* Value is the size of hash table H. */
3904 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3906 /* The list of all weak hash tables. Don't staticpro this one. */
3908 Lisp_Object Vweak_hash_tables
;
3910 /* Various symbols. */
3912 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3913 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3914 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3916 /* Function prototypes. */
3918 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3919 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3920 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3921 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3922 Lisp_Object
, unsigned));
3923 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3924 Lisp_Object
, unsigned));
3925 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3926 unsigned, Lisp_Object
, unsigned));
3927 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3928 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3929 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3930 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3932 static unsigned sxhash_string
P_ ((unsigned char *, int));
3933 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3934 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3935 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3936 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3940 /***********************************************************************
3942 ***********************************************************************/
3944 /* If OBJ is a Lisp hash table, return a pointer to its struct
3945 Lisp_Hash_Table. Otherwise, signal an error. */
3947 static struct Lisp_Hash_Table
*
3948 check_hash_table (obj
)
3951 CHECK_HASH_TABLE (obj
);
3952 return XHASH_TABLE (obj
);
3956 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3960 next_almost_prime (n
)
3973 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3974 which USED[I] is non-zero. If found at index I in ARGS, set
3975 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3976 -1. This function is used to extract a keyword/argument pair from
3977 a DEFUN parameter list. */
3980 get_key_arg (key
, nargs
, args
, used
)
3988 for (i
= 0; i
< nargs
- 1; ++i
)
3989 if (!used
[i
] && EQ (args
[i
], key
))
4004 /* Return a Lisp vector which has the same contents as VEC but has
4005 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4006 vector that are not copied from VEC are set to INIT. */
4009 larger_vector (vec
, new_size
, init
)
4014 struct Lisp_Vector
*v
;
4017 xassert (VECTORP (vec
));
4018 old_size
= XVECTOR (vec
)->size
;
4019 xassert (new_size
>= old_size
);
4021 v
= allocate_vector (new_size
);
4022 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4023 old_size
* sizeof *v
->contents
);
4024 for (i
= old_size
; i
< new_size
; ++i
)
4025 v
->contents
[i
] = init
;
4026 XSETVECTOR (vec
, v
);
4031 /***********************************************************************
4033 ***********************************************************************/
4035 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4036 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4037 KEY2 are the same. */
4040 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4041 struct Lisp_Hash_Table
*h
;
4042 Lisp_Object key1
, key2
;
4043 unsigned hash1
, hash2
;
4045 return (FLOATP (key1
)
4047 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4051 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4052 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4053 KEY2 are the same. */
4056 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4057 struct Lisp_Hash_Table
*h
;
4058 Lisp_Object key1
, key2
;
4059 unsigned hash1
, hash2
;
4061 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4065 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4066 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4067 if KEY1 and KEY2 are the same. */
4070 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4071 struct Lisp_Hash_Table
*h
;
4072 Lisp_Object key1
, key2
;
4073 unsigned hash1
, hash2
;
4077 Lisp_Object args
[3];
4079 args
[0] = h
->user_cmp_function
;
4082 return !NILP (Ffuncall (3, args
));
4089 /* Value is a hash code for KEY for use in hash table H which uses
4090 `eq' to compare keys. The hash code returned is guaranteed to fit
4091 in a Lisp integer. */
4095 struct Lisp_Hash_Table
*h
;
4098 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4099 xassert ((hash
& ~VALMASK
) == 0);
4104 /* Value is a hash code for KEY for use in hash table H which uses
4105 `eql' to compare keys. The hash code returned is guaranteed to fit
4106 in a Lisp integer. */
4110 struct Lisp_Hash_Table
*h
;
4115 hash
= sxhash (key
, 0);
4117 hash
= XUINT (key
) ^ XGCTYPE (key
);
4118 xassert ((hash
& ~VALMASK
) == 0);
4123 /* Value is a hash code for KEY for use in hash table H which uses
4124 `equal' to compare keys. The hash code returned is guaranteed to fit
4125 in a Lisp integer. */
4128 hashfn_equal (h
, key
)
4129 struct Lisp_Hash_Table
*h
;
4132 unsigned hash
= sxhash (key
, 0);
4133 xassert ((hash
& ~VALMASK
) == 0);
4138 /* Value is a hash code for KEY for use in hash table H which uses as
4139 user-defined function to compare keys. The hash code returned is
4140 guaranteed to fit in a Lisp integer. */
4143 hashfn_user_defined (h
, key
)
4144 struct Lisp_Hash_Table
*h
;
4147 Lisp_Object args
[2], hash
;
4149 args
[0] = h
->user_hash_function
;
4151 hash
= Ffuncall (2, args
);
4152 if (!INTEGERP (hash
))
4154 list2 (build_string ("Invalid hash code returned from \
4155 user-supplied hash function"),
4157 return XUINT (hash
);
4161 /* Create and initialize a new hash table.
4163 TEST specifies the test the hash table will use to compare keys.
4164 It must be either one of the predefined tests `eq', `eql' or
4165 `equal' or a symbol denoting a user-defined test named TEST with
4166 test and hash functions USER_TEST and USER_HASH.
4168 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4170 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4171 new size when it becomes full is computed by adding REHASH_SIZE to
4172 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4173 table's new size is computed by multiplying its old size with
4176 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4177 be resized when the ratio of (number of entries in the table) /
4178 (table size) is >= REHASH_THRESHOLD.
4180 WEAK specifies the weakness of the table. If non-nil, it must be
4181 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4184 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4185 user_test
, user_hash
)
4186 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4187 Lisp_Object user_test
, user_hash
;
4189 struct Lisp_Hash_Table
*h
;
4191 int index_size
, i
, sz
;
4193 /* Preconditions. */
4194 xassert (SYMBOLP (test
));
4195 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4196 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4197 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4198 xassert (FLOATP (rehash_threshold
)
4199 && XFLOATINT (rehash_threshold
) > 0
4200 && XFLOATINT (rehash_threshold
) <= 1.0);
4202 if (XFASTINT (size
) == 0)
4203 size
= make_number (1);
4205 /* Allocate a table and initialize it. */
4206 h
= allocate_hash_table ();
4208 /* Initialize hash table slots. */
4209 sz
= XFASTINT (size
);
4212 if (EQ (test
, Qeql
))
4214 h
->cmpfn
= cmpfn_eql
;
4215 h
->hashfn
= hashfn_eql
;
4217 else if (EQ (test
, Qeq
))
4220 h
->hashfn
= hashfn_eq
;
4222 else if (EQ (test
, Qequal
))
4224 h
->cmpfn
= cmpfn_equal
;
4225 h
->hashfn
= hashfn_equal
;
4229 h
->user_cmp_function
= user_test
;
4230 h
->user_hash_function
= user_hash
;
4231 h
->cmpfn
= cmpfn_user_defined
;
4232 h
->hashfn
= hashfn_user_defined
;
4236 h
->rehash_threshold
= rehash_threshold
;
4237 h
->rehash_size
= rehash_size
;
4238 h
->count
= make_number (0);
4239 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4240 h
->hash
= Fmake_vector (size
, Qnil
);
4241 h
->next
= Fmake_vector (size
, Qnil
);
4242 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4243 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4244 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4246 /* Set up the free list. */
4247 for (i
= 0; i
< sz
- 1; ++i
)
4248 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4249 h
->next_free
= make_number (0);
4251 XSET_HASH_TABLE (table
, h
);
4252 xassert (HASH_TABLE_P (table
));
4253 xassert (XHASH_TABLE (table
) == h
);
4255 /* Maybe add this hash table to the list of all weak hash tables. */
4257 h
->next_weak
= Qnil
;
4260 h
->next_weak
= Vweak_hash_tables
;
4261 Vweak_hash_tables
= table
;
4268 /* Return a copy of hash table H1. Keys and values are not copied,
4269 only the table itself is. */
4272 copy_hash_table (h1
)
4273 struct Lisp_Hash_Table
*h1
;
4276 struct Lisp_Hash_Table
*h2
;
4277 struct Lisp_Vector
*next
;
4279 h2
= allocate_hash_table ();
4280 next
= h2
->vec_next
;
4281 bcopy (h1
, h2
, sizeof *h2
);
4282 h2
->vec_next
= next
;
4283 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4284 h2
->hash
= Fcopy_sequence (h1
->hash
);
4285 h2
->next
= Fcopy_sequence (h1
->next
);
4286 h2
->index
= Fcopy_sequence (h1
->index
);
4287 XSET_HASH_TABLE (table
, h2
);
4289 /* Maybe add this hash table to the list of all weak hash tables. */
4290 if (!NILP (h2
->weak
))
4292 h2
->next_weak
= Vweak_hash_tables
;
4293 Vweak_hash_tables
= table
;
4300 /* Resize hash table H if it's too full. If H cannot be resized
4301 because it's already too large, throw an error. */
4304 maybe_resize_hash_table (h
)
4305 struct Lisp_Hash_Table
*h
;
4307 if (NILP (h
->next_free
))
4309 int old_size
= HASH_TABLE_SIZE (h
);
4310 int i
, new_size
, index_size
;
4312 if (INTEGERP (h
->rehash_size
))
4313 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4315 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4316 new_size
= max (old_size
+ 1, new_size
);
4317 index_size
= next_almost_prime ((int)
4319 / XFLOATINT (h
->rehash_threshold
)));
4320 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4321 error ("Hash table too large to resize");
4323 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4324 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4325 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4326 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4328 /* Update the free list. Do it so that new entries are added at
4329 the end of the free list. This makes some operations like
4331 for (i
= old_size
; i
< new_size
- 1; ++i
)
4332 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4334 if (!NILP (h
->next_free
))
4336 Lisp_Object last
, next
;
4338 last
= h
->next_free
;
4339 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4343 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4346 XSETFASTINT (h
->next_free
, old_size
);
4349 for (i
= 0; i
< old_size
; ++i
)
4350 if (!NILP (HASH_HASH (h
, i
)))
4352 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4353 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4354 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4355 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4361 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4362 the hash code of KEY. Value is the index of the entry in H
4363 matching KEY, or -1 if not found. */
4366 hash_lookup (h
, key
, hash
)
4367 struct Lisp_Hash_Table
*h
;
4372 int start_of_bucket
;
4375 hash_code
= h
->hashfn (h
, key
);
4379 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4380 idx
= HASH_INDEX (h
, start_of_bucket
);
4382 /* We need not gcpro idx since it's either an integer or nil. */
4385 int i
= XFASTINT (idx
);
4386 if (EQ (key
, HASH_KEY (h
, i
))
4388 && h
->cmpfn (h
, key
, hash_code
,
4389 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4391 idx
= HASH_NEXT (h
, i
);
4394 return NILP (idx
) ? -1 : XFASTINT (idx
);
4398 /* Put an entry into hash table H that associates KEY with VALUE.
4399 HASH is a previously computed hash code of KEY.
4400 Value is the index of the entry in H matching KEY. */
4403 hash_put (h
, key
, value
, hash
)
4404 struct Lisp_Hash_Table
*h
;
4405 Lisp_Object key
, value
;
4408 int start_of_bucket
, i
;
4410 xassert ((hash
& ~VALMASK
) == 0);
4412 /* Increment count after resizing because resizing may fail. */
4413 maybe_resize_hash_table (h
);
4414 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4416 /* Store key/value in the key_and_value vector. */
4417 i
= XFASTINT (h
->next_free
);
4418 h
->next_free
= HASH_NEXT (h
, i
);
4419 HASH_KEY (h
, i
) = key
;
4420 HASH_VALUE (h
, i
) = value
;
4422 /* Remember its hash code. */
4423 HASH_HASH (h
, i
) = make_number (hash
);
4425 /* Add new entry to its collision chain. */
4426 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4427 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4428 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4433 /* Remove the entry matching KEY from hash table H, if there is one. */
4436 hash_remove (h
, key
)
4437 struct Lisp_Hash_Table
*h
;
4441 int start_of_bucket
;
4442 Lisp_Object idx
, prev
;
4444 hash_code
= h
->hashfn (h
, key
);
4445 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4446 idx
= HASH_INDEX (h
, start_of_bucket
);
4449 /* We need not gcpro idx, prev since they're either integers or nil. */
4452 int i
= XFASTINT (idx
);
4454 if (EQ (key
, HASH_KEY (h
, i
))
4456 && h
->cmpfn (h
, key
, hash_code
,
4457 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4459 /* Take entry out of collision chain. */
4461 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4463 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4465 /* Clear slots in key_and_value and add the slots to
4467 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4468 HASH_NEXT (h
, i
) = h
->next_free
;
4469 h
->next_free
= make_number (i
);
4470 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4471 xassert (XINT (h
->count
) >= 0);
4477 idx
= HASH_NEXT (h
, i
);
4483 /* Clear hash table H. */
4487 struct Lisp_Hash_Table
*h
;
4489 if (XFASTINT (h
->count
) > 0)
4491 int i
, size
= HASH_TABLE_SIZE (h
);
4493 for (i
= 0; i
< size
; ++i
)
4495 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4496 HASH_KEY (h
, i
) = Qnil
;
4497 HASH_VALUE (h
, i
) = Qnil
;
4498 HASH_HASH (h
, i
) = Qnil
;
4501 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4502 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4504 h
->next_free
= make_number (0);
4505 h
->count
= make_number (0);
4511 /************************************************************************
4513 ************************************************************************/
4515 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4516 entries from the table that don't survive the current GC.
4517 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4518 non-zero if anything was marked. */
4521 sweep_weak_table (h
, remove_entries_p
)
4522 struct Lisp_Hash_Table
*h
;
4523 int remove_entries_p
;
4525 int bucket
, n
, marked
;
4527 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4530 for (bucket
= 0; bucket
< n
; ++bucket
)
4532 Lisp_Object idx
, next
, prev
;
4534 /* Follow collision chain, removing entries that
4535 don't survive this garbage collection. */
4537 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4539 int i
= XFASTINT (idx
);
4540 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4541 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4544 if (EQ (h
->weak
, Qkey
))
4545 remove_p
= !key_known_to_survive_p
;
4546 else if (EQ (h
->weak
, Qvalue
))
4547 remove_p
= !value_known_to_survive_p
;
4548 else if (EQ (h
->weak
, Qkey_or_value
))
4549 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4550 else if (EQ (h
->weak
, Qkey_and_value
))
4551 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4555 next
= HASH_NEXT (h
, i
);
4557 if (remove_entries_p
)
4561 /* Take out of collision chain. */
4563 HASH_INDEX (h
, bucket
) = next
;
4565 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4567 /* Add to free list. */
4568 HASH_NEXT (h
, i
) = h
->next_free
;
4571 /* Clear key, value, and hash. */
4572 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4573 HASH_HASH (h
, i
) = Qnil
;
4575 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4582 /* Make sure key and value survive. */
4583 if (!key_known_to_survive_p
)
4585 mark_object (&HASH_KEY (h
, i
));
4589 if (!value_known_to_survive_p
)
4591 mark_object (&HASH_VALUE (h
, i
));
4602 /* Remove elements from weak hash tables that don't survive the
4603 current garbage collection. Remove weak tables that don't survive
4604 from Vweak_hash_tables. Called from gc_sweep. */
4607 sweep_weak_hash_tables ()
4609 Lisp_Object table
, used
, next
;
4610 struct Lisp_Hash_Table
*h
;
4613 /* Mark all keys and values that are in use. Keep on marking until
4614 there is no more change. This is necessary for cases like
4615 value-weak table A containing an entry X -> Y, where Y is used in a
4616 key-weak table B, Z -> Y. If B comes after A in the list of weak
4617 tables, X -> Y might be removed from A, although when looking at B
4618 one finds that it shouldn't. */
4622 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4624 h
= XHASH_TABLE (table
);
4625 if (h
->size
& ARRAY_MARK_FLAG
)
4626 marked
|= sweep_weak_table (h
, 0);
4631 /* Remove tables and entries that aren't used. */
4632 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4634 h
= XHASH_TABLE (table
);
4635 next
= h
->next_weak
;
4637 if (h
->size
& ARRAY_MARK_FLAG
)
4639 /* TABLE is marked as used. Sweep its contents. */
4640 if (XFASTINT (h
->count
) > 0)
4641 sweep_weak_table (h
, 1);
4643 /* Add table to the list of used weak hash tables. */
4644 h
->next_weak
= used
;
4649 Vweak_hash_tables
= used
;
4654 /***********************************************************************
4655 Hash Code Computation
4656 ***********************************************************************/
4658 /* Maximum depth up to which to dive into Lisp structures. */
4660 #define SXHASH_MAX_DEPTH 3
4662 /* Maximum length up to which to take list and vector elements into
4665 #define SXHASH_MAX_LEN 7
4667 /* Combine two integers X and Y for hashing. */
4669 #define SXHASH_COMBINE(X, Y) \
4670 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4674 /* Return a hash for string PTR which has length LEN. The hash
4675 code returned is guaranteed to fit in a Lisp integer. */
4678 sxhash_string (ptr
, len
)
4682 unsigned char *p
= ptr
;
4683 unsigned char *end
= p
+ len
;
4692 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4695 return hash
& VALMASK
;
4699 /* Return a hash for list LIST. DEPTH is the current depth in the
4700 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4703 sxhash_list (list
, depth
)
4710 if (depth
< SXHASH_MAX_DEPTH
)
4712 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4713 list
= XCDR (list
), ++i
)
4715 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4716 hash
= SXHASH_COMBINE (hash
, hash2
);
4723 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4724 the Lisp structure. */
4727 sxhash_vector (vec
, depth
)
4731 unsigned hash
= XVECTOR (vec
)->size
;
4734 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4735 for (i
= 0; i
< n
; ++i
)
4737 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4738 hash
= SXHASH_COMBINE (hash
, hash2
);
4745 /* Return a hash for bool-vector VECTOR. */
4748 sxhash_bool_vector (vec
)
4751 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4754 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4755 for (i
= 0; i
< n
; ++i
)
4756 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4762 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4763 structure. Value is an unsigned integer clipped to VALMASK. */
4772 if (depth
> SXHASH_MAX_DEPTH
)
4775 switch (XTYPE (obj
))
4782 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4783 XSYMBOL (obj
)->name
->size
);
4791 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4794 /* This can be everything from a vector to an overlay. */
4795 case Lisp_Vectorlike
:
4797 /* According to the CL HyperSpec, two arrays are equal only if
4798 they are `eq', except for strings and bit-vectors. In
4799 Emacs, this works differently. We have to compare element
4801 hash
= sxhash_vector (obj
, depth
);
4802 else if (BOOL_VECTOR_P (obj
))
4803 hash
= sxhash_bool_vector (obj
);
4805 /* Others are `equal' if they are `eq', so let's take their
4811 hash
= sxhash_list (obj
, depth
);
4816 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4817 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4818 for (hash
= 0; p
< e
; ++p
)
4819 hash
= SXHASH_COMBINE (hash
, *p
);
4827 return hash
& VALMASK
;
4832 /***********************************************************************
4834 ***********************************************************************/
4837 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4838 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4842 unsigned hash
= sxhash (obj
, 0);;
4843 return make_number (hash
);
4847 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4848 doc
: /* Create and return a new hash table.
4850 Arguments are specified as keyword/argument pairs. The following
4851 arguments are defined:
4853 :test TEST -- TEST must be a symbol that specifies how to compare
4854 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4855 `equal'. User-supplied test and hash functions can be specified via
4856 `define-hash-table-test'.
4858 :size SIZE -- A hint as to how many elements will be put in the table.
4861 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4862 fills up. If REHASH-SIZE is an integer, add that many space. If it
4863 is a float, it must be > 1.0, and the new size is computed by
4864 multiplying the old size with that factor. Default is 1.5.
4866 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4867 Resize the hash table when ratio of the number of entries in the
4868 table. Default is 0.8.
4870 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4871 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4872 returned is a weak table. Key/value pairs are removed from a weak
4873 hash table when there are no non-weak references pointing to their
4874 key, value, one of key or value, or both key and value, depending on
4875 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4878 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4883 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4884 Lisp_Object user_test
, user_hash
;
4888 /* The vector `used' is used to keep track of arguments that
4889 have been consumed. */
4890 used
= (char *) alloca (nargs
* sizeof *used
);
4891 bzero (used
, nargs
* sizeof *used
);
4893 /* See if there's a `:test TEST' among the arguments. */
4894 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4895 test
= i
< 0 ? Qeql
: args
[i
];
4896 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4898 /* See if it is a user-defined test. */
4901 prop
= Fget (test
, Qhash_table_test
);
4902 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4903 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4905 user_test
= XCAR (prop
);
4906 user_hash
= XCAR (XCDR (prop
));
4909 user_test
= user_hash
= Qnil
;
4911 /* See if there's a `:size SIZE' argument. */
4912 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4913 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4914 if (!INTEGERP (size
) || XINT (size
) < 0)
4916 list2 (build_string ("Invalid hash table size"),
4919 /* Look for `:rehash-size SIZE'. */
4920 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4921 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4922 if (!NUMBERP (rehash_size
)
4923 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4924 || XFLOATINT (rehash_size
) <= 1.0)
4926 list2 (build_string ("Invalid hash table rehash size"),
4929 /* Look for `:rehash-threshold THRESHOLD'. */
4930 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4931 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4932 if (!FLOATP (rehash_threshold
)
4933 || XFLOATINT (rehash_threshold
) <= 0.0
4934 || XFLOATINT (rehash_threshold
) > 1.0)
4936 list2 (build_string ("Invalid hash table rehash threshold"),
4939 /* Look for `:weakness WEAK'. */
4940 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4941 weak
= i
< 0 ? Qnil
: args
[i
];
4943 weak
= Qkey_and_value
;
4946 && !EQ (weak
, Qvalue
)
4947 && !EQ (weak
, Qkey_or_value
)
4948 && !EQ (weak
, Qkey_and_value
))
4949 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4952 /* Now, all args should have been used up, or there's a problem. */
4953 for (i
= 0; i
< nargs
; ++i
)
4956 list2 (build_string ("Invalid argument list"), args
[i
]));
4958 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4959 user_test
, user_hash
);
4963 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4964 doc
: /* Return a copy of hash table TABLE. */)
4968 return copy_hash_table (check_hash_table (table
));
4972 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4973 doc
: /* Create a new hash table.
4975 Optional first argument TEST specifies how to compare keys in the
4976 table. Predefined tests are `eq', `eql', and `equal'. Default is
4977 `eql'. New tests can be defined with `define-hash-table-test'. */)
4981 Lisp_Object args
[2];
4983 args
[1] = NILP (test
) ? Qeql
: test
;
4984 return Fmake_hash_table (2, args
);
4988 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4989 doc
: /* Return the number of elements in TABLE. */)
4993 return check_hash_table (table
)->count
;
4997 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4998 Shash_table_rehash_size
, 1, 1, 0,
4999 doc
: /* Return the current rehash size of TABLE. */)
5003 return check_hash_table (table
)->rehash_size
;
5007 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5008 Shash_table_rehash_threshold
, 1, 1, 0,
5009 doc
: /* Return the current rehash threshold of TABLE. */)
5013 return check_hash_table (table
)->rehash_threshold
;
5017 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5018 doc
: /* Return the size of TABLE.
5019 The size can be used as an argument to `make-hash-table' to create
5020 a hash table than can hold as many elements of TABLE holds
5021 without need for resizing. */)
5025 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5026 return make_number (HASH_TABLE_SIZE (h
));
5030 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5031 doc
: /* Return the test TABLE uses. */)
5035 return check_hash_table (table
)->test
;
5039 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5041 doc
: /* Return the weakness of TABLE. */)
5045 return check_hash_table (table
)->weak
;
5049 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5050 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5054 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5058 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5059 doc
: /* Clear hash table TABLE. */)
5063 hash_clear (check_hash_table (table
));
5068 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5069 doc
: /* Look up KEY in TABLE and return its associated value.
5070 If KEY is not found, return DFLT which defaults to nil. */)
5072 Lisp_Object key
, table
, dflt
;
5074 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5075 int i
= hash_lookup (h
, key
, NULL
);
5076 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5080 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5081 doc
: /* Associate KEY with VALUE in hash table TABLE.
5082 If KEY is already present in table, replace its current value with
5085 Lisp_Object key
, value
, table
;
5087 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5091 i
= hash_lookup (h
, key
, &hash
);
5093 HASH_VALUE (h
, i
) = value
;
5095 hash_put (h
, key
, value
, hash
);
5101 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5102 doc
: /* Remove KEY from TABLE. */)
5104 Lisp_Object key
, table
;
5106 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5107 hash_remove (h
, key
);
5112 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5113 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5114 FUNCTION is called with 2 arguments KEY and VALUE. */)
5116 Lisp_Object function
, table
;
5118 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5119 Lisp_Object args
[3];
5122 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5123 if (!NILP (HASH_HASH (h
, i
)))
5126 args
[1] = HASH_KEY (h
, i
);
5127 args
[2] = HASH_VALUE (h
, i
);
5135 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5136 Sdefine_hash_table_test
, 3, 3, 0,
5137 doc
: /* Define a new hash table test with name NAME, a symbol.
5139 In hash tables created with NAME specified as test, use TEST to
5140 compare keys, and HASH for computing hash codes of keys.
5142 TEST must be a function taking two arguments and returning non-nil if
5143 both arguments are the same. HASH must be a function taking one
5144 argument and return an integer that is the hash code of the argument.
5145 Hash code computation should use the whole value range of integers,
5146 including negative integers. */)
5148 Lisp_Object name
, test
, hash
;
5150 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5155 /************************************************************************
5157 ************************************************************************/
5162 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5163 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5165 A message digest is a cryptographic checksum of a document, and the
5166 algorithm to calculate it is defined in RFC 1321.
5168 The two optional arguments START and END are character positions
5169 specifying for which part of OBJECT the message digest should be
5170 computed. If nil or omitted, the digest is computed for the whole
5173 The MD5 message digest is computed from the result of encoding the
5174 text in a coding system, not directly from the internal Emacs form of
5175 the text. The optional fourth argument CODING-SYSTEM specifies which
5176 coding system to encode the text with. It should be the same coding
5177 system that you used or will use when actually writing the text into a
5180 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5181 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5182 system would be chosen by default for writing this text into a file.
5184 If OBJECT is a string, the most preferred coding system (see the
5185 command `prefer-coding-system') is used.
5187 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5188 guesswork fails. Normally, an error is signaled in such case. */)
5189 (object
, start
, end
, coding_system
, noerror
)
5190 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5192 unsigned char digest
[16];
5193 unsigned char value
[33];
5197 int start_char
= 0, end_char
= 0;
5198 int start_byte
= 0, end_byte
= 0;
5200 register struct buffer
*bp
;
5203 if (STRINGP (object
))
5205 if (NILP (coding_system
))
5207 /* Decide the coding-system to encode the data with. */
5209 if (STRING_MULTIBYTE (object
))
5210 /* use default, we can't guess correct value */
5211 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5213 coding_system
= Qraw_text
;
5216 if (NILP (Fcoding_system_p (coding_system
)))
5218 /* Invalid coding system. */
5220 if (!NILP (noerror
))
5221 coding_system
= Qraw_text
;
5224 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5227 if (STRING_MULTIBYTE (object
))
5228 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5230 size
= XSTRING (object
)->size
;
5231 size_byte
= STRING_BYTES (XSTRING (object
));
5235 CHECK_NUMBER (start
);
5237 start_char
= XINT (start
);
5242 start_byte
= string_char_to_byte (object
, start_char
);
5248 end_byte
= size_byte
;
5254 end_char
= XINT (end
);
5259 end_byte
= string_char_to_byte (object
, end_char
);
5262 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5263 args_out_of_range_3 (object
, make_number (start_char
),
5264 make_number (end_char
));
5268 CHECK_BUFFER (object
);
5270 bp
= XBUFFER (object
);
5276 CHECK_NUMBER_COERCE_MARKER (start
);
5284 CHECK_NUMBER_COERCE_MARKER (end
);
5289 temp
= b
, b
= e
, e
= temp
;
5291 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5292 args_out_of_range (start
, end
);
5294 if (NILP (coding_system
))
5296 /* Decide the coding-system to encode the data with.
5297 See fileio.c:Fwrite-region */
5299 if (!NILP (Vcoding_system_for_write
))
5300 coding_system
= Vcoding_system_for_write
;
5303 int force_raw_text
= 0;
5305 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5306 if (NILP (coding_system
)
5307 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5309 coding_system
= Qnil
;
5310 if (NILP (current_buffer
->enable_multibyte_characters
))
5314 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5316 /* Check file-coding-system-alist. */
5317 Lisp_Object args
[4], val
;
5319 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5320 args
[3] = Fbuffer_file_name(object
);
5321 val
= Ffind_operation_coding_system (4, args
);
5322 if (CONSP (val
) && !NILP (XCDR (val
)))
5323 coding_system
= XCDR (val
);
5326 if (NILP (coding_system
)
5327 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5329 /* If we still have not decided a coding system, use the
5330 default value of buffer-file-coding-system. */
5331 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5335 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5336 /* Confirm that VAL can surely encode the current region. */
5337 coding_system
= call3 (Vselect_safe_coding_system_function
,
5338 make_number (b
), make_number (e
),
5342 coding_system
= Qraw_text
;
5345 if (NILP (Fcoding_system_p (coding_system
)))
5347 /* Invalid coding system. */
5349 if (!NILP (noerror
))
5350 coding_system
= Qraw_text
;
5353 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5357 object
= make_buffer_string (b
, e
, 0);
5359 if (STRING_MULTIBYTE (object
))
5360 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5363 md5_buffer (XSTRING (object
)->data
+ start_byte
,
5364 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
5367 for (i
= 0; i
< 16; i
++)
5368 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5371 return make_string (value
, 32);
5378 /* Hash table stuff. */
5379 Qhash_table_p
= intern ("hash-table-p");
5380 staticpro (&Qhash_table_p
);
5381 Qeq
= intern ("eq");
5383 Qeql
= intern ("eql");
5385 Qequal
= intern ("equal");
5386 staticpro (&Qequal
);
5387 QCtest
= intern (":test");
5388 staticpro (&QCtest
);
5389 QCsize
= intern (":size");
5390 staticpro (&QCsize
);
5391 QCrehash_size
= intern (":rehash-size");
5392 staticpro (&QCrehash_size
);
5393 QCrehash_threshold
= intern (":rehash-threshold");
5394 staticpro (&QCrehash_threshold
);
5395 QCweakness
= intern (":weakness");
5396 staticpro (&QCweakness
);
5397 Qkey
= intern ("key");
5399 Qvalue
= intern ("value");
5400 staticpro (&Qvalue
);
5401 Qhash_table_test
= intern ("hash-table-test");
5402 staticpro (&Qhash_table_test
);
5403 Qkey_or_value
= intern ("key-or-value");
5404 staticpro (&Qkey_or_value
);
5405 Qkey_and_value
= intern ("key-and-value");
5406 staticpro (&Qkey_and_value
);
5409 defsubr (&Smake_hash_table
);
5410 defsubr (&Scopy_hash_table
);
5411 defsubr (&Smakehash
);
5412 defsubr (&Shash_table_count
);
5413 defsubr (&Shash_table_rehash_size
);
5414 defsubr (&Shash_table_rehash_threshold
);
5415 defsubr (&Shash_table_size
);
5416 defsubr (&Shash_table_test
);
5417 defsubr (&Shash_table_weakness
);
5418 defsubr (&Shash_table_p
);
5419 defsubr (&Sclrhash
);
5420 defsubr (&Sgethash
);
5421 defsubr (&Sputhash
);
5422 defsubr (&Sremhash
);
5423 defsubr (&Smaphash
);
5424 defsubr (&Sdefine_hash_table_test
);
5426 Qstring_lessp
= intern ("string-lessp");
5427 staticpro (&Qstring_lessp
);
5428 Qprovide
= intern ("provide");
5429 staticpro (&Qprovide
);
5430 Qrequire
= intern ("require");
5431 staticpro (&Qrequire
);
5432 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5433 staticpro (&Qyes_or_no_p_history
);
5434 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5435 staticpro (&Qcursor_in_echo_area
);
5436 Qwidget_type
= intern ("widget-type");
5437 staticpro (&Qwidget_type
);
5439 staticpro (&string_char_byte_cache_string
);
5440 string_char_byte_cache_string
= Qnil
;
5442 require_nesting_list
= Qnil
;
5443 staticpro (&require_nesting_list
);
5445 Fset (Qyes_or_no_p_history
, Qnil
);
5447 DEFVAR_LISP ("features", &Vfeatures
,
5448 doc
: /* A list of symbols which are the features of the executing emacs.
5449 Used by `featurep' and `require', and altered by `provide'. */);
5451 Qsubfeatures
= intern ("subfeatures");
5452 staticpro (&Qsubfeatures
);
5454 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5455 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5456 This applies to y-or-n and yes-or-no questions asked by commands
5457 invoked by mouse clicks and mouse menu items. */);
5460 defsubr (&Sidentity
);
5463 defsubr (&Ssafe_length
);
5464 defsubr (&Sstring_bytes
);
5465 defsubr (&Sstring_equal
);
5466 defsubr (&Scompare_strings
);
5467 defsubr (&Sstring_lessp
);
5470 defsubr (&Svconcat
);
5471 defsubr (&Scopy_sequence
);
5472 defsubr (&Sstring_make_multibyte
);
5473 defsubr (&Sstring_make_unibyte
);
5474 defsubr (&Sstring_as_multibyte
);
5475 defsubr (&Sstring_as_unibyte
);
5476 defsubr (&Scopy_alist
);
5477 defsubr (&Ssubstring
);
5478 defsubr (&Ssubstring_no_properties
);
5490 defsubr (&Snreverse
);
5491 defsubr (&Sreverse
);
5493 defsubr (&Splist_get
);
5495 defsubr (&Splist_put
);
5497 defsubr (&Slax_plist_get
);
5498 defsubr (&Slax_plist_put
);
5500 defsubr (&Sfillarray
);
5501 defsubr (&Schar_table_subtype
);
5502 defsubr (&Schar_table_parent
);
5503 defsubr (&Sset_char_table_parent
);
5504 defsubr (&Schar_table_extra_slot
);
5505 defsubr (&Sset_char_table_extra_slot
);
5506 defsubr (&Schar_table_range
);
5507 defsubr (&Sset_char_table_range
);
5508 defsubr (&Sset_char_table_default
);
5509 defsubr (&Soptimize_char_table
);
5510 defsubr (&Smap_char_table
);
5514 defsubr (&Smapconcat
);
5515 defsubr (&Sy_or_n_p
);
5516 defsubr (&Syes_or_no_p
);
5517 defsubr (&Sload_average
);
5518 defsubr (&Sfeaturep
);
5519 defsubr (&Srequire
);
5520 defsubr (&Sprovide
);
5521 defsubr (&Splist_member
);
5522 defsubr (&Swidget_put
);
5523 defsubr (&Swidget_get
);
5524 defsubr (&Swidget_apply
);
5525 defsubr (&Sbase64_encode_region
);
5526 defsubr (&Sbase64_decode_region
);
5527 defsubr (&Sbase64_encode_string
);
5528 defsubr (&Sbase64_decode_string
);
5536 Vweak_hash_tables
= Qnil
;