1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 01, 02
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. */
36 #include "character.h"
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
;
59 extern Lisp_Object Vlocale_coding_system
;
61 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
62 Lisp_Object Qyes_or_no_p_history
;
63 Lisp_Object Qcursor_in_echo_area
;
64 Lisp_Object Qwidget_type
;
65 Lisp_Object Qcodeset
, Qdays
, Qmonths
;
67 extern Lisp_Object Qinput_method_function
;
69 static int internal_equal ();
71 extern long get_random ();
72 extern void seed_random ();
78 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
79 doc
: /* Return the argument unchanged. */)
86 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
87 doc
: /* Return a pseudo-random number.
88 All integers representable in Lisp are equally likely.
89 On most systems, this is 28 bits' worth.
90 With positive integer argument N, return random number in interval [0,N).
91 With argument t, set the random number seed from the current time and pid. */)
96 Lisp_Object lispy_val
;
97 unsigned long denominator
;
100 seed_random (getpid () + time (NULL
));
101 if (NATNUMP (n
) && XFASTINT (n
) != 0)
103 /* Try to take our random number from the higher bits of VAL,
104 not the lower, since (says Gentzel) the low bits of `random'
105 are less random than the higher ones. We do this by using the
106 quotient rather than the remainder. At the high end of the RNG
107 it's possible to get a quotient larger than n; discarding
108 these values eliminates the bias that would otherwise appear
109 when using a large n. */
110 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
112 val
= get_random () / denominator
;
113 while (val
>= XFASTINT (n
));
117 XSETINT (lispy_val
, val
);
121 /* Random data-structure functions */
123 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
124 doc
: /* Return the length of vector, list or string SEQUENCE.
125 A byte-code function object is also allowed.
126 If the string contains multibyte characters, this is not the necessarily
127 the number of bytes in the string; it is the number of characters.
128 To get the number of bytes, use `string-bytes'. */)
130 register Lisp_Object sequence
;
132 register Lisp_Object val
;
136 if (STRINGP (sequence
))
137 XSETFASTINT (val
, XSTRING (sequence
)->size
);
138 else if (VECTORP (sequence
))
139 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
140 else if (CHAR_TABLE_P (sequence
))
141 XSETFASTINT (val
, MAX_CHAR
);
142 else if (BOOL_VECTOR_P (sequence
))
143 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
144 else if (COMPILEDP (sequence
))
145 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
146 else if (CONSP (sequence
))
149 while (CONSP (sequence
))
151 sequence
= XCDR (sequence
);
154 if (!CONSP (sequence
))
157 sequence
= XCDR (sequence
);
162 if (!NILP (sequence
))
163 wrong_type_argument (Qlistp
, sequence
);
165 val
= make_number (i
);
167 else if (NILP (sequence
))
168 XSETFASTINT (val
, 0);
171 sequence
= wrong_type_argument (Qsequencep
, sequence
);
177 /* This does not check for quits. That is safe
178 since it must terminate. */
180 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
181 doc
: /* Return the length of a list, but avoid error or infinite loop.
182 This function never gets an error. If LIST is not really a list,
183 it returns 0. If LIST is circular, it returns a finite value
184 which is at least the number of distinct elements. */)
188 Lisp_Object tail
, halftail
, length
;
191 /* halftail is used to detect circular lists. */
193 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
195 if (EQ (tail
, halftail
) && len
!= 0)
199 halftail
= XCDR (halftail
);
202 XSETINT (length
, len
);
206 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
207 doc
: /* Return the number of bytes in STRING.
208 If STRING is a multibyte string, this is greater than the length of STRING. */)
212 CHECK_STRING (string
);
213 return make_number (STRING_BYTES (XSTRING (string
)));
216 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
217 doc
: /* Return t if two strings have identical contents.
218 Case is significant, but text properties are ignored.
219 Symbols are also allowed; their print names are used instead. */)
221 register Lisp_Object s1
, s2
;
224 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
226 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
230 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
231 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
232 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
237 DEFUN ("compare-strings", Fcompare_strings
,
238 Scompare_strings
, 6, 7, 0,
239 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
240 In string STR1, skip the first START1 characters and stop at END1.
241 In string STR2, skip the first START2 characters and stop at END2.
242 END1 and END2 default to the full lengths of the respective strings.
244 Case is significant in this comparison if IGNORE-CASE is nil.
245 Unibyte strings are converted to multibyte for comparison.
247 The value is t if the strings (or specified portions) match.
248 If string STR1 is less, the value is a negative number N;
249 - 1 - N is the number of characters that match at the beginning.
250 If string STR1 is greater, the value is a positive number N;
251 N - 1 is the number of characters that match at the beginning. */)
252 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
253 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
255 register int end1_char
, end2_char
;
256 register int i1
, i1_byte
, i2
, i2_byte
;
261 start1
= make_number (0);
263 start2
= make_number (0);
264 CHECK_NATNUM (start1
);
265 CHECK_NATNUM (start2
);
274 i1_byte
= string_char_to_byte (str1
, i1
);
275 i2_byte
= string_char_to_byte (str2
, i2
);
277 end1_char
= XSTRING (str1
)->size
;
278 if (! NILP (end1
) && end1_char
> XINT (end1
))
279 end1_char
= XINT (end1
);
281 end2_char
= XSTRING (str2
)->size
;
282 if (! NILP (end2
) && end2_char
> XINT (end2
))
283 end2_char
= XINT (end2
);
285 while (i1
< end1_char
&& i2
< end2_char
)
287 /* When we find a mismatch, we must compare the
288 characters, not just the bytes. */
291 if (STRING_MULTIBYTE (str1
))
292 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
295 c1
= XSTRING (str1
)->data
[i1
++];
296 c1
= unibyte_char_to_multibyte (c1
);
299 if (STRING_MULTIBYTE (str2
))
300 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
303 c2
= XSTRING (str2
)->data
[i2
++];
304 c2
= unibyte_char_to_multibyte (c2
);
310 if (! NILP (ignore_case
))
314 tem
= Fupcase (make_number (c1
));
316 tem
= Fupcase (make_number (c2
));
323 /* Note that I1 has already been incremented
324 past the character that we are comparing;
325 hence we don't add or subtract 1 here. */
327 return make_number (- i1
+ XINT (start1
));
329 return make_number (i1
- XINT (start1
));
333 return make_number (i1
- XINT (start1
) + 1);
335 return make_number (- i1
+ XINT (start1
) - 1);
340 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
341 doc
: /* Return t if first arg string is less than second in lexicographic order.
343 Symbols are also allowed; their print names are used instead. */)
345 register Lisp_Object s1
, s2
;
348 register int i1
, i1_byte
, i2
, i2_byte
;
351 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
353 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
357 i1
= i1_byte
= i2
= i2_byte
= 0;
359 end
= XSTRING (s1
)->size
;
360 if (end
> XSTRING (s2
)->size
)
361 end
= XSTRING (s2
)->size
;
365 /* When we find a mismatch, we must compare the
366 characters, not just the bytes. */
369 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
370 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
373 return c1
< c2
? Qt
: Qnil
;
375 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
378 static Lisp_Object
concat ();
389 return concat (2, args
, Lisp_String
, 0);
391 return concat (2, &s1
, Lisp_String
, 0);
392 #endif /* NO_ARG_ARRAY */
398 Lisp_Object s1
, s2
, s3
;
405 return concat (3, args
, Lisp_String
, 0);
407 return concat (3, &s1
, Lisp_String
, 0);
408 #endif /* NO_ARG_ARRAY */
411 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
412 doc
: /* Concatenate all the arguments and make the result a list.
413 The result is a list whose elements are the elements of all the arguments.
414 Each argument may be a list, vector or string.
415 The last argument is not copied, just used as the tail of the new list.
416 usage: (append &rest SEQUENCES) */)
421 return concat (nargs
, args
, Lisp_Cons
, 1);
424 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
425 doc
: /* Concatenate all the arguments and make the result a string.
426 The result is a string whose elements are the elements of all the arguments.
427 Each argument may be a string or a list or vector of characters (integers).
428 usage: (concat &rest SEQUENCES) */)
433 return concat (nargs
, args
, Lisp_String
, 0);
436 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
437 doc
: /* Concatenate all the arguments and make the result a vector.
438 The result is a vector whose elements are the elements of all the arguments.
439 Each argument may be a list, vector or string.
440 usage: (vconcat &rest SEQUENCES) */)
445 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
449 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
450 doc
: /* Return a copy of a list, vector or string.
451 The elements of a list or vector are not copied; they are shared
452 with the original. */)
456 if (NILP (arg
)) return arg
;
458 if (CHAR_TABLE_P (arg
))
460 return copy_char_table (arg
);
462 if (BOOL_VECTOR_P (arg
))
466 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
468 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
469 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
474 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
475 arg
= wrong_type_argument (Qsequencep
, arg
);
476 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
480 /* In string STR of length LEN, see if bytes before STR[I] combine
481 with bytes after STR[I] to form a single character. If so, return
482 the number of bytes after STR[I] which combine in this way.
483 Otherwize, return 0. */
486 count_combining (str
, len
, i
)
490 int j
= i
- 1, bytes
;
492 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
494 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
495 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
497 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
498 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
502 /* This structure holds information of an argument of `concat' that is
503 a string and has text properties to be copied. */
506 int argnum
; /* refer to ARGS (arguments of `concat') */
507 int from
; /* refer to ARGS[argnum] (argument string) */
508 int to
; /* refer to VAL (the target string) */
512 concat (nargs
, args
, target_type
, last_special
)
515 enum Lisp_Type target_type
;
519 register Lisp_Object tail
;
520 register Lisp_Object
this;
522 int toindex_byte
= 0;
523 register int result_len
;
524 register int result_len_byte
;
526 Lisp_Object last_tail
;
529 /* When we make a multibyte string, we can't copy text properties
530 while concatinating each string because the length of resulting
531 string can't be decided until we finish the whole concatination.
532 So, we record strings that have text properties to be copied
533 here, and copy the text properties after the concatination. */
534 struct textprop_rec
*textprops
= NULL
;
535 /* Number of elments in textprops. */
536 int num_textprops
= 0;
540 /* In append, the last arg isn't treated like the others */
541 if (last_special
&& nargs
> 0)
544 last_tail
= args
[nargs
];
549 /* Canonicalize each argument. */
550 for (argnum
= 0; argnum
< nargs
; argnum
++)
553 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
554 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
556 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
560 /* Compute total length in chars of arguments in RESULT_LEN.
561 If desired output is a string, also compute length in bytes
562 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
563 whether the result should be a multibyte string. */
567 for (argnum
= 0; argnum
< nargs
; argnum
++)
571 len
= XFASTINT (Flength (this));
572 if (target_type
== Lisp_String
)
574 /* We must count the number of bytes needed in the string
575 as well as the number of characters. */
581 for (i
= 0; i
< len
; i
++)
583 ch
= XVECTOR (this)->contents
[i
];
584 if (! CHARACTERP (ch
))
585 wrong_type_argument (Qcharacterp
, ch
);
586 this_len_byte
= CHAR_BYTES (XINT (ch
));
587 result_len_byte
+= this_len_byte
;
588 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
591 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
592 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
593 else if (CONSP (this))
594 for (; CONSP (this); this = XCDR (this))
597 if (! CHARACTERP (ch
))
598 wrong_type_argument (Qcharacterp
, ch
);
599 this_len_byte
= CHAR_BYTES (XINT (ch
));
600 result_len_byte
+= this_len_byte
;
601 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
604 else if (STRINGP (this))
606 if (STRING_MULTIBYTE (this))
609 result_len_byte
+= STRING_BYTES (XSTRING (this));
612 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
613 XSTRING (this)->size
);
620 if (! some_multibyte
)
621 result_len_byte
= result_len
;
623 /* Create the output object. */
624 if (target_type
== Lisp_Cons
)
625 val
= Fmake_list (make_number (result_len
), Qnil
);
626 else if (target_type
== Lisp_Vectorlike
)
627 val
= Fmake_vector (make_number (result_len
), Qnil
);
628 else if (some_multibyte
)
629 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
631 val
= make_uninit_string (result_len
);
633 /* In `append', if all but last arg are nil, return last arg. */
634 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
637 /* Copy the contents of the args into the result. */
639 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
641 toindex
= 0, toindex_byte
= 0;
646 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
648 for (argnum
= 0; argnum
< nargs
; argnum
++)
652 register unsigned int thisindex
= 0;
653 register unsigned int thisindex_byte
= 0;
657 thislen
= Flength (this), thisleni
= XINT (thislen
);
659 /* Between strings of the same kind, copy fast. */
660 if (STRINGP (this) && STRINGP (val
)
661 && STRING_MULTIBYTE (this) == some_multibyte
)
663 int thislen_byte
= STRING_BYTES (XSTRING (this));
665 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
666 STRING_BYTES (XSTRING (this)));
667 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
669 textprops
[num_textprops
].argnum
= argnum
;
670 textprops
[num_textprops
].from
= 0;
671 textprops
[num_textprops
++].to
= toindex
;
673 toindex_byte
+= thislen_byte
;
676 /* Copy a single-byte string to a multibyte string. */
677 else if (STRINGP (this) && STRINGP (val
))
679 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
681 textprops
[num_textprops
].argnum
= argnum
;
682 textprops
[num_textprops
].from
= 0;
683 textprops
[num_textprops
++].to
= toindex
;
685 toindex_byte
+= copy_text (XSTRING (this)->data
,
686 XSTRING (val
)->data
+ toindex_byte
,
687 XSTRING (this)->size
, 0, 1);
691 /* Copy element by element. */
694 register Lisp_Object elt
;
696 /* Fetch next element of `this' arg into `elt', or break if
697 `this' is exhausted. */
698 if (NILP (this)) break;
700 elt
= XCAR (this), this = XCDR (this);
701 else if (thisindex
>= thisleni
)
703 else if (STRINGP (this))
706 if (STRING_MULTIBYTE (this))
708 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
711 XSETFASTINT (elt
, c
);
715 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
717 && XINT (elt
) >= 0200
718 && XINT (elt
) < 0400)
720 c
= unibyte_char_to_multibyte (XINT (elt
));
725 else if (BOOL_VECTOR_P (this))
728 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
729 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
736 elt
= XVECTOR (this)->contents
[thisindex
++];
738 /* Store this element into the result. */
745 else if (VECTORP (val
))
746 XVECTOR (val
)->contents
[toindex
++] = elt
;
752 += CHAR_STRING (XINT (elt
),
753 XSTRING (val
)->data
+ toindex_byte
);
755 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
761 XSETCDR (prev
, last_tail
);
763 if (num_textprops
> 0)
766 int last_to_end
= -1;
768 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
770 this = args
[textprops
[argnum
].argnum
];
771 props
= text_property_list (this,
773 make_number (XSTRING (this)->size
),
775 /* If successive arguments have properites, be sure that the
776 value of `composition' property be the copy. */
777 if (last_to_end
== textprops
[argnum
].to
)
778 make_composition_value_copy (props
);
779 add_text_properties_from_list (val
, props
,
780 make_number (textprops
[argnum
].to
));
781 last_to_end
= textprops
[argnum
].to
+ XSTRING (this)->size
;
787 static Lisp_Object string_char_byte_cache_string
;
788 static int string_char_byte_cache_charpos
;
789 static int string_char_byte_cache_bytepos
;
792 clear_string_char_byte_cache ()
794 string_char_byte_cache_string
= Qnil
;
797 /* Return the character index corresponding to CHAR_INDEX in STRING. */
800 string_char_to_byte (string
, char_index
)
805 int best_below
, best_below_byte
;
806 int best_above
, best_above_byte
;
808 if (! STRING_MULTIBYTE (string
))
811 best_below
= best_below_byte
= 0;
812 best_above
= XSTRING (string
)->size
;
813 best_above_byte
= STRING_BYTES (XSTRING (string
));
815 if (EQ (string
, string_char_byte_cache_string
))
817 if (string_char_byte_cache_charpos
< char_index
)
819 best_below
= string_char_byte_cache_charpos
;
820 best_below_byte
= string_char_byte_cache_bytepos
;
824 best_above
= string_char_byte_cache_charpos
;
825 best_above_byte
= string_char_byte_cache_bytepos
;
829 if (char_index
- best_below
< best_above
- char_index
)
831 unsigned char *p
= XSTRING (string
)->data
+ best_below_byte
;
833 while (best_below
< char_index
)
835 p
+= BYTES_BY_CHAR_HEAD (*p
);
838 i_byte
= p
- XSTRING (string
)->data
;
842 unsigned char *p
= XSTRING (string
)->data
+ best_above_byte
;
844 while (best_above
> char_index
)
847 while (!CHAR_HEAD_P (*p
)) p
--;
850 i_byte
= p
- XSTRING (string
)->data
;
853 string_char_byte_cache_bytepos
= i_byte
;
854 string_char_byte_cache_charpos
= char_index
;
855 string_char_byte_cache_string
= string
;
860 /* Return the character index corresponding to BYTE_INDEX in STRING. */
863 string_byte_to_char (string
, byte_index
)
868 int best_below
, best_below_byte
;
869 int best_above
, best_above_byte
;
871 if (! STRING_MULTIBYTE (string
))
874 best_below
= best_below_byte
= 0;
875 best_above
= XSTRING (string
)->size
;
876 best_above_byte
= STRING_BYTES (XSTRING (string
));
878 if (EQ (string
, string_char_byte_cache_string
))
880 if (string_char_byte_cache_bytepos
< byte_index
)
882 best_below
= string_char_byte_cache_charpos
;
883 best_below_byte
= string_char_byte_cache_bytepos
;
887 best_above
= string_char_byte_cache_charpos
;
888 best_above_byte
= string_char_byte_cache_bytepos
;
892 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
894 unsigned char *p
= XSTRING (string
)->data
+ best_below_byte
;
895 unsigned char *pend
= XSTRING (string
)->data
+ byte_index
;
899 p
+= BYTES_BY_CHAR_HEAD (*p
);
903 i_byte
= p
- XSTRING (string
)->data
;
907 unsigned char *p
= XSTRING (string
)->data
+ best_above_byte
;
908 unsigned char *pbeg
= XSTRING (string
)->data
+ byte_index
;
913 while (!CHAR_HEAD_P (*p
)) p
--;
917 i_byte
= p
- XSTRING (string
)->data
;
920 string_char_byte_cache_bytepos
= i_byte
;
921 string_char_byte_cache_charpos
= i
;
922 string_char_byte_cache_string
= string
;
927 /* Convert STRING to a multibyte string. */
930 string_make_multibyte (string
)
936 if (STRING_MULTIBYTE (string
))
939 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
940 XSTRING (string
)->size
);
941 /* If all the chars are ASCII, they won't need any more bytes
942 once converted. In that case, we can return STRING itself. */
943 if (nbytes
== STRING_BYTES (XSTRING (string
)))
946 buf
= (unsigned char *) alloca (nbytes
);
947 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
950 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
953 /* Convert STRING to a single-byte string. */
956 string_make_unibyte (string
)
961 if (! STRING_MULTIBYTE (string
))
964 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
966 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
969 return make_unibyte_string (buf
, XSTRING (string
)->size
);
972 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
974 doc
: /* Return the multibyte equivalent of STRING.
975 The function `unibyte-char-to-multibyte' is used to convert
976 each unibyte character to a multibyte character. */)
980 CHECK_STRING (string
);
982 return string_make_multibyte (string
);
985 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
987 doc
: /* Return the unibyte equivalent of STRING.
988 Multibyte character codes are converted to unibyte
989 by using just the low 8 bits. */)
993 CHECK_STRING (string
);
995 return string_make_unibyte (string
);
998 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1000 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1001 If STRING is unibyte, the result is STRING itself.
1002 Otherwise it is a newly created string, with no text properties.
1003 If STRING is multibyte and contains a character of charset
1004 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1005 corresponding single byte. */)
1009 CHECK_STRING (string
);
1011 if (STRING_MULTIBYTE (string
))
1013 int bytes
= STRING_BYTES (XSTRING (string
));
1014 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1016 bcopy (XSTRING (string
)->data
, str
, bytes
);
1017 bytes
= str_as_unibyte (str
, bytes
);
1018 string
= make_unibyte_string (str
, bytes
);
1024 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1026 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1027 If STRING is multibyte, the result is STRING itself.
1028 Otherwise it is a newly created string, with no text properties.
1029 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1030 part of a multibyte form), it is converted to the corresponding
1031 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1035 CHECK_STRING (string
);
1037 if (! STRING_MULTIBYTE (string
))
1039 Lisp_Object new_string
;
1042 parse_str_as_multibyte (XSTRING (string
)->data
,
1043 STRING_BYTES (XSTRING (string
)),
1045 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1046 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1047 STRING_BYTES (XSTRING (string
)));
1048 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1049 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1050 STRING_BYTES (XSTRING (string
)), NULL
);
1051 string
= new_string
;
1052 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1058 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1060 doc
: /* Return a multibyte string with the same individual chars as STRING.
1061 If STRING is multibyte, the result is STRING itself.
1062 Otherwise it is a newly created string, with no text properties.
1064 If STRING is unibyte and contains an 8-bit byte, it is converted to
1065 the corresponding multibyte character of charset `eight-bit'. */)
1069 CHECK_STRING (string
);
1071 if (! STRING_MULTIBYTE (string
))
1073 Lisp_Object new_string
;
1076 nchars
= XSTRING (string
)->size
;
1077 nbytes
= parse_str_to_multibyte (XSTRING (string
)->data
,
1078 STRING_BYTES (XSTRING (string
)));
1079 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1080 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1081 STRING_BYTES (XSTRING (string
)));
1082 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1083 str_to_multibyte (XSTRING (new_string
)->data
, nbytes
,
1084 STRING_BYTES (XSTRING (string
)));
1085 string
= new_string
;
1086 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1091 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1092 doc
: /* Return a copy of ALIST.
1093 This is an alist which represents the same mapping from objects to objects,
1094 but does not share the alist structure with ALIST.
1095 The objects mapped (cars and cdrs of elements of the alist)
1096 are shared, however.
1097 Elements of ALIST that are not conses are also shared. */)
1101 register Lisp_Object tem
;
1106 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1107 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1109 register Lisp_Object car
;
1113 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1118 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1119 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1120 TO may be nil or omitted; then the substring runs to the end of STRING.
1121 If FROM or TO is negative, it counts from the end.
1123 This function allows vectors as well as strings. */)
1126 register Lisp_Object from
, to
;
1131 int from_char
, to_char
;
1132 int from_byte
= 0, to_byte
= 0;
1134 if (! (STRINGP (string
) || VECTORP (string
)))
1135 wrong_type_argument (Qarrayp
, string
);
1137 CHECK_NUMBER (from
);
1139 if (STRINGP (string
))
1141 size
= XSTRING (string
)->size
;
1142 size_byte
= STRING_BYTES (XSTRING (string
));
1145 size
= XVECTOR (string
)->size
;
1150 to_byte
= size_byte
;
1156 to_char
= XINT (to
);
1160 if (STRINGP (string
))
1161 to_byte
= string_char_to_byte (string
, to_char
);
1164 from_char
= XINT (from
);
1167 if (STRINGP (string
))
1168 from_byte
= string_char_to_byte (string
, from_char
);
1170 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1171 args_out_of_range_3 (string
, make_number (from_char
),
1172 make_number (to_char
));
1174 if (STRINGP (string
))
1176 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1177 to_char
- from_char
, to_byte
- from_byte
,
1178 STRING_MULTIBYTE (string
));
1179 copy_text_properties (make_number (from_char
), make_number (to_char
),
1180 string
, make_number (0), res
, Qnil
);
1183 res
= Fvector (to_char
- from_char
,
1184 XVECTOR (string
)->contents
+ from_char
);
1189 /* Extract a substring of STRING, giving start and end positions
1190 both in characters and in bytes. */
1193 substring_both (string
, from
, from_byte
, to
, to_byte
)
1195 int from
, from_byte
, to
, to_byte
;
1201 if (! (STRINGP (string
) || VECTORP (string
)))
1202 wrong_type_argument (Qarrayp
, string
);
1204 if (STRINGP (string
))
1206 size
= XSTRING (string
)->size
;
1207 size_byte
= STRING_BYTES (XSTRING (string
));
1210 size
= XVECTOR (string
)->size
;
1212 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1213 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1215 if (STRINGP (string
))
1217 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1218 to
- from
, to_byte
- from_byte
,
1219 STRING_MULTIBYTE (string
));
1220 copy_text_properties (make_number (from
), make_number (to
),
1221 string
, make_number (0), res
, Qnil
);
1224 res
= Fvector (to
- from
,
1225 XVECTOR (string
)->contents
+ from
);
1230 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1231 doc
: /* Take cdr N times on LIST, returns the result. */)
1234 register Lisp_Object list
;
1236 register int i
, num
;
1239 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1243 wrong_type_argument (Qlistp
, list
);
1249 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1250 doc
: /* Return the Nth element of LIST.
1251 N counts from zero. If LIST is not that long, nil is returned. */)
1253 Lisp_Object n
, list
;
1255 return Fcar (Fnthcdr (n
, list
));
1258 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1259 doc
: /* Return element of SEQUENCE at index N. */)
1261 register Lisp_Object sequence
, n
;
1266 if (CONSP (sequence
) || NILP (sequence
))
1267 return Fcar (Fnthcdr (n
, sequence
));
1268 else if (STRINGP (sequence
) || VECTORP (sequence
)
1269 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1270 return Faref (sequence
, n
);
1272 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1276 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1277 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1278 The value is actually the tail of LIST whose car is ELT. */)
1280 register Lisp_Object elt
;
1283 register Lisp_Object tail
;
1284 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1286 register Lisp_Object tem
;
1288 wrong_type_argument (Qlistp
, list
);
1290 if (! NILP (Fequal (elt
, tem
)))
1297 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1298 doc
: /* Return non-nil if ELT is an element of LIST.
1299 Comparison done with EQ. The value is actually the tail of LIST
1300 whose car is ELT. */)
1302 Lisp_Object elt
, list
;
1306 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1310 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1314 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1321 if (!CONSP (list
) && !NILP (list
))
1322 list
= wrong_type_argument (Qlistp
, list
);
1327 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1328 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1329 The value is actually the element of LIST whose car is KEY.
1330 Elements of LIST that are not conses are ignored. */)
1332 Lisp_Object key
, list
;
1339 || (CONSP (XCAR (list
))
1340 && EQ (XCAR (XCAR (list
)), key
)))
1345 || (CONSP (XCAR (list
))
1346 && EQ (XCAR (XCAR (list
)), key
)))
1351 || (CONSP (XCAR (list
))
1352 && EQ (XCAR (XCAR (list
)), key
)))
1360 result
= XCAR (list
);
1361 else if (NILP (list
))
1364 result
= wrong_type_argument (Qlistp
, list
);
1369 /* Like Fassq but never report an error and do not allow quits.
1370 Use only on lists known never to be circular. */
1373 assq_no_quit (key
, list
)
1374 Lisp_Object key
, list
;
1377 && (!CONSP (XCAR (list
))
1378 || !EQ (XCAR (XCAR (list
)), key
)))
1381 return CONSP (list
) ? XCAR (list
) : Qnil
;
1384 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1385 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1386 The value is actually the element of LIST whose car equals KEY. */)
1388 Lisp_Object key
, list
;
1390 Lisp_Object result
, car
;
1395 || (CONSP (XCAR (list
))
1396 && (car
= XCAR (XCAR (list
)),
1397 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1402 || (CONSP (XCAR (list
))
1403 && (car
= XCAR (XCAR (list
)),
1404 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1409 || (CONSP (XCAR (list
))
1410 && (car
= XCAR (XCAR (list
)),
1411 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1419 result
= XCAR (list
);
1420 else if (NILP (list
))
1423 result
= wrong_type_argument (Qlistp
, list
);
1428 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1429 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1430 The value is actually the element of LIST whose cdr is KEY. */)
1432 register Lisp_Object key
;
1440 || (CONSP (XCAR (list
))
1441 && EQ (XCDR (XCAR (list
)), key
)))
1446 || (CONSP (XCAR (list
))
1447 && EQ (XCDR (XCAR (list
)), key
)))
1452 || (CONSP (XCAR (list
))
1453 && EQ (XCDR (XCAR (list
)), key
)))
1462 else if (CONSP (list
))
1463 result
= XCAR (list
);
1465 result
= wrong_type_argument (Qlistp
, list
);
1470 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1471 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1472 The value is actually the element of LIST whose cdr equals KEY. */)
1474 Lisp_Object key
, list
;
1476 Lisp_Object result
, cdr
;
1481 || (CONSP (XCAR (list
))
1482 && (cdr
= XCDR (XCAR (list
)),
1483 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1488 || (CONSP (XCAR (list
))
1489 && (cdr
= XCDR (XCAR (list
)),
1490 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1495 || (CONSP (XCAR (list
))
1496 && (cdr
= XCDR (XCAR (list
)),
1497 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1505 result
= XCAR (list
);
1506 else if (NILP (list
))
1509 result
= wrong_type_argument (Qlistp
, list
);
1514 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1515 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1516 The modified LIST is returned. Comparison is done with `eq'.
1517 If the first member of LIST is ELT, there is no way to remove it by side effect;
1518 therefore, write `(setq foo (delq element foo))'
1519 to be sure of changing the value of `foo'. */)
1521 register Lisp_Object elt
;
1524 register Lisp_Object tail
, prev
;
1525 register Lisp_Object tem
;
1529 while (!NILP (tail
))
1532 wrong_type_argument (Qlistp
, list
);
1539 Fsetcdr (prev
, XCDR (tail
));
1549 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1550 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1551 SEQ must be a list, a vector, or a string.
1552 The modified SEQ is returned. Comparison is done with `equal'.
1553 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1554 is not a side effect; it is simply using a different sequence.
1555 Therefore, write `(setq foo (delete element foo))'
1556 to be sure of changing the value of `foo'. */)
1558 Lisp_Object elt
, seq
;
1564 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1565 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1568 if (n
!= ASIZE (seq
))
1570 struct Lisp_Vector
*p
= allocate_vector (n
);
1572 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1573 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1574 p
->contents
[n
++] = AREF (seq
, i
);
1576 XSETVECTOR (seq
, p
);
1579 else if (STRINGP (seq
))
1581 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1584 for (i
= nchars
= nbytes
= ibyte
= 0;
1585 i
< XSTRING (seq
)->size
;
1586 ++i
, ibyte
+= cbytes
)
1588 if (STRING_MULTIBYTE (seq
))
1590 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1591 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1592 cbytes
= CHAR_BYTES (c
);
1596 c
= XSTRING (seq
)->data
[i
];
1600 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1607 if (nchars
!= XSTRING (seq
)->size
)
1611 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1612 if (!STRING_MULTIBYTE (seq
))
1613 SET_STRING_BYTES (XSTRING (tem
), -1);
1615 for (i
= nchars
= nbytes
= ibyte
= 0;
1616 i
< XSTRING (seq
)->size
;
1617 ++i
, ibyte
+= cbytes
)
1619 if (STRING_MULTIBYTE (seq
))
1621 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1622 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1623 cbytes
= CHAR_BYTES (c
);
1627 c
= XSTRING (seq
)->data
[i
];
1631 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1633 unsigned char *from
= &XSTRING (seq
)->data
[ibyte
];
1634 unsigned char *to
= &XSTRING (tem
)->data
[nbytes
];
1640 for (n
= cbytes
; n
--; )
1650 Lisp_Object tail
, prev
;
1652 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1655 wrong_type_argument (Qlistp
, seq
);
1657 if (!NILP (Fequal (elt
, XCAR (tail
))))
1662 Fsetcdr (prev
, XCDR (tail
));
1673 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1674 doc
: /* Reverse LIST by modifying cdr pointers.
1675 Returns the beginning of the reversed list. */)
1679 register Lisp_Object prev
, tail
, next
;
1681 if (NILP (list
)) return list
;
1684 while (!NILP (tail
))
1688 wrong_type_argument (Qlistp
, list
);
1690 Fsetcdr (tail
, prev
);
1697 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1698 doc
: /* Reverse LIST, copying. Returns the beginning of the reversed list.
1699 See also the function `nreverse', which is used more often. */)
1705 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1706 new = Fcons (XCAR (list
), new);
1708 wrong_type_argument (Qconsp
, list
);
1712 Lisp_Object
merge ();
1714 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1715 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1716 Returns the sorted list. LIST is modified by side effects.
1717 PREDICATE is called with two elements of LIST, and should return t
1718 if the first element is "less" than the second. */)
1720 Lisp_Object list
, predicate
;
1722 Lisp_Object front
, back
;
1723 register Lisp_Object len
, tem
;
1724 struct gcpro gcpro1
, gcpro2
;
1725 register int length
;
1728 len
= Flength (list
);
1729 length
= XINT (len
);
1733 XSETINT (len
, (length
/ 2) - 1);
1734 tem
= Fnthcdr (len
, list
);
1736 Fsetcdr (tem
, Qnil
);
1738 GCPRO2 (front
, back
);
1739 front
= Fsort (front
, predicate
);
1740 back
= Fsort (back
, predicate
);
1742 return merge (front
, back
, predicate
);
1746 merge (org_l1
, org_l2
, pred
)
1747 Lisp_Object org_l1
, org_l2
;
1751 register Lisp_Object tail
;
1753 register Lisp_Object l1
, l2
;
1754 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1761 /* It is sufficient to protect org_l1 and org_l2.
1762 When l1 and l2 are updated, we copy the new values
1763 back into the org_ vars. */
1764 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1784 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1800 Fsetcdr (tail
, tem
);
1806 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1807 doc
: /* Extract a value from a property list.
1808 PLIST is a property list, which is a list of the form
1809 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1810 corresponding to the given PROP, or nil if PROP is not
1811 one of the properties on the list. */)
1819 CONSP (tail
) && CONSP (XCDR (tail
));
1820 tail
= XCDR (XCDR (tail
)))
1822 if (EQ (prop
, XCAR (tail
)))
1823 return XCAR (XCDR (tail
));
1825 /* This function can be called asynchronously
1826 (setup_coding_system). Don't QUIT in that case. */
1827 if (!interrupt_input_blocked
)
1832 wrong_type_argument (Qlistp
, prop
);
1837 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1838 doc
: /* Return the value of SYMBOL's PROPNAME property.
1839 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1841 Lisp_Object symbol
, propname
;
1843 CHECK_SYMBOL (symbol
);
1844 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1847 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1848 doc
: /* Change value in PLIST of PROP to VAL.
1849 PLIST is a property list, which is a list of the form
1850 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1851 If PROP is already a property on the list, its value is set to VAL,
1852 otherwise the new PROP VAL pair is added. The new plist is returned;
1853 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1854 The PLIST is modified by side effects. */)
1857 register Lisp_Object prop
;
1860 register Lisp_Object tail
, prev
;
1861 Lisp_Object newcell
;
1863 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1864 tail
= XCDR (XCDR (tail
)))
1866 if (EQ (prop
, XCAR (tail
)))
1868 Fsetcar (XCDR (tail
), val
);
1875 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1879 Fsetcdr (XCDR (prev
), newcell
);
1883 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1884 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1885 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1886 (symbol
, propname
, value
)
1887 Lisp_Object symbol
, propname
, value
;
1889 CHECK_SYMBOL (symbol
);
1890 XSYMBOL (symbol
)->plist
1891 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1895 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1896 doc
: /* Return t if two Lisp objects have similar structure and contents.
1897 They must have the same data type.
1898 Conses are compared by comparing the cars and the cdrs.
1899 Vectors and strings are compared element by element.
1900 Numbers are compared by value, but integers cannot equal floats.
1901 (Use `=' if you want integers and floats to be able to be equal.)
1902 Symbols must match exactly. */)
1904 register Lisp_Object o1
, o2
;
1906 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1910 internal_equal (o1
, o2
, depth
)
1911 register Lisp_Object o1
, o2
;
1915 error ("Stack overflow in equal");
1921 if (XTYPE (o1
) != XTYPE (o2
))
1927 return (extract_float (o1
) == extract_float (o2
));
1930 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1937 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1941 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1943 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1946 o1
= XOVERLAY (o1
)->plist
;
1947 o2
= XOVERLAY (o2
)->plist
;
1952 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1953 && (XMARKER (o1
)->buffer
== 0
1954 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1958 case Lisp_Vectorlike
:
1960 register int i
, size
;
1961 size
= XVECTOR (o1
)->size
;
1962 /* Pseudovectors have the type encoded in the size field, so this test
1963 actually checks that the objects have the same type as well as the
1965 if (XVECTOR (o2
)->size
!= size
)
1967 /* Boolvectors are compared much like strings. */
1968 if (BOOL_VECTOR_P (o1
))
1971 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1973 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1975 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1980 if (WINDOW_CONFIGURATIONP (o1
))
1981 return compare_window_configurations (o1
, o2
, 0);
1983 /* Aside from them, only true vectors, char-tables, and compiled
1984 functions are sensible to compare, so eliminate the others now. */
1985 if (size
& PSEUDOVECTOR_FLAG
)
1987 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
1988 | PVEC_SUB_CHAR_TABLE
)))
1990 size
&= PSEUDOVECTOR_SIZE_MASK
;
1992 for (i
= 0; i
< size
; i
++)
1995 v1
= XVECTOR (o1
)->contents
[i
];
1996 v2
= XVECTOR (o2
)->contents
[i
];
1997 if (!internal_equal (v1
, v2
, depth
+ 1))
2005 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
2007 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
2009 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
2010 STRING_BYTES (XSTRING (o1
))))
2016 case Lisp_Type_Limit
:
2023 extern Lisp_Object
Fmake_char_internal ();
2025 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2026 doc
: /* Store each element of ARRAY with ITEM.
2027 ARRAY is a vector, string, char-table, or bool-vector. */)
2029 Lisp_Object array
, item
;
2031 register int size
, index
, charval
;
2033 if (VECTORP (array
))
2035 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2036 size
= XVECTOR (array
)->size
;
2037 for (index
= 0; index
< size
; index
++)
2040 else if (CHAR_TABLE_P (array
))
2044 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2045 XCHAR_TABLE (array
)->contents
[i
] = item
;
2046 XCHAR_TABLE (array
)->defalt
= item
;
2048 else if (STRINGP (array
))
2050 register unsigned char *p
= XSTRING (array
)->data
;
2051 CHECK_NUMBER (item
);
2052 charval
= XINT (item
);
2053 size
= XSTRING (array
)->size
;
2054 if (STRING_MULTIBYTE (array
))
2056 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2057 int len
= CHAR_STRING (charval
, str
);
2058 int size_byte
= STRING_BYTES (XSTRING (array
));
2059 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2062 if (size
!= size_byte
)
2065 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2066 if (len
!= this_len
)
2067 error ("Attempt to change byte length of a string");
2070 for (i
= 0; i
< size_byte
; i
++)
2071 *p
++ = str
[i
% len
];
2074 for (index
= 0; index
< size
; index
++)
2077 else if (BOOL_VECTOR_P (array
))
2079 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2081 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2083 charval
= (! NILP (item
) ? -1 : 0);
2084 for (index
= 0; index
< size_in_chars
; index
++)
2089 array
= wrong_type_argument (Qarrayp
, array
);
2102 Lisp_Object args
[2];
2105 return Fnconc (2, args
);
2107 return Fnconc (2, &s1
);
2108 #endif /* NO_ARG_ARRAY */
2111 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2112 doc
: /* Concatenate any number of lists by altering them.
2113 Only the last argument is not altered, and need not be a list.
2114 usage: (nconc &rest LISTS) */)
2119 register int argnum
;
2120 register Lisp_Object tail
, tem
, val
;
2124 for (argnum
= 0; argnum
< nargs
; argnum
++)
2127 if (NILP (tem
)) continue;
2132 if (argnum
+ 1 == nargs
) break;
2135 tem
= wrong_type_argument (Qlistp
, tem
);
2144 tem
= args
[argnum
+ 1];
2145 Fsetcdr (tail
, tem
);
2147 args
[argnum
+ 1] = tail
;
2153 /* This is the guts of all mapping functions.
2154 Apply FN to each element of SEQ, one by one,
2155 storing the results into elements of VALS, a C vector of Lisp_Objects.
2156 LENI is the length of VALS, which should also be the length of SEQ. */
2159 mapcar1 (leni
, vals
, fn
, seq
)
2162 Lisp_Object fn
, seq
;
2164 register Lisp_Object tail
;
2167 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2171 /* Don't let vals contain any garbage when GC happens. */
2172 for (i
= 0; i
< leni
; i
++)
2175 GCPRO3 (dummy
, fn
, seq
);
2177 gcpro1
.nvars
= leni
;
2181 /* We need not explicitly protect `tail' because it is used only on lists, and
2182 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2186 for (i
= 0; i
< leni
; i
++)
2188 dummy
= XVECTOR (seq
)->contents
[i
];
2189 dummy
= call1 (fn
, dummy
);
2194 else if (BOOL_VECTOR_P (seq
))
2196 for (i
= 0; i
< leni
; i
++)
2199 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2200 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2205 dummy
= call1 (fn
, dummy
);
2210 else if (STRINGP (seq
))
2214 for (i
= 0, i_byte
= 0; i
< leni
;)
2219 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2220 XSETFASTINT (dummy
, c
);
2221 dummy
= call1 (fn
, dummy
);
2223 vals
[i_before
] = dummy
;
2226 else /* Must be a list, since Flength did not get an error */
2229 for (i
= 0; i
< leni
; i
++)
2231 dummy
= call1 (fn
, Fcar (tail
));
2241 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2242 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2243 In between each pair of results, stick in SEPARATOR. Thus, " " as
2244 SEPARATOR results in spaces between the values returned by FUNCTION.
2245 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2246 (function
, sequence
, separator
)
2247 Lisp_Object function
, sequence
, separator
;
2252 register Lisp_Object
*args
;
2254 struct gcpro gcpro1
;
2256 len
= Flength (sequence
);
2258 nargs
= leni
+ leni
- 1;
2259 if (nargs
< 0) return build_string ("");
2261 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2264 mapcar1 (leni
, args
, function
, sequence
);
2267 for (i
= leni
- 1; i
>= 0; i
--)
2268 args
[i
+ i
] = args
[i
];
2270 for (i
= 1; i
< nargs
; i
+= 2)
2271 args
[i
] = separator
;
2273 return Fconcat (nargs
, args
);
2276 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2277 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2278 The result is a list just as long as SEQUENCE.
2279 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2280 (function
, sequence
)
2281 Lisp_Object function
, sequence
;
2283 register Lisp_Object len
;
2285 register Lisp_Object
*args
;
2287 len
= Flength (sequence
);
2288 leni
= XFASTINT (len
);
2289 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2291 mapcar1 (leni
, args
, function
, sequence
);
2293 return Flist (leni
, args
);
2296 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2297 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2298 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2299 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2300 (function
, sequence
)
2301 Lisp_Object function
, sequence
;
2305 leni
= XFASTINT (Flength (sequence
));
2306 mapcar1 (leni
, 0, function
, sequence
);
2311 /* Anything that calls this function must protect from GC! */
2313 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2314 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2315 Takes one argument, which is the string to display to ask the question.
2316 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2317 No confirmation of the answer is requested; a single character is enough.
2318 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2319 the bindings in `query-replace-map'; see the documentation of that variable
2320 for more information. In this case, the useful bindings are `act', `skip',
2321 `recenter', and `quit'.\)
2323 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2324 is nil and `use-dialog-box' is non-nil. */)
2328 register Lisp_Object obj
, key
, def
, map
;
2329 register int answer
;
2330 Lisp_Object xprompt
;
2331 Lisp_Object args
[2];
2332 struct gcpro gcpro1
, gcpro2
;
2333 int count
= specpdl_ptr
- specpdl
;
2335 specbind (Qcursor_in_echo_area
, Qt
);
2337 map
= Fsymbol_value (intern ("query-replace-map"));
2339 CHECK_STRING (prompt
);
2341 GCPRO2 (prompt
, xprompt
);
2343 #ifdef HAVE_X_WINDOWS
2344 if (display_hourglass_p
)
2345 cancel_hourglass ();
2352 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2356 Lisp_Object pane
, menu
;
2357 redisplay_preserve_echo_area (3);
2358 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2359 Fcons (Fcons (build_string ("No"), Qnil
),
2361 menu
= Fcons (prompt
, pane
);
2362 obj
= Fx_popup_dialog (Qt
, menu
);
2363 answer
= !NILP (obj
);
2366 #endif /* HAVE_MENUS */
2367 cursor_in_echo_area
= 1;
2368 choose_minibuf_frame ();
2369 message_with_string ("%s(y or n) ", xprompt
, 0);
2371 if (minibuffer_auto_raise
)
2373 Lisp_Object mini_frame
;
2375 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2377 Fraise_frame (mini_frame
);
2380 obj
= read_filtered_event (1, 0, 0, 0);
2381 cursor_in_echo_area
= 0;
2382 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2385 key
= Fmake_vector (make_number (1), obj
);
2386 def
= Flookup_key (map
, key
, Qt
);
2388 if (EQ (def
, intern ("skip")))
2393 else if (EQ (def
, intern ("act")))
2398 else if (EQ (def
, intern ("recenter")))
2404 else if (EQ (def
, intern ("quit")))
2406 /* We want to exit this command for exit-prefix,
2407 and this is the only way to do it. */
2408 else if (EQ (def
, intern ("exit-prefix")))
2413 /* If we don't clear this, then the next call to read_char will
2414 return quit_char again, and we'll enter an infinite loop. */
2419 if (EQ (xprompt
, prompt
))
2421 args
[0] = build_string ("Please answer y or n. ");
2423 xprompt
= Fconcat (2, args
);
2428 if (! noninteractive
)
2430 cursor_in_echo_area
= -1;
2431 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2435 unbind_to (count
, Qnil
);
2436 return answer
? Qt
: Qnil
;
2439 /* This is how C code calls `yes-or-no-p' and allows the user
2442 Anything that calls this function must protect from GC! */
2445 do_yes_or_no_p (prompt
)
2448 return call1 (intern ("yes-or-no-p"), prompt
);
2451 /* Anything that calls this function must protect from GC! */
2453 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2454 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2455 Takes one argument, which is the string to display to ask the question.
2456 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2457 The user must confirm the answer with RET,
2458 and can edit it until it has been confirmed.
2460 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2461 is nil, and `use-dialog-box' is non-nil. */)
2465 register Lisp_Object ans
;
2466 Lisp_Object args
[2];
2467 struct gcpro gcpro1
;
2469 CHECK_STRING (prompt
);
2472 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2476 Lisp_Object pane
, menu
, obj
;
2477 redisplay_preserve_echo_area (4);
2478 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2479 Fcons (Fcons (build_string ("No"), Qnil
),
2482 menu
= Fcons (prompt
, pane
);
2483 obj
= Fx_popup_dialog (Qt
, menu
);
2487 #endif /* HAVE_MENUS */
2490 args
[1] = build_string ("(yes or no) ");
2491 prompt
= Fconcat (2, args
);
2497 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2498 Qyes_or_no_p_history
, Qnil
,
2500 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2505 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2513 message ("Please answer yes or no.");
2514 Fsleep_for (make_number (2), Qnil
);
2518 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2519 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2521 Each of the three load averages is multiplied by 100, then converted
2524 When USE-FLOATS is non-nil, floats will be used instead of integers.
2525 These floats are not multiplied by 100.
2527 If the 5-minute or 15-minute load averages are not available, return a
2528 shortened list, containing only those averages which are available. */)
2530 Lisp_Object use_floats
;
2533 int loads
= getloadavg (load_ave
, 3);
2534 Lisp_Object ret
= Qnil
;
2537 error ("load-average not implemented for this operating system");
2541 Lisp_Object load
= (NILP (use_floats
) ?
2542 make_number ((int) (100.0 * load_ave
[loads
]))
2543 : make_float (load_ave
[loads
]));
2544 ret
= Fcons (load
, ret
);
2550 Lisp_Object Vfeatures
, Qsubfeatures
;
2551 extern Lisp_Object Vafter_load_alist
;
2553 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2554 doc
: /* Returns t if FEATURE is present in this Emacs.
2556 Use this to conditionalize execution of lisp code based on the
2557 presence or absence of emacs or environment extensions.
2558 Use `provide' to declare that a feature is available. This function
2559 looks at the value of the variable `features'. The optional argument
2560 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2561 (feature
, subfeature
)
2562 Lisp_Object feature
, subfeature
;
2564 register Lisp_Object tem
;
2565 CHECK_SYMBOL (feature
);
2566 tem
= Fmemq (feature
, Vfeatures
);
2567 if (!NILP (tem
) && !NILP (subfeature
))
2568 tem
= Fmemq (subfeature
, Fget (feature
, Qsubfeatures
));
2569 return (NILP (tem
)) ? Qnil
: Qt
;
2572 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2573 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2574 The optional argument SUBFEATURES should be a list of symbols listing
2575 particular subfeatures supported in this version of FEATURE. */)
2576 (feature
, subfeatures
)
2577 Lisp_Object feature
, subfeatures
;
2579 register Lisp_Object tem
;
2580 CHECK_SYMBOL (feature
);
2581 if (!NILP (Vautoload_queue
))
2582 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2583 tem
= Fmemq (feature
, Vfeatures
);
2585 Vfeatures
= Fcons (feature
, Vfeatures
);
2586 if (!NILP (subfeatures
))
2587 Fput (feature
, Qsubfeatures
, subfeatures
);
2588 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2590 /* Run any load-hooks for this file. */
2591 tem
= Fassq (feature
, Vafter_load_alist
);
2593 Fprogn (Fcdr (tem
));
2598 /* `require' and its subroutines. */
2600 /* List of features currently being require'd, innermost first. */
2602 Lisp_Object require_nesting_list
;
2605 require_unwind (old_value
)
2606 Lisp_Object old_value
;
2608 return require_nesting_list
= old_value
;
2611 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2612 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2613 If FEATURE is not a member of the list `features', then the feature
2614 is not loaded; so load the file FILENAME.
2615 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2616 and `load' will try to load this name appended with the suffix `.elc',
2617 `.el' or the unmodified name, in that order.
2618 If the optional third argument NOERROR is non-nil,
2619 then return nil if the file is not found instead of signaling an error.
2620 Normally the return value is FEATURE.
2621 The normal messages at start and end of loading FILENAME are suppressed. */)
2622 (feature
, filename
, noerror
)
2623 Lisp_Object feature
, filename
, noerror
;
2625 register Lisp_Object tem
;
2626 struct gcpro gcpro1
, gcpro2
;
2628 CHECK_SYMBOL (feature
);
2630 tem
= Fmemq (feature
, Vfeatures
);
2632 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2636 int count
= specpdl_ptr
- specpdl
;
2639 /* A certain amount of recursive `require' is legitimate,
2640 but if we require the same feature recursively 3 times,
2642 tem
= require_nesting_list
;
2643 while (! NILP (tem
))
2645 if (! NILP (Fequal (feature
, XCAR (tem
))))
2650 error ("Recursive `require' for feature `%s'",
2651 XSYMBOL (feature
)->name
->data
);
2653 /* Update the list for any nested `require's that occur. */
2654 record_unwind_protect (require_unwind
, require_nesting_list
);
2655 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2657 /* Value saved here is to be restored into Vautoload_queue */
2658 record_unwind_protect (un_autoload
, Vautoload_queue
);
2659 Vautoload_queue
= Qt
;
2661 /* Load the file. */
2662 GCPRO2 (feature
, filename
);
2663 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2664 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2667 /* If load failed entirely, return nil. */
2669 return unbind_to (count
, Qnil
);
2671 tem
= Fmemq (feature
, Vfeatures
);
2673 error ("Required feature `%s' was not provided",
2674 XSYMBOL (feature
)->name
->data
);
2676 /* Once loading finishes, don't undo it. */
2677 Vautoload_queue
= Qt
;
2678 feature
= unbind_to (count
, feature
);
2684 /* Primitives for work of the "widget" library.
2685 In an ideal world, this section would not have been necessary.
2686 However, lisp function calls being as slow as they are, it turns
2687 out that some functions in the widget library (wid-edit.el) are the
2688 bottleneck of Widget operation. Here is their translation to C,
2689 for the sole reason of efficiency. */
2691 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2692 doc
: /* Return non-nil if PLIST has the property PROP.
2693 PLIST is a property list, which is a list of the form
2694 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2695 Unlike `plist-get', this allows you to distinguish between a missing
2696 property and a property with the value nil.
2697 The value is actually the tail of PLIST whose car is PROP. */)
2699 Lisp_Object plist
, prop
;
2701 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2704 plist
= XCDR (plist
);
2705 plist
= CDR (plist
);
2710 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2711 doc
: /* In WIDGET, set PROPERTY to VALUE.
2712 The value can later be retrieved with `widget-get'. */)
2713 (widget
, property
, value
)
2714 Lisp_Object widget
, property
, value
;
2716 CHECK_CONS (widget
);
2717 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2721 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2722 doc
: /* In WIDGET, get the value of PROPERTY.
2723 The value could either be specified when the widget was created, or
2724 later with `widget-put'. */)
2726 Lisp_Object widget
, property
;
2734 CHECK_CONS (widget
);
2735 tmp
= Fplist_member (XCDR (widget
), property
);
2741 tmp
= XCAR (widget
);
2744 widget
= Fget (tmp
, Qwidget_type
);
2748 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2749 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2750 ARGS are passed as extra arguments to the function.
2751 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2756 /* This function can GC. */
2757 Lisp_Object newargs
[3];
2758 struct gcpro gcpro1
, gcpro2
;
2761 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2762 newargs
[1] = args
[0];
2763 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2764 GCPRO2 (newargs
[0], newargs
[2]);
2765 result
= Fapply (3, newargs
);
2770 #ifdef HAVE_LANGINFO_CODESET
2771 #include <langinfo.h>
2774 DEFUN ("langinfo", Flanginfo
, Slanginfo
, 1, 1, 0,
2775 doc
: /* Access locale category ITEM, if available.
2777 ITEM may be one of the following:
2778 `codeset', returning the character set as a string (CODESET);
2779 `days', returning a 7-element vector of day names (DAY_n);
2780 `months', returning a 12-element vector of month names (MON_n).
2782 If the system can't provide such information through a call to
2783 nl_langinfo(3), return nil. */)
2788 #ifdef HAVE_LANGINFO_CODESET
2790 if (EQ (item
, Qcodeset
))
2791 str
= nl_langinfo (CODESET
);
2793 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2795 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2796 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2798 for (i
= 0; i
< 7; i
++)
2800 str
= nl_langinfo (days
[i
]);
2801 Faset (v
, make_number (i
),
2802 code_convert_string (make_unibyte_string (str
, strlen (str
)),
2803 Vlocale_coding_system
, Qnil
, 0, 0, 1));
2809 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2811 struct Lisp_Vector
*p
= allocate_vector (12);
2812 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2813 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2815 for (i
= 0; i
< 12; i
++)
2817 str
= nl_langinfo (months
[i
]);
2819 code_convert_string (make_unibyte_string (str
, strlen (str
)),
2820 Vlocale_coding_system
, Qnil
, 0, 0, 1);
2822 XSETVECTOR (val
, p
);
2828 return build_string (str
);
2833 /* base64 encode/decode functions (RFC 2045).
2834 Based on code from GNU recode. */
2836 #define MIME_LINE_LENGTH 76
2838 #define IS_ASCII(Character) \
2840 #define IS_BASE64(Character) \
2841 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2842 #define IS_BASE64_IGNORABLE(Character) \
2843 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2844 || (Character) == '\f' || (Character) == '\r')
2846 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2847 character or return retval if there are no characters left to
2849 #define READ_QUADRUPLET_BYTE(retval) \
2854 if (nchars_return) \
2855 *nchars_return = nchars; \
2860 while (IS_BASE64_IGNORABLE (c))
2862 /* Don't use alloca for regions larger than this, lest we overflow
2864 #define MAX_ALLOCA 16*1024
2866 /* Table of characters coding the 64 values. */
2867 static char base64_value_to_char
[64] =
2869 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2870 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2871 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2872 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2873 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2874 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2875 '8', '9', '+', '/' /* 60-63 */
2878 /* Table of base64 values for first 128 characters. */
2879 static short base64_char_to_value
[128] =
2881 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2882 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2883 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2884 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2885 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2886 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2887 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2888 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2889 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2890 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2891 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2892 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2893 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2896 /* The following diagram shows the logical steps by which three octets
2897 get transformed into four base64 characters.
2899 .--------. .--------. .--------.
2900 |aaaaaabb| |bbbbcccc| |ccdddddd|
2901 `--------' `--------' `--------'
2903 .--------+--------+--------+--------.
2904 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2905 `--------+--------+--------+--------'
2907 .--------+--------+--------+--------.
2908 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2909 `--------+--------+--------+--------'
2911 The octets are divided into 6 bit chunks, which are then encoded into
2912 base64 characters. */
2915 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
2916 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
2918 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2920 doc
: /* Base64-encode the region between BEG and END.
2921 Return the length of the encoded text.
2922 Optional third argument NO-LINE-BREAK means do not break long lines
2923 into shorter lines. */)
2924 (beg
, end
, no_line_break
)
2925 Lisp_Object beg
, end
, no_line_break
;
2928 int allength
, length
;
2929 int ibeg
, iend
, encoded_length
;
2932 validate_region (&beg
, &end
);
2934 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2935 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2936 move_gap_both (XFASTINT (beg
), ibeg
);
2938 /* We need to allocate enough room for encoding the text.
2939 We need 33 1/3% more space, plus a newline every 76
2940 characters, and then we round up. */
2941 length
= iend
- ibeg
;
2942 allength
= length
+ length
/3 + 1;
2943 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2945 if (allength
<= MAX_ALLOCA
)
2946 encoded
= (char *) alloca (allength
);
2948 encoded
= (char *) xmalloc (allength
);
2949 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2950 NILP (no_line_break
),
2951 !NILP (current_buffer
->enable_multibyte_characters
));
2952 if (encoded_length
> allength
)
2955 if (encoded_length
< 0)
2957 /* The encoding wasn't possible. */
2958 if (length
> MAX_ALLOCA
)
2960 error ("Multibyte character in data for base64 encoding");
2963 /* Now we have encoded the region, so we insert the new contents
2964 and delete the old. (Insert first in order to preserve markers.) */
2965 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2966 insert (encoded
, encoded_length
);
2967 if (allength
> MAX_ALLOCA
)
2969 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2971 /* If point was outside of the region, restore it exactly; else just
2972 move to the beginning of the region. */
2973 if (old_pos
>= XFASTINT (end
))
2974 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2975 else if (old_pos
> XFASTINT (beg
))
2976 old_pos
= XFASTINT (beg
);
2979 /* We return the length of the encoded text. */
2980 return make_number (encoded_length
);
2983 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2985 doc
: /* Base64-encode STRING and return the result.
2986 Optional second argument NO-LINE-BREAK means do not break long lines
2987 into shorter lines. */)
2988 (string
, no_line_break
)
2989 Lisp_Object string
, no_line_break
;
2991 int allength
, length
, encoded_length
;
2993 Lisp_Object encoded_string
;
2995 CHECK_STRING (string
);
2997 /* We need to allocate enough room for encoding the text.
2998 We need 33 1/3% more space, plus a newline every 76
2999 characters, and then we round up. */
3000 length
= STRING_BYTES (XSTRING (string
));
3001 allength
= length
+ length
/3 + 1;
3002 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3004 /* We need to allocate enough room for decoding the text. */
3005 if (allength
<= MAX_ALLOCA
)
3006 encoded
= (char *) alloca (allength
);
3008 encoded
= (char *) xmalloc (allength
);
3010 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3011 encoded
, length
, NILP (no_line_break
),
3012 STRING_MULTIBYTE (string
));
3013 if (encoded_length
> allength
)
3016 if (encoded_length
< 0)
3018 /* The encoding wasn't possible. */
3019 if (length
> MAX_ALLOCA
)
3021 error ("Multibyte character in data for base64 encoding");
3024 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3025 if (allength
> MAX_ALLOCA
)
3028 return encoded_string
;
3032 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3039 int counter
= 0, i
= 0;
3049 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3050 if (CHAR_BYTE8_P (c
))
3051 c
= CHAR_TO_BYTE8 (c
);
3059 /* Wrap line every 76 characters. */
3063 if (counter
< MIME_LINE_LENGTH
/ 4)
3072 /* Process first byte of a triplet. */
3074 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3075 value
= (0x03 & c
) << 4;
3077 /* Process second byte of a triplet. */
3081 *e
++ = base64_value_to_char
[value
];
3089 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3090 if (CHAR_BYTE8_P (c
))
3091 c
= CHAR_TO_BYTE8 (c
);
3099 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3100 value
= (0x0f & c
) << 2;
3102 /* Process third byte of a triplet. */
3106 *e
++ = base64_value_to_char
[value
];
3113 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3114 if (CHAR_BYTE8_P (c
))
3115 c
= CHAR_TO_BYTE8 (c
);
3123 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3124 *e
++ = base64_value_to_char
[0x3f & c
];
3131 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3133 doc
: /* Base64-decode the region between BEG and END.
3134 Return the length of the decoded text.
3135 If the region can't be decoded, signal an error and don't modify the buffer. */)
3137 Lisp_Object beg
, end
;
3139 int ibeg
, iend
, length
, allength
;
3144 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3146 validate_region (&beg
, &end
);
3148 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3149 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3151 length
= iend
- ibeg
;
3153 /* We need to allocate enough room for decoding the text. If we are
3154 working on a multibyte buffer, each decoded code may occupy at
3156 allength
= multibyte
? length
* 2 : length
;
3157 if (allength
<= MAX_ALLOCA
)
3158 decoded
= (char *) alloca (allength
);
3160 decoded
= (char *) xmalloc (allength
);
3162 move_gap_both (XFASTINT (beg
), ibeg
);
3163 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3164 multibyte
, &inserted_chars
);
3165 if (decoded_length
> allength
)
3168 if (decoded_length
< 0)
3170 /* The decoding wasn't possible. */
3171 if (allength
> MAX_ALLOCA
)
3173 error ("Invalid base64 data");
3176 /* Now we have decoded the region, so we insert the new contents
3177 and delete the old. (Insert first in order to preserve markers.) */
3178 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3179 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3180 if (allength
> MAX_ALLOCA
)
3182 /* Delete the original text. */
3183 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3184 iend
+ decoded_length
, 1);
3186 /* If point was outside of the region, restore it exactly; else just
3187 move to the beginning of the region. */
3188 if (old_pos
>= XFASTINT (end
))
3189 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3190 else if (old_pos
> XFASTINT (beg
))
3191 old_pos
= XFASTINT (beg
);
3192 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3194 return make_number (inserted_chars
);
3197 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3199 doc
: /* Base64-decode STRING and return the result. */)
3204 int length
, decoded_length
;
3205 Lisp_Object decoded_string
;
3207 CHECK_STRING (string
);
3209 length
= STRING_BYTES (XSTRING (string
));
3210 /* We need to allocate enough room for decoding the text. */
3211 if (length
<= MAX_ALLOCA
)
3212 decoded
= (char *) alloca (length
);
3214 decoded
= (char *) xmalloc (length
);
3216 /* The decoded result should be unibyte. */
3217 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3219 if (decoded_length
> length
)
3221 else if (decoded_length
>= 0)
3222 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3224 decoded_string
= Qnil
;
3226 if (length
> MAX_ALLOCA
)
3228 if (!STRINGP (decoded_string
))
3229 error ("Invalid base64 data");
3231 return decoded_string
;
3234 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3235 MULTIBYTE is nonzero, the decoded result should be in multibyte
3236 form. If NCHARS_RETRUN is not NULL, store the number of produced
3237 characters in *NCHARS_RETURN. */
3240 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3250 unsigned long value
;
3255 /* Process first byte of a quadruplet. */
3257 READ_QUADRUPLET_BYTE (e
-to
);
3261 value
= base64_char_to_value
[c
] << 18;
3263 /* Process second byte of a quadruplet. */
3265 READ_QUADRUPLET_BYTE (-1);
3269 value
|= base64_char_to_value
[c
] << 12;
3271 c
= (unsigned char) (value
>> 16);
3272 if (multibyte
&& c
>= 128)
3273 e
+= BYTE8_STRING (c
, e
);
3278 /* Process third byte of a quadruplet. */
3280 READ_QUADRUPLET_BYTE (-1);
3284 READ_QUADRUPLET_BYTE (-1);
3293 value
|= base64_char_to_value
[c
] << 6;
3295 c
= (unsigned char) (0xff & value
>> 8);
3296 if (multibyte
&& c
>= 128)
3297 e
+= BYTE8_STRING (c
, e
);
3302 /* Process fourth byte of a quadruplet. */
3304 READ_QUADRUPLET_BYTE (-1);
3311 value
|= base64_char_to_value
[c
];
3313 c
= (unsigned char) (0xff & value
);
3314 if (multibyte
&& c
>= 128)
3315 e
+= BYTE8_STRING (c
, e
);
3324 /***********************************************************************
3326 ***** Hash Tables *****
3328 ***********************************************************************/
3330 /* Implemented by gerd@gnu.org. This hash table implementation was
3331 inspired by CMUCL hash tables. */
3335 1. For small tables, association lists are probably faster than
3336 hash tables because they have lower overhead.
3338 For uses of hash tables where the O(1) behavior of table
3339 operations is not a requirement, it might therefore be a good idea
3340 not to hash. Instead, we could just do a linear search in the
3341 key_and_value vector of the hash table. This could be done
3342 if a `:linear-search t' argument is given to make-hash-table. */
3345 /* Value is the index of the next entry following the one at IDX
3348 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3350 /* Value is the hash code computed for entry IDX in hash table H. */
3352 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3354 /* Value is the index of the element in hash table H that is the
3355 start of the collision list at index IDX in the index vector of H. */
3357 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3359 /* Value is the size of hash table H. */
3361 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3363 /* The list of all weak hash tables. Don't staticpro this one. */
3365 Lisp_Object Vweak_hash_tables
;
3367 /* Various symbols. */
3369 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3370 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3371 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3373 /* Function prototypes. */
3375 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3376 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3377 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3378 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3379 Lisp_Object
, unsigned));
3380 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3381 Lisp_Object
, unsigned));
3382 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3383 unsigned, Lisp_Object
, unsigned));
3384 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3385 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3386 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3387 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3389 static unsigned sxhash_string
P_ ((unsigned char *, int));
3390 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3391 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3392 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3393 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3397 /***********************************************************************
3399 ***********************************************************************/
3401 /* If OBJ is a Lisp hash table, return a pointer to its struct
3402 Lisp_Hash_Table. Otherwise, signal an error. */
3404 static struct Lisp_Hash_Table
*
3405 check_hash_table (obj
)
3408 CHECK_HASH_TABLE (obj
);
3409 return XHASH_TABLE (obj
);
3413 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3417 next_almost_prime (n
)
3430 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3431 which USED[I] is non-zero. If found at index I in ARGS, set
3432 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3433 -1. This function is used to extract a keyword/argument pair from
3434 a DEFUN parameter list. */
3437 get_key_arg (key
, nargs
, args
, used
)
3445 for (i
= 0; i
< nargs
- 1; ++i
)
3446 if (!used
[i
] && EQ (args
[i
], key
))
3461 /* Return a Lisp vector which has the same contents as VEC but has
3462 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3463 vector that are not copied from VEC are set to INIT. */
3466 larger_vector (vec
, new_size
, init
)
3471 struct Lisp_Vector
*v
;
3474 xassert (VECTORP (vec
));
3475 old_size
= XVECTOR (vec
)->size
;
3476 xassert (new_size
>= old_size
);
3478 v
= allocate_vector (new_size
);
3479 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3480 old_size
* sizeof *v
->contents
);
3481 for (i
= old_size
; i
< new_size
; ++i
)
3482 v
->contents
[i
] = init
;
3483 XSETVECTOR (vec
, v
);
3488 /***********************************************************************
3490 ***********************************************************************/
3492 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3493 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3494 KEY2 are the same. */
3497 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3498 struct Lisp_Hash_Table
*h
;
3499 Lisp_Object key1
, key2
;
3500 unsigned hash1
, hash2
;
3502 return (FLOATP (key1
)
3504 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3508 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3509 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3510 KEY2 are the same. */
3513 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3514 struct Lisp_Hash_Table
*h
;
3515 Lisp_Object key1
, key2
;
3516 unsigned hash1
, hash2
;
3518 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3522 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3523 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3524 if KEY1 and KEY2 are the same. */
3527 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3528 struct Lisp_Hash_Table
*h
;
3529 Lisp_Object key1
, key2
;
3530 unsigned hash1
, hash2
;
3534 Lisp_Object args
[3];
3536 args
[0] = h
->user_cmp_function
;
3539 return !NILP (Ffuncall (3, args
));
3546 /* Value is a hash code for KEY for use in hash table H which uses
3547 `eq' to compare keys. The hash code returned is guaranteed to fit
3548 in a Lisp integer. */
3552 struct Lisp_Hash_Table
*h
;
3555 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3556 xassert ((hash
& ~VALMASK
) == 0);
3561 /* Value is a hash code for KEY for use in hash table H which uses
3562 `eql' to compare keys. The hash code returned is guaranteed to fit
3563 in a Lisp integer. */
3567 struct Lisp_Hash_Table
*h
;
3572 hash
= sxhash (key
, 0);
3574 hash
= XUINT (key
) ^ XGCTYPE (key
);
3575 xassert ((hash
& ~VALMASK
) == 0);
3580 /* Value is a hash code for KEY for use in hash table H which uses
3581 `equal' to compare keys. The hash code returned is guaranteed to fit
3582 in a Lisp integer. */
3585 hashfn_equal (h
, key
)
3586 struct Lisp_Hash_Table
*h
;
3589 unsigned hash
= sxhash (key
, 0);
3590 xassert ((hash
& ~VALMASK
) == 0);
3595 /* Value is a hash code for KEY for use in hash table H which uses as
3596 user-defined function to compare keys. The hash code returned is
3597 guaranteed to fit in a Lisp integer. */
3600 hashfn_user_defined (h
, key
)
3601 struct Lisp_Hash_Table
*h
;
3604 Lisp_Object args
[2], hash
;
3606 args
[0] = h
->user_hash_function
;
3608 hash
= Ffuncall (2, args
);
3609 if (!INTEGERP (hash
))
3611 list2 (build_string ("Invalid hash code returned from \
3612 user-supplied hash function"),
3614 return XUINT (hash
);
3618 /* Create and initialize a new hash table.
3620 TEST specifies the test the hash table will use to compare keys.
3621 It must be either one of the predefined tests `eq', `eql' or
3622 `equal' or a symbol denoting a user-defined test named TEST with
3623 test and hash functions USER_TEST and USER_HASH.
3625 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3627 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3628 new size when it becomes full is computed by adding REHASH_SIZE to
3629 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3630 table's new size is computed by multiplying its old size with
3633 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3634 be resized when the ratio of (number of entries in the table) /
3635 (table size) is >= REHASH_THRESHOLD.
3637 WEAK specifies the weakness of the table. If non-nil, it must be
3638 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3641 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3642 user_test
, user_hash
)
3643 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3644 Lisp_Object user_test
, user_hash
;
3646 struct Lisp_Hash_Table
*h
;
3648 int index_size
, i
, sz
;
3650 /* Preconditions. */
3651 xassert (SYMBOLP (test
));
3652 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3653 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3654 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3655 xassert (FLOATP (rehash_threshold
)
3656 && XFLOATINT (rehash_threshold
) > 0
3657 && XFLOATINT (rehash_threshold
) <= 1.0);
3659 if (XFASTINT (size
) == 0)
3660 size
= make_number (1);
3662 /* Allocate a table and initialize it. */
3663 h
= allocate_hash_table ();
3665 /* Initialize hash table slots. */
3666 sz
= XFASTINT (size
);
3669 if (EQ (test
, Qeql
))
3671 h
->cmpfn
= cmpfn_eql
;
3672 h
->hashfn
= hashfn_eql
;
3674 else if (EQ (test
, Qeq
))
3677 h
->hashfn
= hashfn_eq
;
3679 else if (EQ (test
, Qequal
))
3681 h
->cmpfn
= cmpfn_equal
;
3682 h
->hashfn
= hashfn_equal
;
3686 h
->user_cmp_function
= user_test
;
3687 h
->user_hash_function
= user_hash
;
3688 h
->cmpfn
= cmpfn_user_defined
;
3689 h
->hashfn
= hashfn_user_defined
;
3693 h
->rehash_threshold
= rehash_threshold
;
3694 h
->rehash_size
= rehash_size
;
3695 h
->count
= make_number (0);
3696 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3697 h
->hash
= Fmake_vector (size
, Qnil
);
3698 h
->next
= Fmake_vector (size
, Qnil
);
3699 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3700 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3701 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3703 /* Set up the free list. */
3704 for (i
= 0; i
< sz
- 1; ++i
)
3705 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3706 h
->next_free
= make_number (0);
3708 XSET_HASH_TABLE (table
, h
);
3709 xassert (HASH_TABLE_P (table
));
3710 xassert (XHASH_TABLE (table
) == h
);
3712 /* Maybe add this hash table to the list of all weak hash tables. */
3714 h
->next_weak
= Qnil
;
3717 h
->next_weak
= Vweak_hash_tables
;
3718 Vweak_hash_tables
= table
;
3725 /* Return a copy of hash table H1. Keys and values are not copied,
3726 only the table itself is. */
3729 copy_hash_table (h1
)
3730 struct Lisp_Hash_Table
*h1
;
3733 struct Lisp_Hash_Table
*h2
;
3734 struct Lisp_Vector
*next
;
3736 h2
= allocate_hash_table ();
3737 next
= h2
->vec_next
;
3738 bcopy (h1
, h2
, sizeof *h2
);
3739 h2
->vec_next
= next
;
3740 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3741 h2
->hash
= Fcopy_sequence (h1
->hash
);
3742 h2
->next
= Fcopy_sequence (h1
->next
);
3743 h2
->index
= Fcopy_sequence (h1
->index
);
3744 XSET_HASH_TABLE (table
, h2
);
3746 /* Maybe add this hash table to the list of all weak hash tables. */
3747 if (!NILP (h2
->weak
))
3749 h2
->next_weak
= Vweak_hash_tables
;
3750 Vweak_hash_tables
= table
;
3757 /* Resize hash table H if it's too full. If H cannot be resized
3758 because it's already too large, throw an error. */
3761 maybe_resize_hash_table (h
)
3762 struct Lisp_Hash_Table
*h
;
3764 if (NILP (h
->next_free
))
3766 int old_size
= HASH_TABLE_SIZE (h
);
3767 int i
, new_size
, index_size
;
3769 if (INTEGERP (h
->rehash_size
))
3770 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3772 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3773 new_size
= max (old_size
+ 1, new_size
);
3774 index_size
= next_almost_prime ((int)
3776 / XFLOATINT (h
->rehash_threshold
)));
3777 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3778 error ("Hash table too large to resize");
3780 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3781 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3782 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3783 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3785 /* Update the free list. Do it so that new entries are added at
3786 the end of the free list. This makes some operations like
3788 for (i
= old_size
; i
< new_size
- 1; ++i
)
3789 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3791 if (!NILP (h
->next_free
))
3793 Lisp_Object last
, next
;
3795 last
= h
->next_free
;
3796 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3800 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3803 XSETFASTINT (h
->next_free
, old_size
);
3806 for (i
= 0; i
< old_size
; ++i
)
3807 if (!NILP (HASH_HASH (h
, i
)))
3809 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3810 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3811 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3812 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3818 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3819 the hash code of KEY. Value is the index of the entry in H
3820 matching KEY, or -1 if not found. */
3823 hash_lookup (h
, key
, hash
)
3824 struct Lisp_Hash_Table
*h
;
3829 int start_of_bucket
;
3832 hash_code
= h
->hashfn (h
, key
);
3836 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3837 idx
= HASH_INDEX (h
, start_of_bucket
);
3839 /* We need not gcpro idx since it's either an integer or nil. */
3842 int i
= XFASTINT (idx
);
3843 if (EQ (key
, HASH_KEY (h
, i
))
3845 && h
->cmpfn (h
, key
, hash_code
,
3846 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3848 idx
= HASH_NEXT (h
, i
);
3851 return NILP (idx
) ? -1 : XFASTINT (idx
);
3855 /* Put an entry into hash table H that associates KEY with VALUE.
3856 HASH is a previously computed hash code of KEY.
3857 Value is the index of the entry in H matching KEY. */
3860 hash_put (h
, key
, value
, hash
)
3861 struct Lisp_Hash_Table
*h
;
3862 Lisp_Object key
, value
;
3865 int start_of_bucket
, i
;
3867 xassert ((hash
& ~VALMASK
) == 0);
3869 /* Increment count after resizing because resizing may fail. */
3870 maybe_resize_hash_table (h
);
3871 h
->count
= make_number (XFASTINT (h
->count
) + 1);
3873 /* Store key/value in the key_and_value vector. */
3874 i
= XFASTINT (h
->next_free
);
3875 h
->next_free
= HASH_NEXT (h
, i
);
3876 HASH_KEY (h
, i
) = key
;
3877 HASH_VALUE (h
, i
) = value
;
3879 /* Remember its hash code. */
3880 HASH_HASH (h
, i
) = make_number (hash
);
3882 /* Add new entry to its collision chain. */
3883 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
3884 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3885 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3890 /* Remove the entry matching KEY from hash table H, if there is one. */
3893 hash_remove (h
, key
)
3894 struct Lisp_Hash_Table
*h
;
3898 int start_of_bucket
;
3899 Lisp_Object idx
, prev
;
3901 hash_code
= h
->hashfn (h
, key
);
3902 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3903 idx
= HASH_INDEX (h
, start_of_bucket
);
3906 /* We need not gcpro idx, prev since they're either integers or nil. */
3909 int i
= XFASTINT (idx
);
3911 if (EQ (key
, HASH_KEY (h
, i
))
3913 && h
->cmpfn (h
, key
, hash_code
,
3914 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3916 /* Take entry out of collision chain. */
3918 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3920 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3922 /* Clear slots in key_and_value and add the slots to
3924 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3925 HASH_NEXT (h
, i
) = h
->next_free
;
3926 h
->next_free
= make_number (i
);
3927 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3928 xassert (XINT (h
->count
) >= 0);
3934 idx
= HASH_NEXT (h
, i
);
3940 /* Clear hash table H. */
3944 struct Lisp_Hash_Table
*h
;
3946 if (XFASTINT (h
->count
) > 0)
3948 int i
, size
= HASH_TABLE_SIZE (h
);
3950 for (i
= 0; i
< size
; ++i
)
3952 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3953 HASH_KEY (h
, i
) = Qnil
;
3954 HASH_VALUE (h
, i
) = Qnil
;
3955 HASH_HASH (h
, i
) = Qnil
;
3958 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
3959 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
3961 h
->next_free
= make_number (0);
3962 h
->count
= make_number (0);
3968 /************************************************************************
3970 ************************************************************************/
3972 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3973 entries from the table that don't survive the current GC.
3974 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3975 non-zero if anything was marked. */
3978 sweep_weak_table (h
, remove_entries_p
)
3979 struct Lisp_Hash_Table
*h
;
3980 int remove_entries_p
;
3982 int bucket
, n
, marked
;
3984 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
3987 for (bucket
= 0; bucket
< n
; ++bucket
)
3989 Lisp_Object idx
, next
, prev
;
3991 /* Follow collision chain, removing entries that
3992 don't survive this garbage collection. */
3994 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
3996 int i
= XFASTINT (idx
);
3997 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3998 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4001 if (EQ (h
->weak
, Qkey
))
4002 remove_p
= !key_known_to_survive_p
;
4003 else if (EQ (h
->weak
, Qvalue
))
4004 remove_p
= !value_known_to_survive_p
;
4005 else if (EQ (h
->weak
, Qkey_or_value
))
4006 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4007 else if (EQ (h
->weak
, Qkey_and_value
))
4008 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4012 next
= HASH_NEXT (h
, i
);
4014 if (remove_entries_p
)
4018 /* Take out of collision chain. */
4020 HASH_INDEX (h
, bucket
) = next
;
4022 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4024 /* Add to free list. */
4025 HASH_NEXT (h
, i
) = h
->next_free
;
4028 /* Clear key, value, and hash. */
4029 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4030 HASH_HASH (h
, i
) = Qnil
;
4032 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4039 /* Make sure key and value survive. */
4040 if (!key_known_to_survive_p
)
4042 mark_object (&HASH_KEY (h
, i
));
4046 if (!value_known_to_survive_p
)
4048 mark_object (&HASH_VALUE (h
, i
));
4059 /* Remove elements from weak hash tables that don't survive the
4060 current garbage collection. Remove weak tables that don't survive
4061 from Vweak_hash_tables. Called from gc_sweep. */
4064 sweep_weak_hash_tables ()
4066 Lisp_Object table
, used
, next
;
4067 struct Lisp_Hash_Table
*h
;
4070 /* Mark all keys and values that are in use. Keep on marking until
4071 there is no more change. This is necessary for cases like
4072 value-weak table A containing an entry X -> Y, where Y is used in a
4073 key-weak table B, Z -> Y. If B comes after A in the list of weak
4074 tables, X -> Y might be removed from A, although when looking at B
4075 one finds that it shouldn't. */
4079 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4081 h
= XHASH_TABLE (table
);
4082 if (h
->size
& ARRAY_MARK_FLAG
)
4083 marked
|= sweep_weak_table (h
, 0);
4088 /* Remove tables and entries that aren't used. */
4089 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4091 h
= XHASH_TABLE (table
);
4092 next
= h
->next_weak
;
4094 if (h
->size
& ARRAY_MARK_FLAG
)
4096 /* TABLE is marked as used. Sweep its contents. */
4097 if (XFASTINT (h
->count
) > 0)
4098 sweep_weak_table (h
, 1);
4100 /* Add table to the list of used weak hash tables. */
4101 h
->next_weak
= used
;
4106 Vweak_hash_tables
= used
;
4111 /***********************************************************************
4112 Hash Code Computation
4113 ***********************************************************************/
4115 /* Maximum depth up to which to dive into Lisp structures. */
4117 #define SXHASH_MAX_DEPTH 3
4119 /* Maximum length up to which to take list and vector elements into
4122 #define SXHASH_MAX_LEN 7
4124 /* Combine two integers X and Y for hashing. */
4126 #define SXHASH_COMBINE(X, Y) \
4127 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4131 /* Return a hash for string PTR which has length LEN. The hash
4132 code returned is guaranteed to fit in a Lisp integer. */
4135 sxhash_string (ptr
, len
)
4139 unsigned char *p
= ptr
;
4140 unsigned char *end
= p
+ len
;
4149 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4152 return hash
& VALMASK
;
4156 /* Return a hash for list LIST. DEPTH is the current depth in the
4157 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4160 sxhash_list (list
, depth
)
4167 if (depth
< SXHASH_MAX_DEPTH
)
4169 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4170 list
= XCDR (list
), ++i
)
4172 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4173 hash
= SXHASH_COMBINE (hash
, hash2
);
4180 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4181 the Lisp structure. */
4184 sxhash_vector (vec
, depth
)
4188 unsigned hash
= XVECTOR (vec
)->size
;
4191 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4192 for (i
= 0; i
< n
; ++i
)
4194 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4195 hash
= SXHASH_COMBINE (hash
, hash2
);
4202 /* Return a hash for bool-vector VECTOR. */
4205 sxhash_bool_vector (vec
)
4208 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4211 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4212 for (i
= 0; i
< n
; ++i
)
4213 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4219 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4220 structure. Value is an unsigned integer clipped to VALMASK. */
4229 if (depth
> SXHASH_MAX_DEPTH
)
4232 switch (XTYPE (obj
))
4239 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4240 XSYMBOL (obj
)->name
->size
);
4248 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4251 /* This can be everything from a vector to an overlay. */
4252 case Lisp_Vectorlike
:
4254 /* According to the CL HyperSpec, two arrays are equal only if
4255 they are `eq', except for strings and bit-vectors. In
4256 Emacs, this works differently. We have to compare element
4258 hash
= sxhash_vector (obj
, depth
);
4259 else if (BOOL_VECTOR_P (obj
))
4260 hash
= sxhash_bool_vector (obj
);
4262 /* Others are `equal' if they are `eq', so let's take their
4268 hash
= sxhash_list (obj
, depth
);
4273 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4274 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4275 for (hash
= 0; p
< e
; ++p
)
4276 hash
= SXHASH_COMBINE (hash
, *p
);
4284 return hash
& VALMASK
;
4289 /***********************************************************************
4291 ***********************************************************************/
4294 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4295 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4299 unsigned hash
= sxhash (obj
, 0);;
4300 return make_number (hash
);
4304 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4305 doc
: /* Create and return a new hash table.
4307 Arguments are specified as keyword/argument pairs. The following
4308 arguments are defined:
4310 :test TEST -- TEST must be a symbol that specifies how to compare
4311 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4312 `equal'. User-supplied test and hash functions can be specified via
4313 `define-hash-table-test'.
4315 :size SIZE -- A hint as to how many elements will be put in the table.
4318 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4319 fills up. If REHASH-SIZE is an integer, add that many space. If it
4320 is a float, it must be > 1.0, and the new size is computed by
4321 multiplying the old size with that factor. Default is 1.5.
4323 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4324 Resize the hash table when ratio of the number of entries in the
4325 table. Default is 0.8.
4327 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4328 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4329 returned is a weak table. Key/value pairs are removed from a weak
4330 hash table when there are no non-weak references pointing to their
4331 key, value, one of key or value, or both key and value, depending on
4332 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4335 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4340 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4341 Lisp_Object user_test
, user_hash
;
4345 /* The vector `used' is used to keep track of arguments that
4346 have been consumed. */
4347 used
= (char *) alloca (nargs
* sizeof *used
);
4348 bzero (used
, nargs
* sizeof *used
);
4350 /* See if there's a `:test TEST' among the arguments. */
4351 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4352 test
= i
< 0 ? Qeql
: args
[i
];
4353 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4355 /* See if it is a user-defined test. */
4358 prop
= Fget (test
, Qhash_table_test
);
4359 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4360 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4362 user_test
= XCAR (prop
);
4363 user_hash
= XCAR (XCDR (prop
));
4366 user_test
= user_hash
= Qnil
;
4368 /* See if there's a `:size SIZE' argument. */
4369 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4370 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4371 if (!INTEGERP (size
) || XINT (size
) < 0)
4373 list2 (build_string ("Invalid hash table size"),
4376 /* Look for `:rehash-size SIZE'. */
4377 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4378 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4379 if (!NUMBERP (rehash_size
)
4380 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4381 || XFLOATINT (rehash_size
) <= 1.0)
4383 list2 (build_string ("Invalid hash table rehash size"),
4386 /* Look for `:rehash-threshold THRESHOLD'. */
4387 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4388 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4389 if (!FLOATP (rehash_threshold
)
4390 || XFLOATINT (rehash_threshold
) <= 0.0
4391 || XFLOATINT (rehash_threshold
) > 1.0)
4393 list2 (build_string ("Invalid hash table rehash threshold"),
4396 /* Look for `:weakness WEAK'. */
4397 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4398 weak
= i
< 0 ? Qnil
: args
[i
];
4400 weak
= Qkey_and_value
;
4403 && !EQ (weak
, Qvalue
)
4404 && !EQ (weak
, Qkey_or_value
)
4405 && !EQ (weak
, Qkey_and_value
))
4406 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4409 /* Now, all args should have been used up, or there's a problem. */
4410 for (i
= 0; i
< nargs
; ++i
)
4413 list2 (build_string ("Invalid argument list"), args
[i
]));
4415 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4416 user_test
, user_hash
);
4420 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4421 doc
: /* Return a copy of hash table TABLE. */)
4425 return copy_hash_table (check_hash_table (table
));
4429 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4430 doc
: /* Create a new hash table.
4432 Optional first argument TEST specifies how to compare keys in the
4433 table. Predefined tests are `eq', `eql', and `equal'. Default is
4434 `eql'. New tests can be defined with `define-hash-table-test'. */)
4438 Lisp_Object args
[2];
4440 args
[1] = NILP (test
) ? Qeql
: test
;
4441 return Fmake_hash_table (2, args
);
4445 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4446 doc
: /* Return the number of elements in TABLE. */)
4450 return check_hash_table (table
)->count
;
4454 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4455 Shash_table_rehash_size
, 1, 1, 0,
4456 doc
: /* Return the current rehash size of TABLE. */)
4460 return check_hash_table (table
)->rehash_size
;
4464 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4465 Shash_table_rehash_threshold
, 1, 1, 0,
4466 doc
: /* Return the current rehash threshold of TABLE. */)
4470 return check_hash_table (table
)->rehash_threshold
;
4474 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4475 doc
: /* Return the size of TABLE.
4476 The size can be used as an argument to `make-hash-table' to create
4477 a hash table than can hold as many elements of TABLE holds
4478 without need for resizing. */)
4482 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4483 return make_number (HASH_TABLE_SIZE (h
));
4487 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4488 doc
: /* Return the test TABLE uses. */)
4492 return check_hash_table (table
)->test
;
4496 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4498 doc
: /* Return the weakness of TABLE. */)
4502 return check_hash_table (table
)->weak
;
4506 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4507 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4511 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4515 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4516 doc
: /* Clear hash table TABLE. */)
4520 hash_clear (check_hash_table (table
));
4525 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4526 doc
: /* Look up KEY in TABLE and return its associated value.
4527 If KEY is not found, return DFLT which defaults to nil. */)
4529 Lisp_Object key
, table
, dflt
;
4531 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4532 int i
= hash_lookup (h
, key
, NULL
);
4533 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4537 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4538 doc
: /* Associate KEY with VALUE in hash table TABLE.
4539 If KEY is already present in table, replace its current value with
4542 Lisp_Object key
, value
, table
;
4544 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4548 i
= hash_lookup (h
, key
, &hash
);
4550 HASH_VALUE (h
, i
) = value
;
4552 hash_put (h
, key
, value
, hash
);
4558 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4559 doc
: /* Remove KEY from TABLE. */)
4561 Lisp_Object key
, table
;
4563 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4564 hash_remove (h
, key
);
4569 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4570 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4571 FUNCTION is called with 2 arguments KEY and VALUE. */)
4573 Lisp_Object function
, table
;
4575 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4576 Lisp_Object args
[3];
4579 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4580 if (!NILP (HASH_HASH (h
, i
)))
4583 args
[1] = HASH_KEY (h
, i
);
4584 args
[2] = HASH_VALUE (h
, i
);
4592 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4593 Sdefine_hash_table_test
, 3, 3, 0,
4594 doc
: /* Define a new hash table test with name NAME, a symbol.
4596 In hash tables created with NAME specified as test, use TEST to
4597 compare keys, and HASH for computing hash codes of keys.
4599 TEST must be a function taking two arguments and returning non-nil if
4600 both arguments are the same. HASH must be a function taking one
4601 argument and return an integer that is the hash code of the argument.
4602 Hash code computation should use the whole value range of integers,
4603 including negative integers. */)
4605 Lisp_Object name
, test
, hash
;
4607 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4612 /************************************************************************
4614 ************************************************************************/
4618 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4619 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4621 A message digest is a cryptographic checksum of a document, and the
4622 algorithm to calculate it is defined in RFC 1321.
4624 The two optional arguments START and END are character positions
4625 specifying for which part of OBJECT the message digest should be
4626 computed. If nil or omitted, the digest is computed for the whole
4629 The MD5 message digest is computed from the result of encoding the
4630 text in a coding system, not directly from the internal Emacs form of
4631 the text. The optional fourth argument CODING-SYSTEM specifies which
4632 coding system to encode the text with. It should be the same coding
4633 system that you used or will use when actually writing the text into a
4636 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4637 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4638 system would be chosen by default for writing this text into a file.
4640 If OBJECT is a string, the most preferred coding system (see the
4641 command `prefer-coding-system') is used.
4643 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4644 guesswork fails. Normally, an error is signaled in such case. */)
4645 (object
, start
, end
, coding_system
, noerror
)
4646 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4648 unsigned char digest
[16];
4649 unsigned char value
[33];
4653 int start_char
= 0, end_char
= 0;
4654 int start_byte
= 0, end_byte
= 0;
4656 register struct buffer
*bp
;
4659 if (STRINGP (object
))
4661 if (NILP (coding_system
))
4663 /* Decide the coding-system to encode the data with. */
4665 if (STRING_MULTIBYTE (object
))
4666 /* use default, we can't guess correct value */
4667 coding_system
= preferred_coding_system ();
4669 coding_system
= Qraw_text
;
4672 if (NILP (Fcoding_system_p (coding_system
)))
4674 /* Invalid coding system. */
4676 if (!NILP (noerror
))
4677 coding_system
= Qraw_text
;
4680 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4683 if (STRING_MULTIBYTE (object
))
4684 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4686 size
= XSTRING (object
)->size
;
4687 size_byte
= STRING_BYTES (XSTRING (object
));
4691 CHECK_NUMBER (start
);
4693 start_char
= XINT (start
);
4698 start_byte
= string_char_to_byte (object
, start_char
);
4704 end_byte
= size_byte
;
4710 end_char
= XINT (end
);
4715 end_byte
= string_char_to_byte (object
, end_char
);
4718 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4719 args_out_of_range_3 (object
, make_number (start_char
),
4720 make_number (end_char
));
4724 CHECK_BUFFER (object
);
4726 bp
= XBUFFER (object
);
4732 CHECK_NUMBER_COERCE_MARKER (start
);
4740 CHECK_NUMBER_COERCE_MARKER (end
);
4745 temp
= b
, b
= e
, e
= temp
;
4747 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
4748 args_out_of_range (start
, end
);
4750 if (NILP (coding_system
))
4752 /* Decide the coding-system to encode the data with.
4753 See fileio.c:Fwrite-region */
4755 if (!NILP (Vcoding_system_for_write
))
4756 coding_system
= Vcoding_system_for_write
;
4759 int force_raw_text
= 0;
4761 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4762 if (NILP (coding_system
)
4763 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4765 coding_system
= Qnil
;
4766 if (NILP (current_buffer
->enable_multibyte_characters
))
4770 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4772 /* Check file-coding-system-alist. */
4773 Lisp_Object args
[4], val
;
4775 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4776 args
[3] = Fbuffer_file_name(object
);
4777 val
= Ffind_operation_coding_system (4, args
);
4778 if (CONSP (val
) && !NILP (XCDR (val
)))
4779 coding_system
= XCDR (val
);
4782 if (NILP (coding_system
)
4783 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4785 /* If we still have not decided a coding system, use the
4786 default value of buffer-file-coding-system. */
4787 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4791 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4792 /* Confirm that VAL can surely encode the current region. */
4793 coding_system
= call3 (Vselect_safe_coding_system_function
,
4794 make_number (b
), make_number (e
),
4798 coding_system
= Qraw_text
;
4801 if (NILP (Fcoding_system_p (coding_system
)))
4803 /* Invalid coding system. */
4805 if (!NILP (noerror
))
4806 coding_system
= Qraw_text
;
4809 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4813 object
= make_buffer_string (b
, e
, 0);
4815 if (STRING_MULTIBYTE (object
))
4816 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4819 md5_buffer (XSTRING (object
)->data
+ start_byte
,
4820 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
4823 for (i
= 0; i
< 16; i
++)
4824 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4827 return make_string (value
, 32);
4834 /* Hash table stuff. */
4835 Qhash_table_p
= intern ("hash-table-p");
4836 staticpro (&Qhash_table_p
);
4837 Qeq
= intern ("eq");
4839 Qeql
= intern ("eql");
4841 Qequal
= intern ("equal");
4842 staticpro (&Qequal
);
4843 QCtest
= intern (":test");
4844 staticpro (&QCtest
);
4845 QCsize
= intern (":size");
4846 staticpro (&QCsize
);
4847 QCrehash_size
= intern (":rehash-size");
4848 staticpro (&QCrehash_size
);
4849 QCrehash_threshold
= intern (":rehash-threshold");
4850 staticpro (&QCrehash_threshold
);
4851 QCweakness
= intern (":weakness");
4852 staticpro (&QCweakness
);
4853 Qkey
= intern ("key");
4855 Qvalue
= intern ("value");
4856 staticpro (&Qvalue
);
4857 Qhash_table_test
= intern ("hash-table-test");
4858 staticpro (&Qhash_table_test
);
4859 Qkey_or_value
= intern ("key-or-value");
4860 staticpro (&Qkey_or_value
);
4861 Qkey_and_value
= intern ("key-and-value");
4862 staticpro (&Qkey_and_value
);
4865 defsubr (&Smake_hash_table
);
4866 defsubr (&Scopy_hash_table
);
4867 defsubr (&Smakehash
);
4868 defsubr (&Shash_table_count
);
4869 defsubr (&Shash_table_rehash_size
);
4870 defsubr (&Shash_table_rehash_threshold
);
4871 defsubr (&Shash_table_size
);
4872 defsubr (&Shash_table_test
);
4873 defsubr (&Shash_table_weakness
);
4874 defsubr (&Shash_table_p
);
4875 defsubr (&Sclrhash
);
4876 defsubr (&Sgethash
);
4877 defsubr (&Sputhash
);
4878 defsubr (&Sremhash
);
4879 defsubr (&Smaphash
);
4880 defsubr (&Sdefine_hash_table_test
);
4882 Qstring_lessp
= intern ("string-lessp");
4883 staticpro (&Qstring_lessp
);
4884 Qprovide
= intern ("provide");
4885 staticpro (&Qprovide
);
4886 Qrequire
= intern ("require");
4887 staticpro (&Qrequire
);
4888 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4889 staticpro (&Qyes_or_no_p_history
);
4890 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4891 staticpro (&Qcursor_in_echo_area
);
4892 Qwidget_type
= intern ("widget-type");
4893 staticpro (&Qwidget_type
);
4895 staticpro (&string_char_byte_cache_string
);
4896 string_char_byte_cache_string
= Qnil
;
4898 require_nesting_list
= Qnil
;
4899 staticpro (&require_nesting_list
);
4901 Fset (Qyes_or_no_p_history
, Qnil
);
4903 DEFVAR_LISP ("features", &Vfeatures
,
4904 doc
: /* A list of symbols which are the features of the executing emacs.
4905 Used by `featurep' and `require', and altered by `provide'. */);
4907 Qsubfeatures
= intern ("subfeatures");
4908 staticpro (&Qsubfeatures
);
4910 Qcodeset
= intern ("codeset");
4911 staticpro (&Qcodeset
);
4912 Qdays
= intern ("days");
4914 Qmonths
= intern ("months");
4915 staticpro (&Qmonths
);
4917 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4918 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4919 This applies to y-or-n and yes-or-no questions asked by commands
4920 invoked by mouse clicks and mouse menu items. */);
4923 defsubr (&Sidentity
);
4926 defsubr (&Ssafe_length
);
4927 defsubr (&Sstring_bytes
);
4928 defsubr (&Sstring_equal
);
4929 defsubr (&Scompare_strings
);
4930 defsubr (&Sstring_lessp
);
4933 defsubr (&Svconcat
);
4934 defsubr (&Scopy_sequence
);
4935 defsubr (&Sstring_make_multibyte
);
4936 defsubr (&Sstring_make_unibyte
);
4937 defsubr (&Sstring_as_multibyte
);
4938 defsubr (&Sstring_as_unibyte
);
4939 defsubr (&Sstring_to_multibyte
);
4940 defsubr (&Scopy_alist
);
4941 defsubr (&Ssubstring
);
4953 defsubr (&Snreverse
);
4954 defsubr (&Sreverse
);
4956 defsubr (&Splist_get
);
4958 defsubr (&Splist_put
);
4961 defsubr (&Sfillarray
);
4965 defsubr (&Smapconcat
);
4966 defsubr (&Sy_or_n_p
);
4967 defsubr (&Syes_or_no_p
);
4968 defsubr (&Sload_average
);
4969 defsubr (&Sfeaturep
);
4970 defsubr (&Srequire
);
4971 defsubr (&Sprovide
);
4972 defsubr (&Splist_member
);
4973 defsubr (&Swidget_put
);
4974 defsubr (&Swidget_get
);
4975 defsubr (&Swidget_apply
);
4976 defsubr (&Sbase64_encode_region
);
4977 defsubr (&Sbase64_decode_region
);
4978 defsubr (&Sbase64_encode_string
);
4979 defsubr (&Sbase64_decode_string
);
4981 defsubr (&Slanginfo
);
4988 Vweak_hash_tables
= Qnil
;