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 and VAL are any objects.
2036 If PROP is already a property on the list, its value is set to VAL,
2037 otherwise the new PROP VAL pair is added. The new plist is returned;
2038 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2039 The PLIST is modified by side effects. */)
2042 register Lisp_Object prop
;
2045 register Lisp_Object tail
, prev
;
2046 Lisp_Object newcell
;
2048 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2049 tail
= XCDR (XCDR (tail
)))
2051 if (! NILP (Fequal (prop
, XCAR (tail
))))
2053 Fsetcar (XCDR (tail
), val
);
2060 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2064 Fsetcdr (XCDR (prev
), newcell
);
2068 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2069 doc
: /* Return t if two Lisp objects have similar structure and contents.
2070 They must have the same data type.
2071 Conses are compared by comparing the cars and the cdrs.
2072 Vectors and strings are compared element by element.
2073 Numbers are compared by value, but integers cannot equal floats.
2074 (Use `=' if you want integers and floats to be able to be equal.)
2075 Symbols must match exactly. */)
2077 register Lisp_Object o1
, o2
;
2079 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2083 internal_equal (o1
, o2
, depth
)
2084 register Lisp_Object o1
, o2
;
2088 error ("Stack overflow in equal");
2094 if (XTYPE (o1
) != XTYPE (o2
))
2100 return (extract_float (o1
) == extract_float (o2
));
2103 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2110 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2114 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2116 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2119 o1
= XOVERLAY (o1
)->plist
;
2120 o2
= XOVERLAY (o2
)->plist
;
2125 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2126 && (XMARKER (o1
)->buffer
== 0
2127 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2131 case Lisp_Vectorlike
:
2133 register int i
, size
;
2134 size
= XVECTOR (o1
)->size
;
2135 /* Pseudovectors have the type encoded in the size field, so this test
2136 actually checks that the objects have the same type as well as the
2138 if (XVECTOR (o2
)->size
!= size
)
2140 /* Boolvectors are compared much like strings. */
2141 if (BOOL_VECTOR_P (o1
))
2144 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2146 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2148 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2153 if (WINDOW_CONFIGURATIONP (o1
))
2154 return compare_window_configurations (o1
, o2
, 0);
2156 /* Aside from them, only true vectors, char-tables, and compiled
2157 functions are sensible to compare, so eliminate the others now. */
2158 if (size
& PSEUDOVECTOR_FLAG
)
2160 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2162 size
&= PSEUDOVECTOR_SIZE_MASK
;
2164 for (i
= 0; i
< size
; i
++)
2167 v1
= XVECTOR (o1
)->contents
[i
];
2168 v2
= XVECTOR (o2
)->contents
[i
];
2169 if (!internal_equal (v1
, v2
, depth
+ 1))
2177 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
2179 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
2181 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
2182 STRING_BYTES (XSTRING (o1
))))
2188 case Lisp_Type_Limit
:
2195 extern Lisp_Object
Fmake_char_internal ();
2197 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2198 doc
: /* Store each element of ARRAY with ITEM.
2199 ARRAY is a vector, string, char-table, or bool-vector. */)
2201 Lisp_Object array
, item
;
2203 register int size
, index
, charval
;
2205 if (VECTORP (array
))
2207 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2208 size
= XVECTOR (array
)->size
;
2209 for (index
= 0; index
< size
; index
++)
2212 else if (CHAR_TABLE_P (array
))
2214 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2215 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2216 for (index
= 0; index
< size
; index
++)
2218 XCHAR_TABLE (array
)->defalt
= Qnil
;
2220 else if (STRINGP (array
))
2222 register unsigned char *p
= XSTRING (array
)->data
;
2223 CHECK_NUMBER (item
);
2224 charval
= XINT (item
);
2225 size
= XSTRING (array
)->size
;
2226 if (STRING_MULTIBYTE (array
))
2228 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2229 int len
= CHAR_STRING (charval
, str
);
2230 int size_byte
= STRING_BYTES (XSTRING (array
));
2231 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2234 if (size
!= size_byte
)
2237 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2238 if (len
!= this_len
)
2239 error ("Attempt to change byte length of a string");
2242 for (i
= 0; i
< size_byte
; i
++)
2243 *p
++ = str
[i
% len
];
2246 for (index
= 0; index
< size
; index
++)
2249 else if (BOOL_VECTOR_P (array
))
2251 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2253 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2255 charval
= (! NILP (item
) ? -1 : 0);
2256 for (index
= 0; index
< size_in_chars
; index
++)
2261 array
= wrong_type_argument (Qarrayp
, array
);
2267 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2269 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2271 Lisp_Object char_table
;
2273 CHECK_CHAR_TABLE (char_table
);
2275 return XCHAR_TABLE (char_table
)->purpose
;
2278 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2280 doc
: /* Return the parent char-table of CHAR-TABLE.
2281 The value is either nil or another char-table.
2282 If CHAR-TABLE holds nil for a given character,
2283 then the actual applicable value is inherited from the parent char-table
2284 \(or from its parents, if necessary). */)
2286 Lisp_Object char_table
;
2288 CHECK_CHAR_TABLE (char_table
);
2290 return XCHAR_TABLE (char_table
)->parent
;
2293 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2295 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2296 PARENT must be either nil or another char-table. */)
2297 (char_table
, parent
)
2298 Lisp_Object char_table
, parent
;
2302 CHECK_CHAR_TABLE (char_table
);
2306 CHECK_CHAR_TABLE (parent
);
2308 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2309 if (EQ (temp
, char_table
))
2310 error ("Attempt to make a chartable be its own parent");
2313 XCHAR_TABLE (char_table
)->parent
= parent
;
2318 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2320 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2322 Lisp_Object char_table
, n
;
2324 CHECK_CHAR_TABLE (char_table
);
2327 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2328 args_out_of_range (char_table
, n
);
2330 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2333 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2334 Sset_char_table_extra_slot
,
2336 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2337 (char_table
, n
, value
)
2338 Lisp_Object char_table
, n
, value
;
2340 CHECK_CHAR_TABLE (char_table
);
2343 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2344 args_out_of_range (char_table
, n
);
2346 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2349 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2351 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2352 RANGE should be nil (for the default value)
2353 a vector which identifies a character set or a row of a character set,
2354 a character set name, or a character code. */)
2356 Lisp_Object char_table
, range
;
2358 CHECK_CHAR_TABLE (char_table
);
2360 if (EQ (range
, Qnil
))
2361 return XCHAR_TABLE (char_table
)->defalt
;
2362 else if (INTEGERP (range
))
2363 return Faref (char_table
, range
);
2364 else if (SYMBOLP (range
))
2366 Lisp_Object charset_info
;
2368 charset_info
= Fget (range
, Qcharset
);
2369 CHECK_VECTOR (charset_info
);
2371 return Faref (char_table
,
2372 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2375 else if (VECTORP (range
))
2377 if (XVECTOR (range
)->size
== 1)
2378 return Faref (char_table
,
2379 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2382 int size
= XVECTOR (range
)->size
;
2383 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2384 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2385 size
<= 1 ? Qnil
: val
[1],
2386 size
<= 2 ? Qnil
: val
[2]);
2387 return Faref (char_table
, ch
);
2391 error ("Invalid RANGE argument to `char-table-range'");
2395 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2397 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2398 RANGE should be t (for all characters), nil (for the default value)
2399 a vector which identifies a character set or a row of a character set,
2400 a coding system, or a character code. */)
2401 (char_table
, range
, value
)
2402 Lisp_Object char_table
, range
, value
;
2406 CHECK_CHAR_TABLE (char_table
);
2409 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2410 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2411 else if (EQ (range
, Qnil
))
2412 XCHAR_TABLE (char_table
)->defalt
= value
;
2413 else if (SYMBOLP (range
))
2415 Lisp_Object charset_info
;
2417 charset_info
= Fget (range
, Qcharset
);
2418 CHECK_VECTOR (charset_info
);
2420 return Faset (char_table
,
2421 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2425 else if (INTEGERP (range
))
2426 Faset (char_table
, range
, value
);
2427 else if (VECTORP (range
))
2429 if (XVECTOR (range
)->size
== 1)
2430 return Faset (char_table
,
2431 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2435 int size
= XVECTOR (range
)->size
;
2436 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2437 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2438 size
<= 1 ? Qnil
: val
[1],
2439 size
<= 2 ? Qnil
: val
[2]);
2440 return Faset (char_table
, ch
, value
);
2444 error ("Invalid RANGE argument to `set-char-table-range'");
2449 DEFUN ("set-char-table-default", Fset_char_table_default
,
2450 Sset_char_table_default
, 3, 3, 0,
2451 doc
: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
2452 The generic character specifies the group of characters.
2453 See also the documentation of make-char. */)
2454 (char_table
, ch
, value
)
2455 Lisp_Object char_table
, ch
, value
;
2457 int c
, charset
, code1
, code2
;
2460 CHECK_CHAR_TABLE (char_table
);
2464 SPLIT_CHAR (c
, charset
, code1
, code2
);
2466 /* Since we may want to set the default value for a character set
2467 not yet defined, we check only if the character set is in the
2468 valid range or not, instead of it is already defined or not. */
2469 if (! CHARSET_VALID_P (charset
))
2470 invalid_character (c
);
2472 if (charset
== CHARSET_ASCII
)
2473 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2475 /* Even if C is not a generic char, we had better behave as if a
2476 generic char is specified. */
2477 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2479 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2482 if (SUB_CHAR_TABLE_P (temp
))
2483 XCHAR_TABLE (temp
)->defalt
= value
;
2485 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2488 if (SUB_CHAR_TABLE_P (temp
))
2491 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2492 = make_sub_char_table (temp
));
2493 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2494 if (SUB_CHAR_TABLE_P (temp
))
2495 XCHAR_TABLE (temp
)->defalt
= value
;
2497 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2501 /* Look up the element in TABLE at index CH,
2502 and return it as an integer.
2503 If the element is nil, return CH itself.
2504 (Actually we do that for any non-integer.) */
2507 char_table_translate (table
, ch
)
2512 value
= Faref (table
, make_number (ch
));
2513 if (! INTEGERP (value
))
2515 return XINT (value
);
2519 optimize_sub_char_table (table
, chars
)
2527 from
= 33, to
= 127;
2529 from
= 32, to
= 128;
2531 if (!SUB_CHAR_TABLE_P (*table
))
2533 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2534 for (; from
< to
; from
++)
2535 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2540 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2541 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2549 CHECK_CHAR_TABLE (table
);
2551 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2553 elt
= XCHAR_TABLE (table
)->contents
[i
];
2554 if (!SUB_CHAR_TABLE_P (elt
))
2556 dim
= CHARSET_DIMENSION (i
- 128);
2558 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2559 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2560 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2566 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2567 character or group of characters that share a value.
2568 DEPTH is the current depth in the originally specified
2569 chartable, and INDICES contains the vector indices
2570 for the levels our callers have descended.
2572 ARG is passed to C_FUNCTION when that is called. */
2575 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2576 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2577 Lisp_Object function
, subtable
, arg
, *indices
;
2584 /* At first, handle ASCII and 8-bit European characters. */
2585 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2587 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2589 (*c_function
) (arg
, make_number (i
), elt
);
2591 call2 (function
, make_number (i
), elt
);
2593 #if 0 /* If the char table has entries for higher characters,
2594 we should report them. */
2595 if (NILP (current_buffer
->enable_multibyte_characters
))
2598 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2602 int charset
= XFASTINT (indices
[0]) - 128;
2605 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2606 if (CHARSET_CHARS (charset
) == 94)
2615 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2616 XSETFASTINT (indices
[depth
], i
);
2617 charset
= XFASTINT (indices
[0]) - 128;
2619 && (!CHARSET_DEFINED_P (charset
)
2620 || charset
== CHARSET_8_BIT_CONTROL
2621 || charset
== CHARSET_8_BIT_GRAPHIC
))
2624 if (SUB_CHAR_TABLE_P (elt
))
2627 error ("Too deep char table");
2628 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2635 elt
= XCHAR_TABLE (subtable
)->defalt
;
2636 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2637 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2638 c
= MAKE_CHAR (charset
, c1
, c2
);
2640 (*c_function
) (arg
, make_number (c
), elt
);
2642 call2 (function
, make_number (c
), elt
);
2647 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2649 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2650 FUNCTION is called with two arguments--a key and a value.
2651 The key is always a possible IDX argument to `aref'. */)
2652 (function
, char_table
)
2653 Lisp_Object function
, char_table
;
2655 /* The depth of char table is at most 3. */
2656 Lisp_Object indices
[3];
2658 CHECK_CHAR_TABLE (char_table
);
2660 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2664 /* Return a value for character C in char-table TABLE. Store the
2665 actual index for that value in *IDX. Ignore the default value of
2669 char_table_ref_and_index (table
, c
, idx
)
2673 int charset
, c1
, c2
;
2676 if (SINGLE_BYTE_CHAR_P (c
))
2679 return XCHAR_TABLE (table
)->contents
[c
];
2681 SPLIT_CHAR (c
, charset
, c1
, c2
);
2682 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2683 *idx
= MAKE_CHAR (charset
, 0, 0);
2684 if (!SUB_CHAR_TABLE_P (elt
))
2686 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2687 return XCHAR_TABLE (elt
)->defalt
;
2688 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2689 *idx
= MAKE_CHAR (charset
, c1
, 0);
2690 if (!SUB_CHAR_TABLE_P (elt
))
2692 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2693 return XCHAR_TABLE (elt
)->defalt
;
2695 return XCHAR_TABLE (elt
)->contents
[c2
];
2705 Lisp_Object args
[2];
2708 return Fnconc (2, args
);
2710 return Fnconc (2, &s1
);
2711 #endif /* NO_ARG_ARRAY */
2714 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2715 doc
: /* Concatenate any number of lists by altering them.
2716 Only the last argument is not altered, and need not be a list.
2717 usage: (nconc &rest LISTS) */)
2722 register int argnum
;
2723 register Lisp_Object tail
, tem
, val
;
2727 for (argnum
= 0; argnum
< nargs
; argnum
++)
2730 if (NILP (tem
)) continue;
2735 if (argnum
+ 1 == nargs
) break;
2738 tem
= wrong_type_argument (Qlistp
, tem
);
2747 tem
= args
[argnum
+ 1];
2748 Fsetcdr (tail
, tem
);
2750 args
[argnum
+ 1] = tail
;
2756 /* This is the guts of all mapping functions.
2757 Apply FN to each element of SEQ, one by one,
2758 storing the results into elements of VALS, a C vector of Lisp_Objects.
2759 LENI is the length of VALS, which should also be the length of SEQ. */
2762 mapcar1 (leni
, vals
, fn
, seq
)
2765 Lisp_Object fn
, seq
;
2767 register Lisp_Object tail
;
2770 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2774 /* Don't let vals contain any garbage when GC happens. */
2775 for (i
= 0; i
< leni
; i
++)
2778 GCPRO3 (dummy
, fn
, seq
);
2780 gcpro1
.nvars
= leni
;
2784 /* We need not explicitly protect `tail' because it is used only on lists, and
2785 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2789 for (i
= 0; i
< leni
; i
++)
2791 dummy
= XVECTOR (seq
)->contents
[i
];
2792 dummy
= call1 (fn
, dummy
);
2797 else if (BOOL_VECTOR_P (seq
))
2799 for (i
= 0; i
< leni
; i
++)
2802 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2803 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2808 dummy
= call1 (fn
, dummy
);
2813 else if (STRINGP (seq
))
2817 for (i
= 0, i_byte
= 0; i
< leni
;)
2822 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2823 XSETFASTINT (dummy
, c
);
2824 dummy
= call1 (fn
, dummy
);
2826 vals
[i_before
] = dummy
;
2829 else /* Must be a list, since Flength did not get an error */
2832 for (i
= 0; i
< leni
; i
++)
2834 dummy
= call1 (fn
, Fcar (tail
));
2844 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2845 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2846 In between each pair of results, stick in SEPARATOR. Thus, " " as
2847 SEPARATOR results in spaces between the values returned by FUNCTION.
2848 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2849 (function
, sequence
, separator
)
2850 Lisp_Object function
, sequence
, separator
;
2855 register Lisp_Object
*args
;
2857 struct gcpro gcpro1
;
2859 len
= Flength (sequence
);
2861 nargs
= leni
+ leni
- 1;
2862 if (nargs
< 0) return build_string ("");
2864 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2867 mapcar1 (leni
, args
, function
, sequence
);
2870 for (i
= leni
- 1; i
>= 0; i
--)
2871 args
[i
+ i
] = args
[i
];
2873 for (i
= 1; i
< nargs
; i
+= 2)
2874 args
[i
] = separator
;
2876 return Fconcat (nargs
, args
);
2879 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2880 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2881 The result is a list just as long as SEQUENCE.
2882 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2883 (function
, sequence
)
2884 Lisp_Object function
, sequence
;
2886 register Lisp_Object len
;
2888 register Lisp_Object
*args
;
2890 len
= Flength (sequence
);
2891 leni
= XFASTINT (len
);
2892 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2894 mapcar1 (leni
, args
, function
, sequence
);
2896 return Flist (leni
, args
);
2899 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2900 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2901 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2902 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2903 (function
, sequence
)
2904 Lisp_Object function
, sequence
;
2908 leni
= XFASTINT (Flength (sequence
));
2909 mapcar1 (leni
, 0, function
, sequence
);
2914 /* Anything that calls this function must protect from GC! */
2916 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2917 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2918 Takes one argument, which is the string to display to ask the question.
2919 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2920 No confirmation of the answer is requested; a single character is enough.
2921 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2922 the bindings in `query-replace-map'; see the documentation of that variable
2923 for more information. In this case, the useful bindings are `act', `skip',
2924 `recenter', and `quit'.\)
2926 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2927 is nil and `use-dialog-box' is non-nil. */)
2931 register Lisp_Object obj
, key
, def
, map
;
2932 register int answer
;
2933 Lisp_Object xprompt
;
2934 Lisp_Object args
[2];
2935 struct gcpro gcpro1
, gcpro2
;
2936 int count
= specpdl_ptr
- specpdl
;
2938 specbind (Qcursor_in_echo_area
, Qt
);
2940 map
= Fsymbol_value (intern ("query-replace-map"));
2942 CHECK_STRING (prompt
);
2944 GCPRO2 (prompt
, xprompt
);
2946 #ifdef HAVE_X_WINDOWS
2947 if (display_hourglass_p
)
2948 cancel_hourglass ();
2955 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2959 Lisp_Object pane
, menu
;
2960 redisplay_preserve_echo_area (3);
2961 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2962 Fcons (Fcons (build_string ("No"), Qnil
),
2964 menu
= Fcons (prompt
, pane
);
2965 obj
= Fx_popup_dialog (Qt
, menu
);
2966 answer
= !NILP (obj
);
2969 #endif /* HAVE_MENUS */
2970 cursor_in_echo_area
= 1;
2971 choose_minibuf_frame ();
2974 Lisp_Object pargs
[3];
2976 /* Colorize prompt according to `minibuffer-prompt' face. */
2977 pargs
[0] = build_string ("%s(y or n) ");
2978 pargs
[1] = intern ("face");
2979 pargs
[2] = intern ("minibuffer-prompt");
2980 args
[0] = Fpropertize (3, pargs
);
2985 if (minibuffer_auto_raise
)
2987 Lisp_Object mini_frame
;
2989 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2991 Fraise_frame (mini_frame
);
2994 obj
= read_filtered_event (1, 0, 0, 0);
2995 cursor_in_echo_area
= 0;
2996 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2999 key
= Fmake_vector (make_number (1), obj
);
3000 def
= Flookup_key (map
, key
, Qt
);
3002 if (EQ (def
, intern ("skip")))
3007 else if (EQ (def
, intern ("act")))
3012 else if (EQ (def
, intern ("recenter")))
3018 else if (EQ (def
, intern ("quit")))
3020 /* We want to exit this command for exit-prefix,
3021 and this is the only way to do it. */
3022 else if (EQ (def
, intern ("exit-prefix")))
3027 /* If we don't clear this, then the next call to read_char will
3028 return quit_char again, and we'll enter an infinite loop. */
3033 if (EQ (xprompt
, prompt
))
3035 args
[0] = build_string ("Please answer y or n. ");
3037 xprompt
= Fconcat (2, args
);
3042 if (! noninteractive
)
3044 cursor_in_echo_area
= -1;
3045 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3049 unbind_to (count
, Qnil
);
3050 return answer
? Qt
: Qnil
;
3053 /* This is how C code calls `yes-or-no-p' and allows the user
3056 Anything that calls this function must protect from GC! */
3059 do_yes_or_no_p (prompt
)
3062 return call1 (intern ("yes-or-no-p"), prompt
);
3065 /* Anything that calls this function must protect from GC! */
3067 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3068 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3069 Takes one argument, which is the string to display to ask the question.
3070 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3071 The user must confirm the answer with RET,
3072 and can edit it until it has been confirmed.
3074 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3075 is nil, and `use-dialog-box' is non-nil. */)
3079 register Lisp_Object ans
;
3080 Lisp_Object args
[2];
3081 struct gcpro gcpro1
;
3083 CHECK_STRING (prompt
);
3086 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3090 Lisp_Object pane
, menu
, obj
;
3091 redisplay_preserve_echo_area (4);
3092 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3093 Fcons (Fcons (build_string ("No"), Qnil
),
3096 menu
= Fcons (prompt
, pane
);
3097 obj
= Fx_popup_dialog (Qt
, menu
);
3101 #endif /* HAVE_MENUS */
3104 args
[1] = build_string ("(yes or no) ");
3105 prompt
= Fconcat (2, args
);
3111 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3112 Qyes_or_no_p_history
, Qnil
,
3114 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
3119 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
3127 message ("Please answer yes or no.");
3128 Fsleep_for (make_number (2), Qnil
);
3132 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3133 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3135 Each of the three load averages is multiplied by 100, then converted
3138 When USE-FLOATS is non-nil, floats will be used instead of integers.
3139 These floats are not multiplied by 100.
3141 If the 5-minute or 15-minute load averages are not available, return a
3142 shortened list, containing only those averages which are available. */)
3144 Lisp_Object use_floats
;
3147 int loads
= getloadavg (load_ave
, 3);
3148 Lisp_Object ret
= Qnil
;
3151 error ("load-average not implemented for this operating system");
3155 Lisp_Object load
= (NILP (use_floats
) ?
3156 make_number ((int) (100.0 * load_ave
[loads
]))
3157 : make_float (load_ave
[loads
]));
3158 ret
= Fcons (load
, ret
);
3164 Lisp_Object Vfeatures
, Qsubfeatures
;
3165 extern Lisp_Object Vafter_load_alist
;
3167 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3168 doc
: /* Returns t if FEATURE is present in this Emacs.
3170 Use this to conditionalize execution of lisp code based on the
3171 presence or absence of emacs or environment extensions.
3172 Use `provide' to declare that a feature is available. This function
3173 looks at the value of the variable `features'. The optional argument
3174 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3175 (feature
, subfeature
)
3176 Lisp_Object feature
, subfeature
;
3178 register Lisp_Object tem
;
3179 CHECK_SYMBOL (feature
);
3180 tem
= Fmemq (feature
, Vfeatures
);
3181 if (!NILP (tem
) && !NILP (subfeature
))
3182 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3183 return (NILP (tem
)) ? Qnil
: Qt
;
3186 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3187 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3188 The optional argument SUBFEATURES should be a list of symbols listing
3189 particular subfeatures supported in this version of FEATURE. */)
3190 (feature
, subfeatures
)
3191 Lisp_Object feature
, subfeatures
;
3193 register Lisp_Object tem
;
3194 CHECK_SYMBOL (feature
);
3195 CHECK_LIST (subfeatures
);
3196 if (!NILP (Vautoload_queue
))
3197 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3198 tem
= Fmemq (feature
, Vfeatures
);
3200 Vfeatures
= Fcons (feature
, Vfeatures
);
3201 if (!NILP (subfeatures
))
3202 Fput (feature
, Qsubfeatures
, subfeatures
);
3203 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3205 /* Run any load-hooks for this file. */
3206 tem
= Fassq (feature
, Vafter_load_alist
);
3208 Fprogn (Fcdr (tem
));
3213 /* `require' and its subroutines. */
3215 /* List of features currently being require'd, innermost first. */
3217 Lisp_Object require_nesting_list
;
3220 require_unwind (old_value
)
3221 Lisp_Object old_value
;
3223 return require_nesting_list
= old_value
;
3226 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3227 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3228 If FEATURE is not a member of the list `features', then the feature
3229 is not loaded; so load the file FILENAME.
3230 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3231 and `load' will try to load this name appended with the suffix `.elc',
3232 `.el' or the unmodified name, in that order.
3233 If the optional third argument NOERROR is non-nil,
3234 then return nil if the file is not found instead of signaling an error.
3235 Normally the return value is FEATURE.
3236 The normal messages at start and end of loading FILENAME are suppressed. */)
3237 (feature
, filename
, noerror
)
3238 Lisp_Object feature
, filename
, noerror
;
3240 register Lisp_Object tem
;
3241 struct gcpro gcpro1
, gcpro2
;
3243 CHECK_SYMBOL (feature
);
3245 tem
= Fmemq (feature
, Vfeatures
);
3247 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3251 int count
= specpdl_ptr
- specpdl
;
3254 if (! NILP (Vpurify_flag
))
3255 error ("(require %s) while preparing to dump",
3256 XSYMBOL (feature
)->name
->data
);
3258 /* A certain amount of recursive `require' is legitimate,
3259 but if we require the same feature recursively 3 times,
3261 tem
= require_nesting_list
;
3262 while (! NILP (tem
))
3264 if (! NILP (Fequal (feature
, XCAR (tem
))))
3269 error ("Recursive `require' for feature `%s'",
3270 XSYMBOL (feature
)->name
->data
);
3272 /* Update the list for any nested `require's that occur. */
3273 record_unwind_protect (require_unwind
, require_nesting_list
);
3274 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3276 /* Value saved here is to be restored into Vautoload_queue */
3277 record_unwind_protect (un_autoload
, Vautoload_queue
);
3278 Vautoload_queue
= Qt
;
3280 /* Load the file. */
3281 GCPRO2 (feature
, filename
);
3282 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3283 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3286 /* If load failed entirely, return nil. */
3288 return unbind_to (count
, Qnil
);
3290 tem
= Fmemq (feature
, Vfeatures
);
3292 error ("Required feature `%s' was not provided",
3293 XSYMBOL (feature
)->name
->data
);
3295 /* Once loading finishes, don't undo it. */
3296 Vautoload_queue
= Qt
;
3297 feature
= unbind_to (count
, feature
);
3303 /* Primitives for work of the "widget" library.
3304 In an ideal world, this section would not have been necessary.
3305 However, lisp function calls being as slow as they are, it turns
3306 out that some functions in the widget library (wid-edit.el) are the
3307 bottleneck of Widget operation. Here is their translation to C,
3308 for the sole reason of efficiency. */
3310 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3311 doc
: /* Return non-nil if PLIST has the property PROP.
3312 PLIST is a property list, which is a list of the form
3313 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3314 Unlike `plist-get', this allows you to distinguish between a missing
3315 property and a property with the value nil.
3316 The value is actually the tail of PLIST whose car is PROP. */)
3318 Lisp_Object plist
, prop
;
3320 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3323 plist
= XCDR (plist
);
3324 plist
= CDR (plist
);
3329 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3330 doc
: /* In WIDGET, set PROPERTY to VALUE.
3331 The value can later be retrieved with `widget-get'. */)
3332 (widget
, property
, value
)
3333 Lisp_Object widget
, property
, value
;
3335 CHECK_CONS (widget
);
3336 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3340 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3341 doc
: /* In WIDGET, get the value of PROPERTY.
3342 The value could either be specified when the widget was created, or
3343 later with `widget-put'. */)
3345 Lisp_Object widget
, property
;
3353 CHECK_CONS (widget
);
3354 tmp
= Fplist_member (XCDR (widget
), property
);
3360 tmp
= XCAR (widget
);
3363 widget
= Fget (tmp
, Qwidget_type
);
3367 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3368 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3369 ARGS are passed as extra arguments to the function.
3370 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3375 /* This function can GC. */
3376 Lisp_Object newargs
[3];
3377 struct gcpro gcpro1
, gcpro2
;
3380 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3381 newargs
[1] = args
[0];
3382 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3383 GCPRO2 (newargs
[0], newargs
[2]);
3384 result
= Fapply (3, newargs
);
3389 /* base64 encode/decode functions (RFC 2045).
3390 Based on code from GNU recode. */
3392 #define MIME_LINE_LENGTH 76
3394 #define IS_ASCII(Character) \
3396 #define IS_BASE64(Character) \
3397 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3398 #define IS_BASE64_IGNORABLE(Character) \
3399 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3400 || (Character) == '\f' || (Character) == '\r')
3402 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3403 character or return retval if there are no characters left to
3405 #define READ_QUADRUPLET_BYTE(retval) \
3410 if (nchars_return) \
3411 *nchars_return = nchars; \
3416 while (IS_BASE64_IGNORABLE (c))
3418 /* Don't use alloca for regions larger than this, lest we overflow
3420 #define MAX_ALLOCA 16*1024
3422 /* Table of characters coding the 64 values. */
3423 static char base64_value_to_char
[64] =
3425 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3426 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3427 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3428 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3429 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3430 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3431 '8', '9', '+', '/' /* 60-63 */
3434 /* Table of base64 values for first 128 characters. */
3435 static short base64_char_to_value
[128] =
3437 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3438 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3439 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3440 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3441 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3442 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3443 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3444 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3445 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3446 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3447 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3448 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3449 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3452 /* The following diagram shows the logical steps by which three octets
3453 get transformed into four base64 characters.
3455 .--------. .--------. .--------.
3456 |aaaaaabb| |bbbbcccc| |ccdddddd|
3457 `--------' `--------' `--------'
3459 .--------+--------+--------+--------.
3460 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3461 `--------+--------+--------+--------'
3463 .--------+--------+--------+--------.
3464 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3465 `--------+--------+--------+--------'
3467 The octets are divided into 6 bit chunks, which are then encoded into
3468 base64 characters. */
3471 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3472 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3474 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3476 doc
: /* Base64-encode the region between BEG and END.
3477 Return the length of the encoded text.
3478 Optional third argument NO-LINE-BREAK means do not break long lines
3479 into shorter lines. */)
3480 (beg
, end
, no_line_break
)
3481 Lisp_Object beg
, end
, no_line_break
;
3484 int allength
, length
;
3485 int ibeg
, iend
, encoded_length
;
3488 validate_region (&beg
, &end
);
3490 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3491 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3492 move_gap_both (XFASTINT (beg
), ibeg
);
3494 /* We need to allocate enough room for encoding the text.
3495 We need 33 1/3% more space, plus a newline every 76
3496 characters, and then we round up. */
3497 length
= iend
- ibeg
;
3498 allength
= length
+ length
/3 + 1;
3499 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3501 if (allength
<= MAX_ALLOCA
)
3502 encoded
= (char *) alloca (allength
);
3504 encoded
= (char *) xmalloc (allength
);
3505 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3506 NILP (no_line_break
),
3507 !NILP (current_buffer
->enable_multibyte_characters
));
3508 if (encoded_length
> allength
)
3511 if (encoded_length
< 0)
3513 /* The encoding wasn't possible. */
3514 if (length
> MAX_ALLOCA
)
3516 error ("Multibyte character in data for base64 encoding");
3519 /* Now we have encoded the region, so we insert the new contents
3520 and delete the old. (Insert first in order to preserve markers.) */
3521 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3522 insert (encoded
, encoded_length
);
3523 if (allength
> MAX_ALLOCA
)
3525 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3527 /* If point was outside of the region, restore it exactly; else just
3528 move to the beginning of the region. */
3529 if (old_pos
>= XFASTINT (end
))
3530 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3531 else if (old_pos
> XFASTINT (beg
))
3532 old_pos
= XFASTINT (beg
);
3535 /* We return the length of the encoded text. */
3536 return make_number (encoded_length
);
3539 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3541 doc
: /* Base64-encode STRING and return the result.
3542 Optional second argument NO-LINE-BREAK means do not break long lines
3543 into shorter lines. */)
3544 (string
, no_line_break
)
3545 Lisp_Object string
, no_line_break
;
3547 int allength
, length
, encoded_length
;
3549 Lisp_Object encoded_string
;
3551 CHECK_STRING (string
);
3553 /* We need to allocate enough room for encoding the text.
3554 We need 33 1/3% more space, plus a newline every 76
3555 characters, and then we round up. */
3556 length
= STRING_BYTES (XSTRING (string
));
3557 allength
= length
+ length
/3 + 1;
3558 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3560 /* We need to allocate enough room for decoding the text. */
3561 if (allength
<= MAX_ALLOCA
)
3562 encoded
= (char *) alloca (allength
);
3564 encoded
= (char *) xmalloc (allength
);
3566 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3567 encoded
, length
, NILP (no_line_break
),
3568 STRING_MULTIBYTE (string
));
3569 if (encoded_length
> allength
)
3572 if (encoded_length
< 0)
3574 /* The encoding wasn't possible. */
3575 if (length
> MAX_ALLOCA
)
3577 error ("Multibyte character in data for base64 encoding");
3580 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3581 if (allength
> MAX_ALLOCA
)
3584 return encoded_string
;
3588 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3595 int counter
= 0, i
= 0;
3605 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3613 /* Wrap line every 76 characters. */
3617 if (counter
< MIME_LINE_LENGTH
/ 4)
3626 /* Process first byte of a triplet. */
3628 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3629 value
= (0x03 & c
) << 4;
3631 /* Process second byte of a triplet. */
3635 *e
++ = base64_value_to_char
[value
];
3643 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3651 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3652 value
= (0x0f & c
) << 2;
3654 /* Process third byte of a triplet. */
3658 *e
++ = base64_value_to_char
[value
];
3665 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3673 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3674 *e
++ = base64_value_to_char
[0x3f & c
];
3681 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3683 doc
: /* Base64-decode the region between BEG and END.
3684 Return the length of the decoded text.
3685 If the region can't be decoded, signal an error and don't modify the buffer. */)
3687 Lisp_Object beg
, end
;
3689 int ibeg
, iend
, length
, allength
;
3694 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3696 validate_region (&beg
, &end
);
3698 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3699 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3701 length
= iend
- ibeg
;
3703 /* We need to allocate enough room for decoding the text. If we are
3704 working on a multibyte buffer, each decoded code may occupy at
3706 allength
= multibyte
? length
* 2 : length
;
3707 if (allength
<= MAX_ALLOCA
)
3708 decoded
= (char *) alloca (allength
);
3710 decoded
= (char *) xmalloc (allength
);
3712 move_gap_both (XFASTINT (beg
), ibeg
);
3713 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3714 multibyte
, &inserted_chars
);
3715 if (decoded_length
> allength
)
3718 if (decoded_length
< 0)
3720 /* The decoding wasn't possible. */
3721 if (allength
> MAX_ALLOCA
)
3723 error ("Invalid base64 data");
3726 /* Now we have decoded the region, so we insert the new contents
3727 and delete the old. (Insert first in order to preserve markers.) */
3728 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3729 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3730 if (allength
> MAX_ALLOCA
)
3732 /* Delete the original text. */
3733 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3734 iend
+ decoded_length
, 1);
3736 /* If point was outside of the region, restore it exactly; else just
3737 move to the beginning of the region. */
3738 if (old_pos
>= XFASTINT (end
))
3739 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3740 else if (old_pos
> XFASTINT (beg
))
3741 old_pos
= XFASTINT (beg
);
3742 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3744 return make_number (inserted_chars
);
3747 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3749 doc
: /* Base64-decode STRING and return the result. */)
3754 int length
, decoded_length
;
3755 Lisp_Object decoded_string
;
3757 CHECK_STRING (string
);
3759 length
= STRING_BYTES (XSTRING (string
));
3760 /* We need to allocate enough room for decoding the text. */
3761 if (length
<= MAX_ALLOCA
)
3762 decoded
= (char *) alloca (length
);
3764 decoded
= (char *) xmalloc (length
);
3766 /* The decoded result should be unibyte. */
3767 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3769 if (decoded_length
> length
)
3771 else if (decoded_length
>= 0)
3772 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3774 decoded_string
= Qnil
;
3776 if (length
> MAX_ALLOCA
)
3778 if (!STRINGP (decoded_string
))
3779 error ("Invalid base64 data");
3781 return decoded_string
;
3784 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3785 MULTIBYTE is nonzero, the decoded result should be in multibyte
3786 form. If NCHARS_RETRUN is not NULL, store the number of produced
3787 characters in *NCHARS_RETURN. */
3790 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3800 unsigned long value
;
3805 /* Process first byte of a quadruplet. */
3807 READ_QUADRUPLET_BYTE (e
-to
);
3811 value
= base64_char_to_value
[c
] << 18;
3813 /* Process second byte of a quadruplet. */
3815 READ_QUADRUPLET_BYTE (-1);
3819 value
|= base64_char_to_value
[c
] << 12;
3821 c
= (unsigned char) (value
>> 16);
3823 e
+= CHAR_STRING (c
, e
);
3828 /* Process third byte of a quadruplet. */
3830 READ_QUADRUPLET_BYTE (-1);
3834 READ_QUADRUPLET_BYTE (-1);
3843 value
|= base64_char_to_value
[c
] << 6;
3845 c
= (unsigned char) (0xff & value
>> 8);
3847 e
+= CHAR_STRING (c
, e
);
3852 /* Process fourth byte of a quadruplet. */
3854 READ_QUADRUPLET_BYTE (-1);
3861 value
|= base64_char_to_value
[c
];
3863 c
= (unsigned char) (0xff & value
);
3865 e
+= CHAR_STRING (c
, e
);
3874 /***********************************************************************
3876 ***** Hash Tables *****
3878 ***********************************************************************/
3880 /* Implemented by gerd@gnu.org. This hash table implementation was
3881 inspired by CMUCL hash tables. */
3885 1. For small tables, association lists are probably faster than
3886 hash tables because they have lower overhead.
3888 For uses of hash tables where the O(1) behavior of table
3889 operations is not a requirement, it might therefore be a good idea
3890 not to hash. Instead, we could just do a linear search in the
3891 key_and_value vector of the hash table. This could be done
3892 if a `:linear-search t' argument is given to make-hash-table. */
3895 /* Value is the key part of entry IDX in hash table H. */
3897 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3899 /* Value is the value part of entry IDX in hash table H. */
3901 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3903 /* Value is the index of the next entry following the one at IDX
3906 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3908 /* Value is the hash code computed for entry IDX in hash table H. */
3910 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3912 /* Value is the index of the element in hash table H that is the
3913 start of the collision list at index IDX in the index vector of H. */
3915 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3917 /* Value is the size of hash table H. */
3919 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3921 /* The list of all weak hash tables. Don't staticpro this one. */
3923 Lisp_Object Vweak_hash_tables
;
3925 /* Various symbols. */
3927 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3928 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3929 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3931 /* Function prototypes. */
3933 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3934 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3935 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3936 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3937 Lisp_Object
, unsigned));
3938 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3939 Lisp_Object
, unsigned));
3940 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3941 unsigned, Lisp_Object
, unsigned));
3942 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3943 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3944 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3945 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3947 static unsigned sxhash_string
P_ ((unsigned char *, int));
3948 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3949 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3950 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3951 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3955 /***********************************************************************
3957 ***********************************************************************/
3959 /* If OBJ is a Lisp hash table, return a pointer to its struct
3960 Lisp_Hash_Table. Otherwise, signal an error. */
3962 static struct Lisp_Hash_Table
*
3963 check_hash_table (obj
)
3966 CHECK_HASH_TABLE (obj
);
3967 return XHASH_TABLE (obj
);
3971 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3975 next_almost_prime (n
)
3988 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3989 which USED[I] is non-zero. If found at index I in ARGS, set
3990 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3991 -1. This function is used to extract a keyword/argument pair from
3992 a DEFUN parameter list. */
3995 get_key_arg (key
, nargs
, args
, used
)
4003 for (i
= 0; i
< nargs
- 1; ++i
)
4004 if (!used
[i
] && EQ (args
[i
], key
))
4019 /* Return a Lisp vector which has the same contents as VEC but has
4020 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4021 vector that are not copied from VEC are set to INIT. */
4024 larger_vector (vec
, new_size
, init
)
4029 struct Lisp_Vector
*v
;
4032 xassert (VECTORP (vec
));
4033 old_size
= XVECTOR (vec
)->size
;
4034 xassert (new_size
>= old_size
);
4036 v
= allocate_vector (new_size
);
4037 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4038 old_size
* sizeof *v
->contents
);
4039 for (i
= old_size
; i
< new_size
; ++i
)
4040 v
->contents
[i
] = init
;
4041 XSETVECTOR (vec
, v
);
4046 /***********************************************************************
4048 ***********************************************************************/
4050 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4051 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4052 KEY2 are the same. */
4055 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4056 struct Lisp_Hash_Table
*h
;
4057 Lisp_Object key1
, key2
;
4058 unsigned hash1
, hash2
;
4060 return (FLOATP (key1
)
4062 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4066 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4067 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4068 KEY2 are the same. */
4071 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4072 struct Lisp_Hash_Table
*h
;
4073 Lisp_Object key1
, key2
;
4074 unsigned hash1
, hash2
;
4076 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4080 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4081 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4082 if KEY1 and KEY2 are the same. */
4085 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4086 struct Lisp_Hash_Table
*h
;
4087 Lisp_Object key1
, key2
;
4088 unsigned hash1
, hash2
;
4092 Lisp_Object args
[3];
4094 args
[0] = h
->user_cmp_function
;
4097 return !NILP (Ffuncall (3, args
));
4104 /* Value is a hash code for KEY for use in hash table H which uses
4105 `eq' to compare keys. The hash code returned is guaranteed to fit
4106 in a Lisp integer. */
4110 struct Lisp_Hash_Table
*h
;
4113 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4114 xassert ((hash
& ~VALMASK
) == 0);
4119 /* Value is a hash code for KEY for use in hash table H which uses
4120 `eql' to compare keys. The hash code returned is guaranteed to fit
4121 in a Lisp integer. */
4125 struct Lisp_Hash_Table
*h
;
4130 hash
= sxhash (key
, 0);
4132 hash
= XUINT (key
) ^ XGCTYPE (key
);
4133 xassert ((hash
& ~VALMASK
) == 0);
4138 /* Value is a hash code for KEY for use in hash table H which uses
4139 `equal' to compare keys. The hash code returned is guaranteed to fit
4140 in a Lisp integer. */
4143 hashfn_equal (h
, key
)
4144 struct Lisp_Hash_Table
*h
;
4147 unsigned hash
= sxhash (key
, 0);
4148 xassert ((hash
& ~VALMASK
) == 0);
4153 /* Value is a hash code for KEY for use in hash table H which uses as
4154 user-defined function to compare keys. The hash code returned is
4155 guaranteed to fit in a Lisp integer. */
4158 hashfn_user_defined (h
, key
)
4159 struct Lisp_Hash_Table
*h
;
4162 Lisp_Object args
[2], hash
;
4164 args
[0] = h
->user_hash_function
;
4166 hash
= Ffuncall (2, args
);
4167 if (!INTEGERP (hash
))
4169 list2 (build_string ("Invalid hash code returned from \
4170 user-supplied hash function"),
4172 return XUINT (hash
);
4176 /* Create and initialize a new hash table.
4178 TEST specifies the test the hash table will use to compare keys.
4179 It must be either one of the predefined tests `eq', `eql' or
4180 `equal' or a symbol denoting a user-defined test named TEST with
4181 test and hash functions USER_TEST and USER_HASH.
4183 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4185 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4186 new size when it becomes full is computed by adding REHASH_SIZE to
4187 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4188 table's new size is computed by multiplying its old size with
4191 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4192 be resized when the ratio of (number of entries in the table) /
4193 (table size) is >= REHASH_THRESHOLD.
4195 WEAK specifies the weakness of the table. If non-nil, it must be
4196 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4199 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4200 user_test
, user_hash
)
4201 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4202 Lisp_Object user_test
, user_hash
;
4204 struct Lisp_Hash_Table
*h
;
4206 int index_size
, i
, sz
;
4208 /* Preconditions. */
4209 xassert (SYMBOLP (test
));
4210 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4211 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4212 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4213 xassert (FLOATP (rehash_threshold
)
4214 && XFLOATINT (rehash_threshold
) > 0
4215 && XFLOATINT (rehash_threshold
) <= 1.0);
4217 if (XFASTINT (size
) == 0)
4218 size
= make_number (1);
4220 /* Allocate a table and initialize it. */
4221 h
= allocate_hash_table ();
4223 /* Initialize hash table slots. */
4224 sz
= XFASTINT (size
);
4227 if (EQ (test
, Qeql
))
4229 h
->cmpfn
= cmpfn_eql
;
4230 h
->hashfn
= hashfn_eql
;
4232 else if (EQ (test
, Qeq
))
4235 h
->hashfn
= hashfn_eq
;
4237 else if (EQ (test
, Qequal
))
4239 h
->cmpfn
= cmpfn_equal
;
4240 h
->hashfn
= hashfn_equal
;
4244 h
->user_cmp_function
= user_test
;
4245 h
->user_hash_function
= user_hash
;
4246 h
->cmpfn
= cmpfn_user_defined
;
4247 h
->hashfn
= hashfn_user_defined
;
4251 h
->rehash_threshold
= rehash_threshold
;
4252 h
->rehash_size
= rehash_size
;
4253 h
->count
= make_number (0);
4254 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4255 h
->hash
= Fmake_vector (size
, Qnil
);
4256 h
->next
= Fmake_vector (size
, Qnil
);
4257 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4258 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4259 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4261 /* Set up the free list. */
4262 for (i
= 0; i
< sz
- 1; ++i
)
4263 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4264 h
->next_free
= make_number (0);
4266 XSET_HASH_TABLE (table
, h
);
4267 xassert (HASH_TABLE_P (table
));
4268 xassert (XHASH_TABLE (table
) == h
);
4270 /* Maybe add this hash table to the list of all weak hash tables. */
4272 h
->next_weak
= Qnil
;
4275 h
->next_weak
= Vweak_hash_tables
;
4276 Vweak_hash_tables
= table
;
4283 /* Return a copy of hash table H1. Keys and values are not copied,
4284 only the table itself is. */
4287 copy_hash_table (h1
)
4288 struct Lisp_Hash_Table
*h1
;
4291 struct Lisp_Hash_Table
*h2
;
4292 struct Lisp_Vector
*next
;
4294 h2
= allocate_hash_table ();
4295 next
= h2
->vec_next
;
4296 bcopy (h1
, h2
, sizeof *h2
);
4297 h2
->vec_next
= next
;
4298 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4299 h2
->hash
= Fcopy_sequence (h1
->hash
);
4300 h2
->next
= Fcopy_sequence (h1
->next
);
4301 h2
->index
= Fcopy_sequence (h1
->index
);
4302 XSET_HASH_TABLE (table
, h2
);
4304 /* Maybe add this hash table to the list of all weak hash tables. */
4305 if (!NILP (h2
->weak
))
4307 h2
->next_weak
= Vweak_hash_tables
;
4308 Vweak_hash_tables
= table
;
4315 /* Resize hash table H if it's too full. If H cannot be resized
4316 because it's already too large, throw an error. */
4319 maybe_resize_hash_table (h
)
4320 struct Lisp_Hash_Table
*h
;
4322 if (NILP (h
->next_free
))
4324 int old_size
= HASH_TABLE_SIZE (h
);
4325 int i
, new_size
, index_size
;
4327 if (INTEGERP (h
->rehash_size
))
4328 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4330 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4331 new_size
= max (old_size
+ 1, new_size
);
4332 index_size
= next_almost_prime ((int)
4334 / XFLOATINT (h
->rehash_threshold
)));
4335 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4336 error ("Hash table too large to resize");
4338 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4339 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4340 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4341 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4343 /* Update the free list. Do it so that new entries are added at
4344 the end of the free list. This makes some operations like
4346 for (i
= old_size
; i
< new_size
- 1; ++i
)
4347 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4349 if (!NILP (h
->next_free
))
4351 Lisp_Object last
, next
;
4353 last
= h
->next_free
;
4354 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4358 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4361 XSETFASTINT (h
->next_free
, old_size
);
4364 for (i
= 0; i
< old_size
; ++i
)
4365 if (!NILP (HASH_HASH (h
, i
)))
4367 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4368 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4369 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4370 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4376 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4377 the hash code of KEY. Value is the index of the entry in H
4378 matching KEY, or -1 if not found. */
4381 hash_lookup (h
, key
, hash
)
4382 struct Lisp_Hash_Table
*h
;
4387 int start_of_bucket
;
4390 hash_code
= h
->hashfn (h
, key
);
4394 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4395 idx
= HASH_INDEX (h
, start_of_bucket
);
4397 /* We need not gcpro idx since it's either an integer or nil. */
4400 int i
= XFASTINT (idx
);
4401 if (EQ (key
, HASH_KEY (h
, i
))
4403 && h
->cmpfn (h
, key
, hash_code
,
4404 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4406 idx
= HASH_NEXT (h
, i
);
4409 return NILP (idx
) ? -1 : XFASTINT (idx
);
4413 /* Put an entry into hash table H that associates KEY with VALUE.
4414 HASH is a previously computed hash code of KEY.
4415 Value is the index of the entry in H matching KEY. */
4418 hash_put (h
, key
, value
, hash
)
4419 struct Lisp_Hash_Table
*h
;
4420 Lisp_Object key
, value
;
4423 int start_of_bucket
, i
;
4425 xassert ((hash
& ~VALMASK
) == 0);
4427 /* Increment count after resizing because resizing may fail. */
4428 maybe_resize_hash_table (h
);
4429 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4431 /* Store key/value in the key_and_value vector. */
4432 i
= XFASTINT (h
->next_free
);
4433 h
->next_free
= HASH_NEXT (h
, i
);
4434 HASH_KEY (h
, i
) = key
;
4435 HASH_VALUE (h
, i
) = value
;
4437 /* Remember its hash code. */
4438 HASH_HASH (h
, i
) = make_number (hash
);
4440 /* Add new entry to its collision chain. */
4441 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4442 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4443 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4448 /* Remove the entry matching KEY from hash table H, if there is one. */
4451 hash_remove (h
, key
)
4452 struct Lisp_Hash_Table
*h
;
4456 int start_of_bucket
;
4457 Lisp_Object idx
, prev
;
4459 hash_code
= h
->hashfn (h
, key
);
4460 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4461 idx
= HASH_INDEX (h
, start_of_bucket
);
4464 /* We need not gcpro idx, prev since they're either integers or nil. */
4467 int i
= XFASTINT (idx
);
4469 if (EQ (key
, HASH_KEY (h
, i
))
4471 && h
->cmpfn (h
, key
, hash_code
,
4472 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4474 /* Take entry out of collision chain. */
4476 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4478 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4480 /* Clear slots in key_and_value and add the slots to
4482 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4483 HASH_NEXT (h
, i
) = h
->next_free
;
4484 h
->next_free
= make_number (i
);
4485 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4486 xassert (XINT (h
->count
) >= 0);
4492 idx
= HASH_NEXT (h
, i
);
4498 /* Clear hash table H. */
4502 struct Lisp_Hash_Table
*h
;
4504 if (XFASTINT (h
->count
) > 0)
4506 int i
, size
= HASH_TABLE_SIZE (h
);
4508 for (i
= 0; i
< size
; ++i
)
4510 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4511 HASH_KEY (h
, i
) = Qnil
;
4512 HASH_VALUE (h
, i
) = Qnil
;
4513 HASH_HASH (h
, i
) = Qnil
;
4516 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4517 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4519 h
->next_free
= make_number (0);
4520 h
->count
= make_number (0);
4526 /************************************************************************
4528 ************************************************************************/
4530 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4531 entries from the table that don't survive the current GC.
4532 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4533 non-zero if anything was marked. */
4536 sweep_weak_table (h
, remove_entries_p
)
4537 struct Lisp_Hash_Table
*h
;
4538 int remove_entries_p
;
4540 int bucket
, n
, marked
;
4542 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4545 for (bucket
= 0; bucket
< n
; ++bucket
)
4547 Lisp_Object idx
, next
, prev
;
4549 /* Follow collision chain, removing entries that
4550 don't survive this garbage collection. */
4552 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4554 int i
= XFASTINT (idx
);
4555 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4556 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4559 if (EQ (h
->weak
, Qkey
))
4560 remove_p
= !key_known_to_survive_p
;
4561 else if (EQ (h
->weak
, Qvalue
))
4562 remove_p
= !value_known_to_survive_p
;
4563 else if (EQ (h
->weak
, Qkey_or_value
))
4564 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4565 else if (EQ (h
->weak
, Qkey_and_value
))
4566 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4570 next
= HASH_NEXT (h
, i
);
4572 if (remove_entries_p
)
4576 /* Take out of collision chain. */
4578 HASH_INDEX (h
, bucket
) = next
;
4580 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4582 /* Add to free list. */
4583 HASH_NEXT (h
, i
) = h
->next_free
;
4586 /* Clear key, value, and hash. */
4587 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4588 HASH_HASH (h
, i
) = Qnil
;
4590 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4597 /* Make sure key and value survive. */
4598 if (!key_known_to_survive_p
)
4600 mark_object (&HASH_KEY (h
, i
));
4604 if (!value_known_to_survive_p
)
4606 mark_object (&HASH_VALUE (h
, i
));
4617 /* Remove elements from weak hash tables that don't survive the
4618 current garbage collection. Remove weak tables that don't survive
4619 from Vweak_hash_tables. Called from gc_sweep. */
4622 sweep_weak_hash_tables ()
4624 Lisp_Object table
, used
, next
;
4625 struct Lisp_Hash_Table
*h
;
4628 /* Mark all keys and values that are in use. Keep on marking until
4629 there is no more change. This is necessary for cases like
4630 value-weak table A containing an entry X -> Y, where Y is used in a
4631 key-weak table B, Z -> Y. If B comes after A in the list of weak
4632 tables, X -> Y might be removed from A, although when looking at B
4633 one finds that it shouldn't. */
4637 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4639 h
= XHASH_TABLE (table
);
4640 if (h
->size
& ARRAY_MARK_FLAG
)
4641 marked
|= sweep_weak_table (h
, 0);
4646 /* Remove tables and entries that aren't used. */
4647 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4649 h
= XHASH_TABLE (table
);
4650 next
= h
->next_weak
;
4652 if (h
->size
& ARRAY_MARK_FLAG
)
4654 /* TABLE is marked as used. Sweep its contents. */
4655 if (XFASTINT (h
->count
) > 0)
4656 sweep_weak_table (h
, 1);
4658 /* Add table to the list of used weak hash tables. */
4659 h
->next_weak
= used
;
4664 Vweak_hash_tables
= used
;
4669 /***********************************************************************
4670 Hash Code Computation
4671 ***********************************************************************/
4673 /* Maximum depth up to which to dive into Lisp structures. */
4675 #define SXHASH_MAX_DEPTH 3
4677 /* Maximum length up to which to take list and vector elements into
4680 #define SXHASH_MAX_LEN 7
4682 /* Combine two integers X and Y for hashing. */
4684 #define SXHASH_COMBINE(X, Y) \
4685 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4689 /* Return a hash for string PTR which has length LEN. The hash
4690 code returned is guaranteed to fit in a Lisp integer. */
4693 sxhash_string (ptr
, len
)
4697 unsigned char *p
= ptr
;
4698 unsigned char *end
= p
+ len
;
4707 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4710 return hash
& VALMASK
;
4714 /* Return a hash for list LIST. DEPTH is the current depth in the
4715 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4718 sxhash_list (list
, depth
)
4725 if (depth
< SXHASH_MAX_DEPTH
)
4727 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4728 list
= XCDR (list
), ++i
)
4730 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4731 hash
= SXHASH_COMBINE (hash
, hash2
);
4738 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4739 the Lisp structure. */
4742 sxhash_vector (vec
, depth
)
4746 unsigned hash
= XVECTOR (vec
)->size
;
4749 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4750 for (i
= 0; i
< n
; ++i
)
4752 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4753 hash
= SXHASH_COMBINE (hash
, hash2
);
4760 /* Return a hash for bool-vector VECTOR. */
4763 sxhash_bool_vector (vec
)
4766 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4769 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4770 for (i
= 0; i
< n
; ++i
)
4771 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4777 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4778 structure. Value is an unsigned integer clipped to VALMASK. */
4787 if (depth
> SXHASH_MAX_DEPTH
)
4790 switch (XTYPE (obj
))
4797 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4798 XSYMBOL (obj
)->name
->size
);
4806 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4809 /* This can be everything from a vector to an overlay. */
4810 case Lisp_Vectorlike
:
4812 /* According to the CL HyperSpec, two arrays are equal only if
4813 they are `eq', except for strings and bit-vectors. In
4814 Emacs, this works differently. We have to compare element
4816 hash
= sxhash_vector (obj
, depth
);
4817 else if (BOOL_VECTOR_P (obj
))
4818 hash
= sxhash_bool_vector (obj
);
4820 /* Others are `equal' if they are `eq', so let's take their
4826 hash
= sxhash_list (obj
, depth
);
4831 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4832 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4833 for (hash
= 0; p
< e
; ++p
)
4834 hash
= SXHASH_COMBINE (hash
, *p
);
4842 return hash
& VALMASK
;
4847 /***********************************************************************
4849 ***********************************************************************/
4852 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4853 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4857 unsigned hash
= sxhash (obj
, 0);;
4858 return make_number (hash
);
4862 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4863 doc
: /* Create and return a new hash table.
4865 Arguments are specified as keyword/argument pairs. The following
4866 arguments are defined:
4868 :test TEST -- TEST must be a symbol that specifies how to compare
4869 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4870 `equal'. User-supplied test and hash functions can be specified via
4871 `define-hash-table-test'.
4873 :size SIZE -- A hint as to how many elements will be put in the table.
4876 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4877 fills up. If REHASH-SIZE is an integer, add that many space. If it
4878 is a float, it must be > 1.0, and the new size is computed by
4879 multiplying the old size with that factor. Default is 1.5.
4881 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4882 Resize the hash table when ratio of the number of entries in the
4883 table. Default is 0.8.
4885 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4886 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4887 returned is a weak table. Key/value pairs are removed from a weak
4888 hash table when there are no non-weak references pointing to their
4889 key, value, one of key or value, or both key and value, depending on
4890 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4893 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4898 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4899 Lisp_Object user_test
, user_hash
;
4903 /* The vector `used' is used to keep track of arguments that
4904 have been consumed. */
4905 used
= (char *) alloca (nargs
* sizeof *used
);
4906 bzero (used
, nargs
* sizeof *used
);
4908 /* See if there's a `:test TEST' among the arguments. */
4909 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4910 test
= i
< 0 ? Qeql
: args
[i
];
4911 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4913 /* See if it is a user-defined test. */
4916 prop
= Fget (test
, Qhash_table_test
);
4917 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4918 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4920 user_test
= XCAR (prop
);
4921 user_hash
= XCAR (XCDR (prop
));
4924 user_test
= user_hash
= Qnil
;
4926 /* See if there's a `:size SIZE' argument. */
4927 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4928 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4929 if (!INTEGERP (size
) || XINT (size
) < 0)
4931 list2 (build_string ("Invalid hash table size"),
4934 /* Look for `:rehash-size SIZE'. */
4935 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4936 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4937 if (!NUMBERP (rehash_size
)
4938 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4939 || XFLOATINT (rehash_size
) <= 1.0)
4941 list2 (build_string ("Invalid hash table rehash size"),
4944 /* Look for `:rehash-threshold THRESHOLD'. */
4945 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4946 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4947 if (!FLOATP (rehash_threshold
)
4948 || XFLOATINT (rehash_threshold
) <= 0.0
4949 || XFLOATINT (rehash_threshold
) > 1.0)
4951 list2 (build_string ("Invalid hash table rehash threshold"),
4954 /* Look for `:weakness WEAK'. */
4955 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4956 weak
= i
< 0 ? Qnil
: args
[i
];
4958 weak
= Qkey_and_value
;
4961 && !EQ (weak
, Qvalue
)
4962 && !EQ (weak
, Qkey_or_value
)
4963 && !EQ (weak
, Qkey_and_value
))
4964 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4967 /* Now, all args should have been used up, or there's a problem. */
4968 for (i
= 0; i
< nargs
; ++i
)
4971 list2 (build_string ("Invalid argument list"), args
[i
]));
4973 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4974 user_test
, user_hash
);
4978 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4979 doc
: /* Return a copy of hash table TABLE. */)
4983 return copy_hash_table (check_hash_table (table
));
4987 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4988 doc
: /* Create a new hash table.
4990 Optional first argument TEST specifies how to compare keys in the
4991 table. Predefined tests are `eq', `eql', and `equal'. Default is
4992 `eql'. New tests can be defined with `define-hash-table-test'. */)
4996 Lisp_Object args
[2];
4998 args
[1] = NILP (test
) ? Qeql
: test
;
4999 return Fmake_hash_table (2, args
);
5003 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5004 doc
: /* Return the number of elements in TABLE. */)
5008 return check_hash_table (table
)->count
;
5012 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5013 Shash_table_rehash_size
, 1, 1, 0,
5014 doc
: /* Return the current rehash size of TABLE. */)
5018 return check_hash_table (table
)->rehash_size
;
5022 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5023 Shash_table_rehash_threshold
, 1, 1, 0,
5024 doc
: /* Return the current rehash threshold of TABLE. */)
5028 return check_hash_table (table
)->rehash_threshold
;
5032 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5033 doc
: /* Return the size of TABLE.
5034 The size can be used as an argument to `make-hash-table' to create
5035 a hash table than can hold as many elements of TABLE holds
5036 without need for resizing. */)
5040 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5041 return make_number (HASH_TABLE_SIZE (h
));
5045 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5046 doc
: /* Return the test TABLE uses. */)
5050 return check_hash_table (table
)->test
;
5054 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5056 doc
: /* Return the weakness of TABLE. */)
5060 return check_hash_table (table
)->weak
;
5064 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5065 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5069 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5073 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5074 doc
: /* Clear hash table TABLE. */)
5078 hash_clear (check_hash_table (table
));
5083 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5084 doc
: /* Look up KEY in TABLE and return its associated value.
5085 If KEY is not found, return DFLT which defaults to nil. */)
5087 Lisp_Object key
, table
, dflt
;
5089 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5090 int i
= hash_lookup (h
, key
, NULL
);
5091 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5095 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5096 doc
: /* Associate KEY with VALUE in hash table TABLE.
5097 If KEY is already present in table, replace its current value with
5100 Lisp_Object key
, value
, table
;
5102 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5106 i
= hash_lookup (h
, key
, &hash
);
5108 HASH_VALUE (h
, i
) = value
;
5110 hash_put (h
, key
, value
, hash
);
5116 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5117 doc
: /* Remove KEY from TABLE. */)
5119 Lisp_Object key
, table
;
5121 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5122 hash_remove (h
, key
);
5127 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5128 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5129 FUNCTION is called with 2 arguments KEY and VALUE. */)
5131 Lisp_Object function
, table
;
5133 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5134 Lisp_Object args
[3];
5137 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5138 if (!NILP (HASH_HASH (h
, i
)))
5141 args
[1] = HASH_KEY (h
, i
);
5142 args
[2] = HASH_VALUE (h
, i
);
5150 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5151 Sdefine_hash_table_test
, 3, 3, 0,
5152 doc
: /* Define a new hash table test with name NAME, a symbol.
5154 In hash tables created with NAME specified as test, use TEST to
5155 compare keys, and HASH for computing hash codes of keys.
5157 TEST must be a function taking two arguments and returning non-nil if
5158 both arguments are the same. HASH must be a function taking one
5159 argument and return an integer that is the hash code of the argument.
5160 Hash code computation should use the whole value range of integers,
5161 including negative integers. */)
5163 Lisp_Object name
, test
, hash
;
5165 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5170 /************************************************************************
5172 ************************************************************************/
5177 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5178 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5180 A message digest is a cryptographic checksum of a document, and the
5181 algorithm to calculate it is defined in RFC 1321.
5183 The two optional arguments START and END are character positions
5184 specifying for which part of OBJECT the message digest should be
5185 computed. If nil or omitted, the digest is computed for the whole
5188 The MD5 message digest is computed from the result of encoding the
5189 text in a coding system, not directly from the internal Emacs form of
5190 the text. The optional fourth argument CODING-SYSTEM specifies which
5191 coding system to encode the text with. It should be the same coding
5192 system that you used or will use when actually writing the text into a
5195 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5196 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5197 system would be chosen by default for writing this text into a file.
5199 If OBJECT is a string, the most preferred coding system (see the
5200 command `prefer-coding-system') is used.
5202 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5203 guesswork fails. Normally, an error is signaled in such case. */)
5204 (object
, start
, end
, coding_system
, noerror
)
5205 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5207 unsigned char digest
[16];
5208 unsigned char value
[33];
5212 int start_char
= 0, end_char
= 0;
5213 int start_byte
= 0, end_byte
= 0;
5215 register struct buffer
*bp
;
5218 if (STRINGP (object
))
5220 if (NILP (coding_system
))
5222 /* Decide the coding-system to encode the data with. */
5224 if (STRING_MULTIBYTE (object
))
5225 /* use default, we can't guess correct value */
5226 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5228 coding_system
= Qraw_text
;
5231 if (NILP (Fcoding_system_p (coding_system
)))
5233 /* Invalid coding system. */
5235 if (!NILP (noerror
))
5236 coding_system
= Qraw_text
;
5239 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5242 if (STRING_MULTIBYTE (object
))
5243 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5245 size
= XSTRING (object
)->size
;
5246 size_byte
= STRING_BYTES (XSTRING (object
));
5250 CHECK_NUMBER (start
);
5252 start_char
= XINT (start
);
5257 start_byte
= string_char_to_byte (object
, start_char
);
5263 end_byte
= size_byte
;
5269 end_char
= XINT (end
);
5274 end_byte
= string_char_to_byte (object
, end_char
);
5277 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5278 args_out_of_range_3 (object
, make_number (start_char
),
5279 make_number (end_char
));
5283 CHECK_BUFFER (object
);
5285 bp
= XBUFFER (object
);
5291 CHECK_NUMBER_COERCE_MARKER (start
);
5299 CHECK_NUMBER_COERCE_MARKER (end
);
5304 temp
= b
, b
= e
, e
= temp
;
5306 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5307 args_out_of_range (start
, end
);
5309 if (NILP (coding_system
))
5311 /* Decide the coding-system to encode the data with.
5312 See fileio.c:Fwrite-region */
5314 if (!NILP (Vcoding_system_for_write
))
5315 coding_system
= Vcoding_system_for_write
;
5318 int force_raw_text
= 0;
5320 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5321 if (NILP (coding_system
)
5322 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5324 coding_system
= Qnil
;
5325 if (NILP (current_buffer
->enable_multibyte_characters
))
5329 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5331 /* Check file-coding-system-alist. */
5332 Lisp_Object args
[4], val
;
5334 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5335 args
[3] = Fbuffer_file_name(object
);
5336 val
= Ffind_operation_coding_system (4, args
);
5337 if (CONSP (val
) && !NILP (XCDR (val
)))
5338 coding_system
= XCDR (val
);
5341 if (NILP (coding_system
)
5342 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5344 /* If we still have not decided a coding system, use the
5345 default value of buffer-file-coding-system. */
5346 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5350 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5351 /* Confirm that VAL can surely encode the current region. */
5352 coding_system
= call3 (Vselect_safe_coding_system_function
,
5353 make_number (b
), make_number (e
),
5357 coding_system
= Qraw_text
;
5360 if (NILP (Fcoding_system_p (coding_system
)))
5362 /* Invalid coding system. */
5364 if (!NILP (noerror
))
5365 coding_system
= Qraw_text
;
5368 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5372 object
= make_buffer_string (b
, e
, 0);
5374 if (STRING_MULTIBYTE (object
))
5375 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5378 md5_buffer (XSTRING (object
)->data
+ start_byte
,
5379 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
5382 for (i
= 0; i
< 16; i
++)
5383 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5386 return make_string (value
, 32);
5393 /* Hash table stuff. */
5394 Qhash_table_p
= intern ("hash-table-p");
5395 staticpro (&Qhash_table_p
);
5396 Qeq
= intern ("eq");
5398 Qeql
= intern ("eql");
5400 Qequal
= intern ("equal");
5401 staticpro (&Qequal
);
5402 QCtest
= intern (":test");
5403 staticpro (&QCtest
);
5404 QCsize
= intern (":size");
5405 staticpro (&QCsize
);
5406 QCrehash_size
= intern (":rehash-size");
5407 staticpro (&QCrehash_size
);
5408 QCrehash_threshold
= intern (":rehash-threshold");
5409 staticpro (&QCrehash_threshold
);
5410 QCweakness
= intern (":weakness");
5411 staticpro (&QCweakness
);
5412 Qkey
= intern ("key");
5414 Qvalue
= intern ("value");
5415 staticpro (&Qvalue
);
5416 Qhash_table_test
= intern ("hash-table-test");
5417 staticpro (&Qhash_table_test
);
5418 Qkey_or_value
= intern ("key-or-value");
5419 staticpro (&Qkey_or_value
);
5420 Qkey_and_value
= intern ("key-and-value");
5421 staticpro (&Qkey_and_value
);
5424 defsubr (&Smake_hash_table
);
5425 defsubr (&Scopy_hash_table
);
5426 defsubr (&Smakehash
);
5427 defsubr (&Shash_table_count
);
5428 defsubr (&Shash_table_rehash_size
);
5429 defsubr (&Shash_table_rehash_threshold
);
5430 defsubr (&Shash_table_size
);
5431 defsubr (&Shash_table_test
);
5432 defsubr (&Shash_table_weakness
);
5433 defsubr (&Shash_table_p
);
5434 defsubr (&Sclrhash
);
5435 defsubr (&Sgethash
);
5436 defsubr (&Sputhash
);
5437 defsubr (&Sremhash
);
5438 defsubr (&Smaphash
);
5439 defsubr (&Sdefine_hash_table_test
);
5441 Qstring_lessp
= intern ("string-lessp");
5442 staticpro (&Qstring_lessp
);
5443 Qprovide
= intern ("provide");
5444 staticpro (&Qprovide
);
5445 Qrequire
= intern ("require");
5446 staticpro (&Qrequire
);
5447 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5448 staticpro (&Qyes_or_no_p_history
);
5449 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5450 staticpro (&Qcursor_in_echo_area
);
5451 Qwidget_type
= intern ("widget-type");
5452 staticpro (&Qwidget_type
);
5454 staticpro (&string_char_byte_cache_string
);
5455 string_char_byte_cache_string
= Qnil
;
5457 require_nesting_list
= Qnil
;
5458 staticpro (&require_nesting_list
);
5460 Fset (Qyes_or_no_p_history
, Qnil
);
5462 DEFVAR_LISP ("features", &Vfeatures
,
5463 doc
: /* A list of symbols which are the features of the executing emacs.
5464 Used by `featurep' and `require', and altered by `provide'. */);
5466 Qsubfeatures
= intern ("subfeatures");
5467 staticpro (&Qsubfeatures
);
5469 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5470 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5471 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5472 invoked by mouse clicks and mouse menu items. */);
5475 defsubr (&Sidentity
);
5478 defsubr (&Ssafe_length
);
5479 defsubr (&Sstring_bytes
);
5480 defsubr (&Sstring_equal
);
5481 defsubr (&Scompare_strings
);
5482 defsubr (&Sstring_lessp
);
5485 defsubr (&Svconcat
);
5486 defsubr (&Scopy_sequence
);
5487 defsubr (&Sstring_make_multibyte
);
5488 defsubr (&Sstring_make_unibyte
);
5489 defsubr (&Sstring_as_multibyte
);
5490 defsubr (&Sstring_as_unibyte
);
5491 defsubr (&Scopy_alist
);
5492 defsubr (&Ssubstring
);
5493 defsubr (&Ssubstring_no_properties
);
5505 defsubr (&Snreverse
);
5506 defsubr (&Sreverse
);
5508 defsubr (&Splist_get
);
5510 defsubr (&Splist_put
);
5512 defsubr (&Slax_plist_get
);
5513 defsubr (&Slax_plist_put
);
5515 defsubr (&Sfillarray
);
5516 defsubr (&Schar_table_subtype
);
5517 defsubr (&Schar_table_parent
);
5518 defsubr (&Sset_char_table_parent
);
5519 defsubr (&Schar_table_extra_slot
);
5520 defsubr (&Sset_char_table_extra_slot
);
5521 defsubr (&Schar_table_range
);
5522 defsubr (&Sset_char_table_range
);
5523 defsubr (&Sset_char_table_default
);
5524 defsubr (&Soptimize_char_table
);
5525 defsubr (&Smap_char_table
);
5529 defsubr (&Smapconcat
);
5530 defsubr (&Sy_or_n_p
);
5531 defsubr (&Syes_or_no_p
);
5532 defsubr (&Sload_average
);
5533 defsubr (&Sfeaturep
);
5534 defsubr (&Srequire
);
5535 defsubr (&Sprovide
);
5536 defsubr (&Splist_member
);
5537 defsubr (&Swidget_put
);
5538 defsubr (&Swidget_get
);
5539 defsubr (&Swidget_apply
);
5540 defsubr (&Sbase64_encode_region
);
5541 defsubr (&Sbase64_decode_region
);
5542 defsubr (&Sbase64_encode_string
);
5543 defsubr (&Sbase64_decode_string
);
5551 Vweak_hash_tables
= Qnil
;