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 (!ASCII_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 (!ASCII_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.
1030 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1031 part of a correct utf-8 sequence), it is converted to the corresponding
1032 multibyte character of charset `eight-bit'.
1033 See also `string-to-multibyte'. */)
1037 CHECK_STRING (string
);
1039 if (! STRING_MULTIBYTE (string
))
1041 Lisp_Object new_string
;
1044 parse_str_as_multibyte (XSTRING (string
)->data
,
1045 STRING_BYTES (XSTRING (string
)),
1047 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1048 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1049 STRING_BYTES (XSTRING (string
)));
1050 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1051 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1052 STRING_BYTES (XSTRING (string
)), NULL
);
1053 string
= new_string
;
1054 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1060 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1062 doc
: /* Return a multibyte string with the same individual chars as STRING.
1063 If STRING is multibyte, the result is STRING itself.
1064 Otherwise it is a newly created string, with no text properties.
1066 If STRING is unibyte and contains an 8-bit byte, it is converted to
1067 the corresponding multibyte character of charset `eight-bit'.
1069 This differs from `string-as-multibyte' by converting each byte of a correct
1070 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1071 correct sequence. */)
1075 CHECK_STRING (string
);
1077 if (! STRING_MULTIBYTE (string
))
1079 Lisp_Object new_string
;
1082 nchars
= XSTRING (string
)->size
;
1083 nbytes
= parse_str_to_multibyte (XSTRING (string
)->data
,
1084 STRING_BYTES (XSTRING (string
)));
1085 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1086 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1087 STRING_BYTES (XSTRING (string
)));
1088 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1089 str_to_multibyte (XSTRING (new_string
)->data
, nbytes
,
1090 STRING_BYTES (XSTRING (string
)));
1091 string
= new_string
;
1092 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1097 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1098 doc
: /* Return a copy of ALIST.
1099 This is an alist which represents the same mapping from objects to objects,
1100 but does not share the alist structure with ALIST.
1101 The objects mapped (cars and cdrs of elements of the alist)
1102 are shared, however.
1103 Elements of ALIST that are not conses are also shared. */)
1107 register Lisp_Object tem
;
1112 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1113 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1115 register Lisp_Object car
;
1119 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1124 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1125 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1126 TO may be nil or omitted; then the substring runs to the end of STRING.
1127 If FROM or TO is negative, it counts from the end.
1129 This function allows vectors as well as strings. */)
1132 register Lisp_Object from
, to
;
1137 int from_char
, to_char
;
1138 int from_byte
= 0, to_byte
= 0;
1140 if (! (STRINGP (string
) || VECTORP (string
)))
1141 wrong_type_argument (Qarrayp
, string
);
1143 CHECK_NUMBER (from
);
1145 if (STRINGP (string
))
1147 size
= XSTRING (string
)->size
;
1148 size_byte
= STRING_BYTES (XSTRING (string
));
1151 size
= XVECTOR (string
)->size
;
1156 to_byte
= size_byte
;
1162 to_char
= XINT (to
);
1166 if (STRINGP (string
))
1167 to_byte
= string_char_to_byte (string
, to_char
);
1170 from_char
= XINT (from
);
1173 if (STRINGP (string
))
1174 from_byte
= string_char_to_byte (string
, from_char
);
1176 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1177 args_out_of_range_3 (string
, make_number (from_char
),
1178 make_number (to_char
));
1180 if (STRINGP (string
))
1182 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1183 to_char
- from_char
, to_byte
- from_byte
,
1184 STRING_MULTIBYTE (string
));
1185 copy_text_properties (make_number (from_char
), make_number (to_char
),
1186 string
, make_number (0), res
, Qnil
);
1189 res
= Fvector (to_char
- from_char
,
1190 XVECTOR (string
)->contents
+ from_char
);
1195 /* Extract a substring of STRING, giving start and end positions
1196 both in characters and in bytes. */
1199 substring_both (string
, from
, from_byte
, to
, to_byte
)
1201 int from
, from_byte
, to
, to_byte
;
1207 if (! (STRINGP (string
) || VECTORP (string
)))
1208 wrong_type_argument (Qarrayp
, string
);
1210 if (STRINGP (string
))
1212 size
= XSTRING (string
)->size
;
1213 size_byte
= STRING_BYTES (XSTRING (string
));
1216 size
= XVECTOR (string
)->size
;
1218 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1219 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1221 if (STRINGP (string
))
1223 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1224 to
- from
, to_byte
- from_byte
,
1225 STRING_MULTIBYTE (string
));
1226 copy_text_properties (make_number (from
), make_number (to
),
1227 string
, make_number (0), res
, Qnil
);
1230 res
= Fvector (to
- from
,
1231 XVECTOR (string
)->contents
+ from
);
1236 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1237 doc
: /* Take cdr N times on LIST, returns the result. */)
1240 register Lisp_Object list
;
1242 register int i
, num
;
1245 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1249 wrong_type_argument (Qlistp
, list
);
1255 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1256 doc
: /* Return the Nth element of LIST.
1257 N counts from zero. If LIST is not that long, nil is returned. */)
1259 Lisp_Object n
, list
;
1261 return Fcar (Fnthcdr (n
, list
));
1264 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1265 doc
: /* Return element of SEQUENCE at index N. */)
1267 register Lisp_Object sequence
, n
;
1272 if (CONSP (sequence
) || NILP (sequence
))
1273 return Fcar (Fnthcdr (n
, sequence
));
1274 else if (STRINGP (sequence
) || VECTORP (sequence
)
1275 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1276 return Faref (sequence
, n
);
1278 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1282 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1283 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1284 The value is actually the tail of LIST whose car is ELT. */)
1286 register Lisp_Object elt
;
1289 register Lisp_Object tail
;
1290 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1292 register Lisp_Object tem
;
1294 wrong_type_argument (Qlistp
, list
);
1296 if (! NILP (Fequal (elt
, tem
)))
1303 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1304 doc
: /* Return non-nil if ELT is an element of LIST.
1305 Comparison done with EQ. The value is actually the tail of LIST
1306 whose car is ELT. */)
1308 Lisp_Object elt
, list
;
1312 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1316 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1320 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1327 if (!CONSP (list
) && !NILP (list
))
1328 list
= wrong_type_argument (Qlistp
, list
);
1333 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1334 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1335 The value is actually the element of LIST whose car is KEY.
1336 Elements of LIST that are not conses are ignored. */)
1338 Lisp_Object key
, list
;
1345 || (CONSP (XCAR (list
))
1346 && EQ (XCAR (XCAR (list
)), key
)))
1351 || (CONSP (XCAR (list
))
1352 && EQ (XCAR (XCAR (list
)), key
)))
1357 || (CONSP (XCAR (list
))
1358 && EQ (XCAR (XCAR (list
)), key
)))
1366 result
= XCAR (list
);
1367 else if (NILP (list
))
1370 result
= wrong_type_argument (Qlistp
, list
);
1375 /* Like Fassq but never report an error and do not allow quits.
1376 Use only on lists known never to be circular. */
1379 assq_no_quit (key
, list
)
1380 Lisp_Object key
, list
;
1383 && (!CONSP (XCAR (list
))
1384 || !EQ (XCAR (XCAR (list
)), key
)))
1387 return CONSP (list
) ? XCAR (list
) : Qnil
;
1390 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1391 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1392 The value is actually the element of LIST whose car equals KEY. */)
1394 Lisp_Object key
, list
;
1396 Lisp_Object result
, car
;
1401 || (CONSP (XCAR (list
))
1402 && (car
= XCAR (XCAR (list
)),
1403 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1408 || (CONSP (XCAR (list
))
1409 && (car
= XCAR (XCAR (list
)),
1410 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1415 || (CONSP (XCAR (list
))
1416 && (car
= XCAR (XCAR (list
)),
1417 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1425 result
= XCAR (list
);
1426 else if (NILP (list
))
1429 result
= wrong_type_argument (Qlistp
, list
);
1434 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1435 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1436 The value is actually the element of LIST whose cdr is KEY. */)
1438 register Lisp_Object key
;
1446 || (CONSP (XCAR (list
))
1447 && EQ (XCDR (XCAR (list
)), key
)))
1452 || (CONSP (XCAR (list
))
1453 && EQ (XCDR (XCAR (list
)), key
)))
1458 || (CONSP (XCAR (list
))
1459 && EQ (XCDR (XCAR (list
)), key
)))
1468 else if (CONSP (list
))
1469 result
= XCAR (list
);
1471 result
= wrong_type_argument (Qlistp
, list
);
1476 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1477 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1478 The value is actually the element of LIST whose cdr equals KEY. */)
1480 Lisp_Object key
, list
;
1482 Lisp_Object result
, cdr
;
1487 || (CONSP (XCAR (list
))
1488 && (cdr
= XCDR (XCAR (list
)),
1489 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1494 || (CONSP (XCAR (list
))
1495 && (cdr
= XCDR (XCAR (list
)),
1496 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1501 || (CONSP (XCAR (list
))
1502 && (cdr
= XCDR (XCAR (list
)),
1503 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1511 result
= XCAR (list
);
1512 else if (NILP (list
))
1515 result
= wrong_type_argument (Qlistp
, list
);
1520 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1521 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1522 The modified LIST is returned. Comparison is done with `eq'.
1523 If the first member of LIST is ELT, there is no way to remove it by side effect;
1524 therefore, write `(setq foo (delq element foo))'
1525 to be sure of changing the value of `foo'. */)
1527 register Lisp_Object elt
;
1530 register Lisp_Object tail
, prev
;
1531 register Lisp_Object tem
;
1535 while (!NILP (tail
))
1538 wrong_type_argument (Qlistp
, list
);
1545 Fsetcdr (prev
, XCDR (tail
));
1555 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1556 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1557 SEQ must be a list, a vector, or a string.
1558 The modified SEQ is returned. Comparison is done with `equal'.
1559 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1560 is not a side effect; it is simply using a different sequence.
1561 Therefore, write `(setq foo (delete element foo))'
1562 to be sure of changing the value of `foo'. */)
1564 Lisp_Object elt
, seq
;
1570 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1571 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1574 if (n
!= ASIZE (seq
))
1576 struct Lisp_Vector
*p
= allocate_vector (n
);
1578 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1579 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1580 p
->contents
[n
++] = AREF (seq
, i
);
1582 XSETVECTOR (seq
, p
);
1585 else if (STRINGP (seq
))
1587 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1590 for (i
= nchars
= nbytes
= ibyte
= 0;
1591 i
< XSTRING (seq
)->size
;
1592 ++i
, ibyte
+= cbytes
)
1594 if (STRING_MULTIBYTE (seq
))
1596 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1597 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1598 cbytes
= CHAR_BYTES (c
);
1602 c
= XSTRING (seq
)->data
[i
];
1606 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1613 if (nchars
!= XSTRING (seq
)->size
)
1617 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1618 if (!STRING_MULTIBYTE (seq
))
1619 SET_STRING_BYTES (XSTRING (tem
), -1);
1621 for (i
= nchars
= nbytes
= ibyte
= 0;
1622 i
< XSTRING (seq
)->size
;
1623 ++i
, ibyte
+= cbytes
)
1625 if (STRING_MULTIBYTE (seq
))
1627 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1628 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1629 cbytes
= CHAR_BYTES (c
);
1633 c
= XSTRING (seq
)->data
[i
];
1637 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1639 unsigned char *from
= &XSTRING (seq
)->data
[ibyte
];
1640 unsigned char *to
= &XSTRING (tem
)->data
[nbytes
];
1646 for (n
= cbytes
; n
--; )
1656 Lisp_Object tail
, prev
;
1658 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1661 wrong_type_argument (Qlistp
, seq
);
1663 if (!NILP (Fequal (elt
, XCAR (tail
))))
1668 Fsetcdr (prev
, XCDR (tail
));
1679 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1680 doc
: /* Reverse LIST by modifying cdr pointers.
1681 Returns the beginning of the reversed list. */)
1685 register Lisp_Object prev
, tail
, next
;
1687 if (NILP (list
)) return list
;
1690 while (!NILP (tail
))
1694 wrong_type_argument (Qlistp
, list
);
1696 Fsetcdr (tail
, prev
);
1703 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1704 doc
: /* Reverse LIST, copying. Returns the beginning of the reversed list.
1705 See also the function `nreverse', which is used more often. */)
1711 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1712 new = Fcons (XCAR (list
), new);
1714 wrong_type_argument (Qconsp
, list
);
1718 Lisp_Object
merge ();
1720 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1721 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1722 Returns the sorted list. LIST is modified by side effects.
1723 PREDICATE is called with two elements of LIST, and should return t
1724 if the first element is "less" than the second. */)
1726 Lisp_Object list
, predicate
;
1728 Lisp_Object front
, back
;
1729 register Lisp_Object len
, tem
;
1730 struct gcpro gcpro1
, gcpro2
;
1731 register int length
;
1734 len
= Flength (list
);
1735 length
= XINT (len
);
1739 XSETINT (len
, (length
/ 2) - 1);
1740 tem
= Fnthcdr (len
, list
);
1742 Fsetcdr (tem
, Qnil
);
1744 GCPRO2 (front
, back
);
1745 front
= Fsort (front
, predicate
);
1746 back
= Fsort (back
, predicate
);
1748 return merge (front
, back
, predicate
);
1752 merge (org_l1
, org_l2
, pred
)
1753 Lisp_Object org_l1
, org_l2
;
1757 register Lisp_Object tail
;
1759 register Lisp_Object l1
, l2
;
1760 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1767 /* It is sufficient to protect org_l1 and org_l2.
1768 When l1 and l2 are updated, we copy the new values
1769 back into the org_ vars. */
1770 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1790 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1806 Fsetcdr (tail
, tem
);
1812 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1813 doc
: /* Extract a value from a property list.
1814 PLIST is a property list, which is a list of the form
1815 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1816 corresponding to the given PROP, or nil if PROP is not
1817 one of the properties on the list. */)
1825 CONSP (tail
) && CONSP (XCDR (tail
));
1826 tail
= XCDR (XCDR (tail
)))
1828 if (EQ (prop
, XCAR (tail
)))
1829 return XCAR (XCDR (tail
));
1831 /* This function can be called asynchronously
1832 (setup_coding_system). Don't QUIT in that case. */
1833 if (!interrupt_input_blocked
)
1838 wrong_type_argument (Qlistp
, prop
);
1843 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1844 doc
: /* Return the value of SYMBOL's PROPNAME property.
1845 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1847 Lisp_Object symbol
, propname
;
1849 CHECK_SYMBOL (symbol
);
1850 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1853 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1854 doc
: /* Change value in PLIST of PROP to VAL.
1855 PLIST is a property list, which is a list of the form
1856 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1857 If PROP is already a property on the list, its value is set to VAL,
1858 otherwise the new PROP VAL pair is added. The new plist is returned;
1859 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1860 The PLIST is modified by side effects. */)
1863 register Lisp_Object prop
;
1866 register Lisp_Object tail
, prev
;
1867 Lisp_Object newcell
;
1869 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1870 tail
= XCDR (XCDR (tail
)))
1872 if (EQ (prop
, XCAR (tail
)))
1874 Fsetcar (XCDR (tail
), val
);
1881 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1885 Fsetcdr (XCDR (prev
), newcell
);
1889 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1890 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1891 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1892 (symbol
, propname
, value
)
1893 Lisp_Object symbol
, propname
, value
;
1895 CHECK_SYMBOL (symbol
);
1896 XSYMBOL (symbol
)->plist
1897 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1901 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1902 doc
: /* Return t if two Lisp objects have similar structure and contents.
1903 They must have the same data type.
1904 Conses are compared by comparing the cars and the cdrs.
1905 Vectors and strings are compared element by element.
1906 Numbers are compared by value, but integers cannot equal floats.
1907 (Use `=' if you want integers and floats to be able to be equal.)
1908 Symbols must match exactly. */)
1910 register Lisp_Object o1
, o2
;
1912 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1916 internal_equal (o1
, o2
, depth
)
1917 register Lisp_Object o1
, o2
;
1921 error ("Stack overflow in equal");
1927 if (XTYPE (o1
) != XTYPE (o2
))
1933 return (extract_float (o1
) == extract_float (o2
));
1936 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1943 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1947 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1949 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1952 o1
= XOVERLAY (o1
)->plist
;
1953 o2
= XOVERLAY (o2
)->plist
;
1958 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1959 && (XMARKER (o1
)->buffer
== 0
1960 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1964 case Lisp_Vectorlike
:
1966 register int i
, size
;
1967 size
= XVECTOR (o1
)->size
;
1968 /* Pseudovectors have the type encoded in the size field, so this test
1969 actually checks that the objects have the same type as well as the
1971 if (XVECTOR (o2
)->size
!= size
)
1973 /* Boolvectors are compared much like strings. */
1974 if (BOOL_VECTOR_P (o1
))
1977 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1979 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1981 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1986 if (WINDOW_CONFIGURATIONP (o1
))
1987 return compare_window_configurations (o1
, o2
, 0);
1989 /* Aside from them, only true vectors, char-tables, and compiled
1990 functions are sensible to compare, so eliminate the others now. */
1991 if (size
& PSEUDOVECTOR_FLAG
)
1993 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
1994 | PVEC_SUB_CHAR_TABLE
)))
1996 size
&= PSEUDOVECTOR_SIZE_MASK
;
1998 for (i
= 0; i
< size
; i
++)
2001 v1
= XVECTOR (o1
)->contents
[i
];
2002 v2
= XVECTOR (o2
)->contents
[i
];
2003 if (!internal_equal (v1
, v2
, depth
+ 1))
2011 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
2013 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
2015 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
2016 STRING_BYTES (XSTRING (o1
))))
2022 case Lisp_Type_Limit
:
2029 extern Lisp_Object
Fmake_char_internal ();
2031 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2032 doc
: /* Store each element of ARRAY with ITEM.
2033 ARRAY is a vector, string, char-table, or bool-vector. */)
2035 Lisp_Object array
, item
;
2037 register int size
, index
, charval
;
2039 if (VECTORP (array
))
2041 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2042 size
= XVECTOR (array
)->size
;
2043 for (index
= 0; index
< size
; index
++)
2046 else if (CHAR_TABLE_P (array
))
2050 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2051 XCHAR_TABLE (array
)->contents
[i
] = item
;
2052 XCHAR_TABLE (array
)->defalt
= item
;
2054 else if (STRINGP (array
))
2056 register unsigned char *p
= XSTRING (array
)->data
;
2057 CHECK_NUMBER (item
);
2058 charval
= XINT (item
);
2059 size
= XSTRING (array
)->size
;
2060 if (STRING_MULTIBYTE (array
))
2062 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2063 int len
= CHAR_STRING (charval
, str
);
2064 int size_byte
= STRING_BYTES (XSTRING (array
));
2065 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2068 if (size
!= size_byte
)
2071 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2072 if (len
!= this_len
)
2073 error ("Attempt to change byte length of a string");
2076 for (i
= 0; i
< size_byte
; i
++)
2077 *p
++ = str
[i
% len
];
2080 for (index
= 0; index
< size
; index
++)
2083 else if (BOOL_VECTOR_P (array
))
2085 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2087 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2089 charval
= (! NILP (item
) ? -1 : 0);
2090 for (index
= 0; index
< size_in_chars
; index
++)
2095 array
= wrong_type_argument (Qarrayp
, array
);
2108 Lisp_Object args
[2];
2111 return Fnconc (2, args
);
2113 return Fnconc (2, &s1
);
2114 #endif /* NO_ARG_ARRAY */
2117 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2118 doc
: /* Concatenate any number of lists by altering them.
2119 Only the last argument is not altered, and need not be a list.
2120 usage: (nconc &rest LISTS) */)
2125 register int argnum
;
2126 register Lisp_Object tail
, tem
, val
;
2130 for (argnum
= 0; argnum
< nargs
; argnum
++)
2133 if (NILP (tem
)) continue;
2138 if (argnum
+ 1 == nargs
) break;
2141 tem
= wrong_type_argument (Qlistp
, tem
);
2150 tem
= args
[argnum
+ 1];
2151 Fsetcdr (tail
, tem
);
2153 args
[argnum
+ 1] = tail
;
2159 /* This is the guts of all mapping functions.
2160 Apply FN to each element of SEQ, one by one,
2161 storing the results into elements of VALS, a C vector of Lisp_Objects.
2162 LENI is the length of VALS, which should also be the length of SEQ. */
2165 mapcar1 (leni
, vals
, fn
, seq
)
2168 Lisp_Object fn
, seq
;
2170 register Lisp_Object tail
;
2173 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2177 /* Don't let vals contain any garbage when GC happens. */
2178 for (i
= 0; i
< leni
; i
++)
2181 GCPRO3 (dummy
, fn
, seq
);
2183 gcpro1
.nvars
= leni
;
2187 /* We need not explicitly protect `tail' because it is used only on lists, and
2188 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2192 for (i
= 0; i
< leni
; i
++)
2194 dummy
= XVECTOR (seq
)->contents
[i
];
2195 dummy
= call1 (fn
, dummy
);
2200 else if (BOOL_VECTOR_P (seq
))
2202 for (i
= 0; i
< leni
; i
++)
2205 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2206 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2211 dummy
= call1 (fn
, dummy
);
2216 else if (STRINGP (seq
))
2220 for (i
= 0, i_byte
= 0; i
< leni
;)
2225 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2226 XSETFASTINT (dummy
, c
);
2227 dummy
= call1 (fn
, dummy
);
2229 vals
[i_before
] = dummy
;
2232 else /* Must be a list, since Flength did not get an error */
2235 for (i
= 0; i
< leni
; i
++)
2237 dummy
= call1 (fn
, Fcar (tail
));
2247 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2248 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2249 In between each pair of results, stick in SEPARATOR. Thus, " " as
2250 SEPARATOR results in spaces between the values returned by FUNCTION.
2251 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2252 (function
, sequence
, separator
)
2253 Lisp_Object function
, sequence
, separator
;
2258 register Lisp_Object
*args
;
2260 struct gcpro gcpro1
;
2262 len
= Flength (sequence
);
2264 nargs
= leni
+ leni
- 1;
2265 if (nargs
< 0) return build_string ("");
2267 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2270 mapcar1 (leni
, args
, function
, sequence
);
2273 for (i
= leni
- 1; i
>= 0; i
--)
2274 args
[i
+ i
] = args
[i
];
2276 for (i
= 1; i
< nargs
; i
+= 2)
2277 args
[i
] = separator
;
2279 return Fconcat (nargs
, args
);
2282 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2283 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2284 The result is a list just as long as SEQUENCE.
2285 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2286 (function
, sequence
)
2287 Lisp_Object function
, sequence
;
2289 register Lisp_Object len
;
2291 register Lisp_Object
*args
;
2293 len
= Flength (sequence
);
2294 leni
= XFASTINT (len
);
2295 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2297 mapcar1 (leni
, args
, function
, sequence
);
2299 return Flist (leni
, args
);
2302 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2303 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2304 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2305 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2306 (function
, sequence
)
2307 Lisp_Object function
, sequence
;
2311 leni
= XFASTINT (Flength (sequence
));
2312 mapcar1 (leni
, 0, function
, sequence
);
2317 /* Anything that calls this function must protect from GC! */
2319 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2320 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2321 Takes one argument, which is the string to display to ask the question.
2322 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2323 No confirmation of the answer is requested; a single character is enough.
2324 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2325 the bindings in `query-replace-map'; see the documentation of that variable
2326 for more information. In this case, the useful bindings are `act', `skip',
2327 `recenter', and `quit'.\)
2329 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2330 is nil and `use-dialog-box' is non-nil. */)
2334 register Lisp_Object obj
, key
, def
, map
;
2335 register int answer
;
2336 Lisp_Object xprompt
;
2337 Lisp_Object args
[2];
2338 struct gcpro gcpro1
, gcpro2
;
2339 int count
= specpdl_ptr
- specpdl
;
2341 specbind (Qcursor_in_echo_area
, Qt
);
2343 map
= Fsymbol_value (intern ("query-replace-map"));
2345 CHECK_STRING (prompt
);
2347 GCPRO2 (prompt
, xprompt
);
2349 #ifdef HAVE_X_WINDOWS
2350 if (display_hourglass_p
)
2351 cancel_hourglass ();
2358 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2362 Lisp_Object pane
, menu
;
2363 redisplay_preserve_echo_area (3);
2364 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2365 Fcons (Fcons (build_string ("No"), Qnil
),
2367 menu
= Fcons (prompt
, pane
);
2368 obj
= Fx_popup_dialog (Qt
, menu
);
2369 answer
= !NILP (obj
);
2372 #endif /* HAVE_MENUS */
2373 cursor_in_echo_area
= 1;
2374 choose_minibuf_frame ();
2375 message_with_string ("%s(y or n) ", xprompt
, 0);
2377 if (minibuffer_auto_raise
)
2379 Lisp_Object mini_frame
;
2381 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2383 Fraise_frame (mini_frame
);
2386 obj
= read_filtered_event (1, 0, 0, 0);
2387 cursor_in_echo_area
= 0;
2388 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2391 key
= Fmake_vector (make_number (1), obj
);
2392 def
= Flookup_key (map
, key
, Qt
);
2394 if (EQ (def
, intern ("skip")))
2399 else if (EQ (def
, intern ("act")))
2404 else if (EQ (def
, intern ("recenter")))
2410 else if (EQ (def
, intern ("quit")))
2412 /* We want to exit this command for exit-prefix,
2413 and this is the only way to do it. */
2414 else if (EQ (def
, intern ("exit-prefix")))
2419 /* If we don't clear this, then the next call to read_char will
2420 return quit_char again, and we'll enter an infinite loop. */
2425 if (EQ (xprompt
, prompt
))
2427 args
[0] = build_string ("Please answer y or n. ");
2429 xprompt
= Fconcat (2, args
);
2434 if (! noninteractive
)
2436 cursor_in_echo_area
= -1;
2437 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2441 unbind_to (count
, Qnil
);
2442 return answer
? Qt
: Qnil
;
2445 /* This is how C code calls `yes-or-no-p' and allows the user
2448 Anything that calls this function must protect from GC! */
2451 do_yes_or_no_p (prompt
)
2454 return call1 (intern ("yes-or-no-p"), prompt
);
2457 /* Anything that calls this function must protect from GC! */
2459 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2460 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2461 Takes one argument, which is the string to display to ask the question.
2462 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2463 The user must confirm the answer with RET,
2464 and can edit it until it has been confirmed.
2466 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2467 is nil, and `use-dialog-box' is non-nil. */)
2471 register Lisp_Object ans
;
2472 Lisp_Object args
[2];
2473 struct gcpro gcpro1
;
2475 CHECK_STRING (prompt
);
2478 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2482 Lisp_Object pane
, menu
, obj
;
2483 redisplay_preserve_echo_area (4);
2484 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2485 Fcons (Fcons (build_string ("No"), Qnil
),
2488 menu
= Fcons (prompt
, pane
);
2489 obj
= Fx_popup_dialog (Qt
, menu
);
2493 #endif /* HAVE_MENUS */
2496 args
[1] = build_string ("(yes or no) ");
2497 prompt
= Fconcat (2, args
);
2503 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2504 Qyes_or_no_p_history
, Qnil
,
2506 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2511 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2519 message ("Please answer yes or no.");
2520 Fsleep_for (make_number (2), Qnil
);
2524 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2525 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2527 Each of the three load averages is multiplied by 100, then converted
2530 When USE-FLOATS is non-nil, floats will be used instead of integers.
2531 These floats are not multiplied by 100.
2533 If the 5-minute or 15-minute load averages are not available, return a
2534 shortened list, containing only those averages which are available. */)
2536 Lisp_Object use_floats
;
2539 int loads
= getloadavg (load_ave
, 3);
2540 Lisp_Object ret
= Qnil
;
2543 error ("load-average not implemented for this operating system");
2547 Lisp_Object load
= (NILP (use_floats
) ?
2548 make_number ((int) (100.0 * load_ave
[loads
]))
2549 : make_float (load_ave
[loads
]));
2550 ret
= Fcons (load
, ret
);
2556 Lisp_Object Vfeatures
, Qsubfeatures
;
2557 extern Lisp_Object Vafter_load_alist
;
2559 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2560 doc
: /* Returns t if FEATURE is present in this Emacs.
2562 Use this to conditionalize execution of lisp code based on the
2563 presence or absence of emacs or environment extensions.
2564 Use `provide' to declare that a feature is available. This function
2565 looks at the value of the variable `features'. The optional argument
2566 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2567 (feature
, subfeature
)
2568 Lisp_Object feature
, subfeature
;
2570 register Lisp_Object tem
;
2571 CHECK_SYMBOL (feature
);
2572 tem
= Fmemq (feature
, Vfeatures
);
2573 if (!NILP (tem
) && !NILP (subfeature
))
2574 tem
= Fmemq (subfeature
, Fget (feature
, Qsubfeatures
));
2575 return (NILP (tem
)) ? Qnil
: Qt
;
2578 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2579 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2580 The optional argument SUBFEATURES should be a list of symbols listing
2581 particular subfeatures supported in this version of FEATURE. */)
2582 (feature
, subfeatures
)
2583 Lisp_Object feature
, subfeatures
;
2585 register Lisp_Object tem
;
2586 CHECK_SYMBOL (feature
);
2587 if (!NILP (Vautoload_queue
))
2588 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2589 tem
= Fmemq (feature
, Vfeatures
);
2591 Vfeatures
= Fcons (feature
, Vfeatures
);
2592 if (!NILP (subfeatures
))
2593 Fput (feature
, Qsubfeatures
, subfeatures
);
2594 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2596 /* Run any load-hooks for this file. */
2597 tem
= Fassq (feature
, Vafter_load_alist
);
2599 Fprogn (Fcdr (tem
));
2604 /* `require' and its subroutines. */
2606 /* List of features currently being require'd, innermost first. */
2608 Lisp_Object require_nesting_list
;
2611 require_unwind (old_value
)
2612 Lisp_Object old_value
;
2614 return require_nesting_list
= old_value
;
2617 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2618 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2619 If FEATURE is not a member of the list `features', then the feature
2620 is not loaded; so load the file FILENAME.
2621 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2622 and `load' will try to load this name appended with the suffix `.elc',
2623 `.el' or the unmodified name, in that order.
2624 If the optional third argument NOERROR is non-nil,
2625 then return nil if the file is not found instead of signaling an error.
2626 Normally the return value is FEATURE.
2627 The normal messages at start and end of loading FILENAME are suppressed. */)
2628 (feature
, filename
, noerror
)
2629 Lisp_Object feature
, filename
, noerror
;
2631 register Lisp_Object tem
;
2632 struct gcpro gcpro1
, gcpro2
;
2634 CHECK_SYMBOL (feature
);
2636 tem
= Fmemq (feature
, Vfeatures
);
2638 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2642 int count
= specpdl_ptr
- specpdl
;
2645 /* A certain amount of recursive `require' is legitimate,
2646 but if we require the same feature recursively 3 times,
2648 tem
= require_nesting_list
;
2649 while (! NILP (tem
))
2651 if (! NILP (Fequal (feature
, XCAR (tem
))))
2656 error ("Recursive `require' for feature `%s'",
2657 XSYMBOL (feature
)->name
->data
);
2659 /* Update the list for any nested `require's that occur. */
2660 record_unwind_protect (require_unwind
, require_nesting_list
);
2661 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2663 /* Value saved here is to be restored into Vautoload_queue */
2664 record_unwind_protect (un_autoload
, Vautoload_queue
);
2665 Vautoload_queue
= Qt
;
2667 /* Load the file. */
2668 GCPRO2 (feature
, filename
);
2669 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2670 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2673 /* If load failed entirely, return nil. */
2675 return unbind_to (count
, Qnil
);
2677 tem
= Fmemq (feature
, Vfeatures
);
2679 error ("Required feature `%s' was not provided",
2680 XSYMBOL (feature
)->name
->data
);
2682 /* Once loading finishes, don't undo it. */
2683 Vautoload_queue
= Qt
;
2684 feature
= unbind_to (count
, feature
);
2690 /* Primitives for work of the "widget" library.
2691 In an ideal world, this section would not have been necessary.
2692 However, lisp function calls being as slow as they are, it turns
2693 out that some functions in the widget library (wid-edit.el) are the
2694 bottleneck of Widget operation. Here is their translation to C,
2695 for the sole reason of efficiency. */
2697 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2698 doc
: /* Return non-nil if PLIST has the property PROP.
2699 PLIST is a property list, which is a list of the form
2700 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2701 Unlike `plist-get', this allows you to distinguish between a missing
2702 property and a property with the value nil.
2703 The value is actually the tail of PLIST whose car is PROP. */)
2705 Lisp_Object plist
, prop
;
2707 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2710 plist
= XCDR (plist
);
2711 plist
= CDR (plist
);
2716 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2717 doc
: /* In WIDGET, set PROPERTY to VALUE.
2718 The value can later be retrieved with `widget-get'. */)
2719 (widget
, property
, value
)
2720 Lisp_Object widget
, property
, value
;
2722 CHECK_CONS (widget
);
2723 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2727 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2728 doc
: /* In WIDGET, get the value of PROPERTY.
2729 The value could either be specified when the widget was created, or
2730 later with `widget-put'. */)
2732 Lisp_Object widget
, property
;
2740 CHECK_CONS (widget
);
2741 tmp
= Fplist_member (XCDR (widget
), property
);
2747 tmp
= XCAR (widget
);
2750 widget
= Fget (tmp
, Qwidget_type
);
2754 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2755 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2756 ARGS are passed as extra arguments to the function.
2757 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2762 /* This function can GC. */
2763 Lisp_Object newargs
[3];
2764 struct gcpro gcpro1
, gcpro2
;
2767 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2768 newargs
[1] = args
[0];
2769 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2770 GCPRO2 (newargs
[0], newargs
[2]);
2771 result
= Fapply (3, newargs
);
2776 #ifdef HAVE_LANGINFO_CODESET
2777 #include <langinfo.h>
2780 DEFUN ("langinfo", Flanginfo
, Slanginfo
, 1, 1, 0,
2781 doc
: /* Access locale category ITEM, if available.
2783 ITEM may be one of the following:
2784 `codeset', returning the character set as a string (CODESET);
2785 `days', returning a 7-element vector of day names (DAY_n);
2786 `months', returning a 12-element vector of month names (MON_n).
2788 If the system can't provide such information through a call to
2789 nl_langinfo(3), return nil. */)
2794 #ifdef HAVE_LANGINFO_CODESET
2796 if (EQ (item
, Qcodeset
))
2797 str
= nl_langinfo (CODESET
);
2799 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2801 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2802 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2804 synchronize_system_time_locale ();
2805 for (i
= 0; i
< 7; i
++)
2807 str
= nl_langinfo (days
[i
]);
2808 Faset (v
, make_number (i
),
2809 code_convert_string (make_unibyte_string (str
, strlen (str
)),
2810 Vlocale_coding_system
, Qnil
, 0, 0, 1));
2816 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2818 struct Lisp_Vector
*p
= allocate_vector (12);
2819 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2820 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2822 synchronize_system_time_locale ();
2823 for (i
= 0; i
< 12; i
++)
2825 str
= nl_langinfo (months
[i
]);
2827 code_convert_string (make_unibyte_string (str
, strlen (str
)),
2828 Vlocale_coding_system
, Qnil
, 0, 0, 1);
2830 XSETVECTOR (val
, p
);
2836 return build_string (str
);
2841 /* base64 encode/decode functions (RFC 2045).
2842 Based on code from GNU recode. */
2844 #define MIME_LINE_LENGTH 76
2846 #define IS_ASCII(Character) \
2848 #define IS_BASE64(Character) \
2849 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2850 #define IS_BASE64_IGNORABLE(Character) \
2851 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2852 || (Character) == '\f' || (Character) == '\r')
2854 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2855 character or return retval if there are no characters left to
2857 #define READ_QUADRUPLET_BYTE(retval) \
2862 if (nchars_return) \
2863 *nchars_return = nchars; \
2868 while (IS_BASE64_IGNORABLE (c))
2870 /* Don't use alloca for regions larger than this, lest we overflow
2872 #define MAX_ALLOCA 16*1024
2874 /* Table of characters coding the 64 values. */
2875 static char base64_value_to_char
[64] =
2877 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2878 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2879 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2880 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2881 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2882 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2883 '8', '9', '+', '/' /* 60-63 */
2886 /* Table of base64 values for first 128 characters. */
2887 static short base64_char_to_value
[128] =
2889 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2890 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2891 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2892 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2893 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2894 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2895 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2896 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2897 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2898 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2899 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2900 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2901 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2904 /* The following diagram shows the logical steps by which three octets
2905 get transformed into four base64 characters.
2907 .--------. .--------. .--------.
2908 |aaaaaabb| |bbbbcccc| |ccdddddd|
2909 `--------' `--------' `--------'
2911 .--------+--------+--------+--------.
2912 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2913 `--------+--------+--------+--------'
2915 .--------+--------+--------+--------.
2916 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2917 `--------+--------+--------+--------'
2919 The octets are divided into 6 bit chunks, which are then encoded into
2920 base64 characters. */
2923 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
2924 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
2926 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2928 doc
: /* Base64-encode the region between BEG and END.
2929 Return the length of the encoded text.
2930 Optional third argument NO-LINE-BREAK means do not break long lines
2931 into shorter lines. */)
2932 (beg
, end
, no_line_break
)
2933 Lisp_Object beg
, end
, no_line_break
;
2936 int allength
, length
;
2937 int ibeg
, iend
, encoded_length
;
2940 validate_region (&beg
, &end
);
2942 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2943 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2944 move_gap_both (XFASTINT (beg
), ibeg
);
2946 /* We need to allocate enough room for encoding the text.
2947 We need 33 1/3% more space, plus a newline every 76
2948 characters, and then we round up. */
2949 length
= iend
- ibeg
;
2950 allength
= length
+ length
/3 + 1;
2951 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2953 if (allength
<= MAX_ALLOCA
)
2954 encoded
= (char *) alloca (allength
);
2956 encoded
= (char *) xmalloc (allength
);
2957 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2958 NILP (no_line_break
),
2959 !NILP (current_buffer
->enable_multibyte_characters
));
2960 if (encoded_length
> allength
)
2963 if (encoded_length
< 0)
2965 /* The encoding wasn't possible. */
2966 if (length
> MAX_ALLOCA
)
2968 error ("Multibyte character in data for base64 encoding");
2971 /* Now we have encoded the region, so we insert the new contents
2972 and delete the old. (Insert first in order to preserve markers.) */
2973 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2974 insert (encoded
, encoded_length
);
2975 if (allength
> MAX_ALLOCA
)
2977 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2979 /* If point was outside of the region, restore it exactly; else just
2980 move to the beginning of the region. */
2981 if (old_pos
>= XFASTINT (end
))
2982 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2983 else if (old_pos
> XFASTINT (beg
))
2984 old_pos
= XFASTINT (beg
);
2987 /* We return the length of the encoded text. */
2988 return make_number (encoded_length
);
2991 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2993 doc
: /* Base64-encode STRING and return the result.
2994 Optional second argument NO-LINE-BREAK means do not break long lines
2995 into shorter lines. */)
2996 (string
, no_line_break
)
2997 Lisp_Object string
, no_line_break
;
2999 int allength
, length
, encoded_length
;
3001 Lisp_Object encoded_string
;
3003 CHECK_STRING (string
);
3005 /* We need to allocate enough room for encoding the text.
3006 We need 33 1/3% more space, plus a newline every 76
3007 characters, and then we round up. */
3008 length
= STRING_BYTES (XSTRING (string
));
3009 allength
= length
+ length
/3 + 1;
3010 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3012 /* We need to allocate enough room for decoding the text. */
3013 if (allength
<= MAX_ALLOCA
)
3014 encoded
= (char *) alloca (allength
);
3016 encoded
= (char *) xmalloc (allength
);
3018 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3019 encoded
, length
, NILP (no_line_break
),
3020 STRING_MULTIBYTE (string
));
3021 if (encoded_length
> allength
)
3024 if (encoded_length
< 0)
3026 /* The encoding wasn't possible. */
3027 if (length
> MAX_ALLOCA
)
3029 error ("Multibyte character in data for base64 encoding");
3032 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3033 if (allength
> MAX_ALLOCA
)
3036 return encoded_string
;
3040 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3047 int counter
= 0, i
= 0;
3057 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3058 if (CHAR_BYTE8_P (c
))
3059 c
= CHAR_TO_BYTE8 (c
);
3067 /* Wrap line every 76 characters. */
3071 if (counter
< MIME_LINE_LENGTH
/ 4)
3080 /* Process first byte of a triplet. */
3082 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3083 value
= (0x03 & c
) << 4;
3085 /* Process second byte of a triplet. */
3089 *e
++ = base64_value_to_char
[value
];
3097 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3098 if (CHAR_BYTE8_P (c
))
3099 c
= CHAR_TO_BYTE8 (c
);
3107 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3108 value
= (0x0f & c
) << 2;
3110 /* Process third byte of a triplet. */
3114 *e
++ = base64_value_to_char
[value
];
3121 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3122 if (CHAR_BYTE8_P (c
))
3123 c
= CHAR_TO_BYTE8 (c
);
3131 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3132 *e
++ = base64_value_to_char
[0x3f & c
];
3139 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3141 doc
: /* Base64-decode the region between BEG and END.
3142 Return the length of the decoded text.
3143 If the region can't be decoded, signal an error and don't modify the buffer. */)
3145 Lisp_Object beg
, end
;
3147 int ibeg
, iend
, length
, allength
;
3152 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3154 validate_region (&beg
, &end
);
3156 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3157 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3159 length
= iend
- ibeg
;
3161 /* We need to allocate enough room for decoding the text. If we are
3162 working on a multibyte buffer, each decoded code may occupy at
3164 allength
= multibyte
? length
* 2 : length
;
3165 if (allength
<= MAX_ALLOCA
)
3166 decoded
= (char *) alloca (allength
);
3168 decoded
= (char *) xmalloc (allength
);
3170 move_gap_both (XFASTINT (beg
), ibeg
);
3171 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3172 multibyte
, &inserted_chars
);
3173 if (decoded_length
> allength
)
3176 if (decoded_length
< 0)
3178 /* The decoding wasn't possible. */
3179 if (allength
> MAX_ALLOCA
)
3181 error ("Invalid base64 data");
3184 /* Now we have decoded the region, so we insert the new contents
3185 and delete the old. (Insert first in order to preserve markers.) */
3186 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3187 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3188 if (allength
> MAX_ALLOCA
)
3190 /* Delete the original text. */
3191 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3192 iend
+ decoded_length
, 1);
3194 /* If point was outside of the region, restore it exactly; else just
3195 move to the beginning of the region. */
3196 if (old_pos
>= XFASTINT (end
))
3197 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3198 else if (old_pos
> XFASTINT (beg
))
3199 old_pos
= XFASTINT (beg
);
3200 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3202 return make_number (inserted_chars
);
3205 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3207 doc
: /* Base64-decode STRING and return the result. */)
3212 int length
, decoded_length
;
3213 Lisp_Object decoded_string
;
3215 CHECK_STRING (string
);
3217 length
= STRING_BYTES (XSTRING (string
));
3218 /* We need to allocate enough room for decoding the text. */
3219 if (length
<= MAX_ALLOCA
)
3220 decoded
= (char *) alloca (length
);
3222 decoded
= (char *) xmalloc (length
);
3224 /* The decoded result should be unibyte. */
3225 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3227 if (decoded_length
> length
)
3229 else if (decoded_length
>= 0)
3230 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3232 decoded_string
= Qnil
;
3234 if (length
> MAX_ALLOCA
)
3236 if (!STRINGP (decoded_string
))
3237 error ("Invalid base64 data");
3239 return decoded_string
;
3242 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3243 MULTIBYTE is nonzero, the decoded result should be in multibyte
3244 form. If NCHARS_RETRUN is not NULL, store the number of produced
3245 characters in *NCHARS_RETURN. */
3248 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3258 unsigned long value
;
3263 /* Process first byte of a quadruplet. */
3265 READ_QUADRUPLET_BYTE (e
-to
);
3269 value
= base64_char_to_value
[c
] << 18;
3271 /* Process second byte of a quadruplet. */
3273 READ_QUADRUPLET_BYTE (-1);
3277 value
|= base64_char_to_value
[c
] << 12;
3279 c
= (unsigned char) (value
>> 16);
3280 if (multibyte
&& c
>= 128)
3281 e
+= BYTE8_STRING (c
, e
);
3286 /* Process third byte of a quadruplet. */
3288 READ_QUADRUPLET_BYTE (-1);
3292 READ_QUADRUPLET_BYTE (-1);
3301 value
|= base64_char_to_value
[c
] << 6;
3303 c
= (unsigned char) (0xff & value
>> 8);
3304 if (multibyte
&& c
>= 128)
3305 e
+= BYTE8_STRING (c
, e
);
3310 /* Process fourth byte of a quadruplet. */
3312 READ_QUADRUPLET_BYTE (-1);
3319 value
|= base64_char_to_value
[c
];
3321 c
= (unsigned char) (0xff & value
);
3322 if (multibyte
&& c
>= 128)
3323 e
+= BYTE8_STRING (c
, e
);
3332 /***********************************************************************
3334 ***** Hash Tables *****
3336 ***********************************************************************/
3338 /* Implemented by gerd@gnu.org. This hash table implementation was
3339 inspired by CMUCL hash tables. */
3343 1. For small tables, association lists are probably faster than
3344 hash tables because they have lower overhead.
3346 For uses of hash tables where the O(1) behavior of table
3347 operations is not a requirement, it might therefore be a good idea
3348 not to hash. Instead, we could just do a linear search in the
3349 key_and_value vector of the hash table. This could be done
3350 if a `:linear-search t' argument is given to make-hash-table. */
3353 /* Value is the index of the next entry following the one at IDX
3356 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3358 /* Value is the hash code computed for entry IDX in hash table H. */
3360 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3362 /* Value is the index of the element in hash table H that is the
3363 start of the collision list at index IDX in the index vector of H. */
3365 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3367 /* Value is the size of hash table H. */
3369 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3371 /* The list of all weak hash tables. Don't staticpro this one. */
3373 Lisp_Object Vweak_hash_tables
;
3375 /* Various symbols. */
3377 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3378 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3379 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3381 /* Function prototypes. */
3383 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3384 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3385 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3386 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3387 Lisp_Object
, unsigned));
3388 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3389 Lisp_Object
, unsigned));
3390 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3391 unsigned, Lisp_Object
, unsigned));
3392 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3393 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3394 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3395 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3397 static unsigned sxhash_string
P_ ((unsigned char *, int));
3398 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3399 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3400 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3401 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3405 /***********************************************************************
3407 ***********************************************************************/
3409 /* If OBJ is a Lisp hash table, return a pointer to its struct
3410 Lisp_Hash_Table. Otherwise, signal an error. */
3412 static struct Lisp_Hash_Table
*
3413 check_hash_table (obj
)
3416 CHECK_HASH_TABLE (obj
);
3417 return XHASH_TABLE (obj
);
3421 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3425 next_almost_prime (n
)
3438 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3439 which USED[I] is non-zero. If found at index I in ARGS, set
3440 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3441 -1. This function is used to extract a keyword/argument pair from
3442 a DEFUN parameter list. */
3445 get_key_arg (key
, nargs
, args
, used
)
3453 for (i
= 0; i
< nargs
- 1; ++i
)
3454 if (!used
[i
] && EQ (args
[i
], key
))
3469 /* Return a Lisp vector which has the same contents as VEC but has
3470 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3471 vector that are not copied from VEC are set to INIT. */
3474 larger_vector (vec
, new_size
, init
)
3479 struct Lisp_Vector
*v
;
3482 xassert (VECTORP (vec
));
3483 old_size
= XVECTOR (vec
)->size
;
3484 xassert (new_size
>= old_size
);
3486 v
= allocate_vector (new_size
);
3487 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3488 old_size
* sizeof *v
->contents
);
3489 for (i
= old_size
; i
< new_size
; ++i
)
3490 v
->contents
[i
] = init
;
3491 XSETVECTOR (vec
, v
);
3496 /***********************************************************************
3498 ***********************************************************************/
3500 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3501 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3502 KEY2 are the same. */
3505 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3506 struct Lisp_Hash_Table
*h
;
3507 Lisp_Object key1
, key2
;
3508 unsigned hash1
, hash2
;
3510 return (FLOATP (key1
)
3512 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3516 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3517 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3518 KEY2 are the same. */
3521 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3522 struct Lisp_Hash_Table
*h
;
3523 Lisp_Object key1
, key2
;
3524 unsigned hash1
, hash2
;
3526 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3530 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3531 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3532 if KEY1 and KEY2 are the same. */
3535 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3536 struct Lisp_Hash_Table
*h
;
3537 Lisp_Object key1
, key2
;
3538 unsigned hash1
, hash2
;
3542 Lisp_Object args
[3];
3544 args
[0] = h
->user_cmp_function
;
3547 return !NILP (Ffuncall (3, args
));
3554 /* Value is a hash code for KEY for use in hash table H which uses
3555 `eq' to compare keys. The hash code returned is guaranteed to fit
3556 in a Lisp integer. */
3560 struct Lisp_Hash_Table
*h
;
3563 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3564 xassert ((hash
& ~VALMASK
) == 0);
3569 /* Value is a hash code for KEY for use in hash table H which uses
3570 `eql' to compare keys. The hash code returned is guaranteed to fit
3571 in a Lisp integer. */
3575 struct Lisp_Hash_Table
*h
;
3580 hash
= sxhash (key
, 0);
3582 hash
= XUINT (key
) ^ XGCTYPE (key
);
3583 xassert ((hash
& ~VALMASK
) == 0);
3588 /* Value is a hash code for KEY for use in hash table H which uses
3589 `equal' to compare keys. The hash code returned is guaranteed to fit
3590 in a Lisp integer. */
3593 hashfn_equal (h
, key
)
3594 struct Lisp_Hash_Table
*h
;
3597 unsigned hash
= sxhash (key
, 0);
3598 xassert ((hash
& ~VALMASK
) == 0);
3603 /* Value is a hash code for KEY for use in hash table H which uses as
3604 user-defined function to compare keys. The hash code returned is
3605 guaranteed to fit in a Lisp integer. */
3608 hashfn_user_defined (h
, key
)
3609 struct Lisp_Hash_Table
*h
;
3612 Lisp_Object args
[2], hash
;
3614 args
[0] = h
->user_hash_function
;
3616 hash
= Ffuncall (2, args
);
3617 if (!INTEGERP (hash
))
3619 list2 (build_string ("Invalid hash code returned from \
3620 user-supplied hash function"),
3622 return XUINT (hash
);
3626 /* Create and initialize a new hash table.
3628 TEST specifies the test the hash table will use to compare keys.
3629 It must be either one of the predefined tests `eq', `eql' or
3630 `equal' or a symbol denoting a user-defined test named TEST with
3631 test and hash functions USER_TEST and USER_HASH.
3633 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3635 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3636 new size when it becomes full is computed by adding REHASH_SIZE to
3637 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3638 table's new size is computed by multiplying its old size with
3641 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3642 be resized when the ratio of (number of entries in the table) /
3643 (table size) is >= REHASH_THRESHOLD.
3645 WEAK specifies the weakness of the table. If non-nil, it must be
3646 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3649 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3650 user_test
, user_hash
)
3651 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3652 Lisp_Object user_test
, user_hash
;
3654 struct Lisp_Hash_Table
*h
;
3656 int index_size
, i
, sz
;
3658 /* Preconditions. */
3659 xassert (SYMBOLP (test
));
3660 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3661 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3662 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3663 xassert (FLOATP (rehash_threshold
)
3664 && XFLOATINT (rehash_threshold
) > 0
3665 && XFLOATINT (rehash_threshold
) <= 1.0);
3667 if (XFASTINT (size
) == 0)
3668 size
= make_number (1);
3670 /* Allocate a table and initialize it. */
3671 h
= allocate_hash_table ();
3673 /* Initialize hash table slots. */
3674 sz
= XFASTINT (size
);
3677 if (EQ (test
, Qeql
))
3679 h
->cmpfn
= cmpfn_eql
;
3680 h
->hashfn
= hashfn_eql
;
3682 else if (EQ (test
, Qeq
))
3685 h
->hashfn
= hashfn_eq
;
3687 else if (EQ (test
, Qequal
))
3689 h
->cmpfn
= cmpfn_equal
;
3690 h
->hashfn
= hashfn_equal
;
3694 h
->user_cmp_function
= user_test
;
3695 h
->user_hash_function
= user_hash
;
3696 h
->cmpfn
= cmpfn_user_defined
;
3697 h
->hashfn
= hashfn_user_defined
;
3701 h
->rehash_threshold
= rehash_threshold
;
3702 h
->rehash_size
= rehash_size
;
3703 h
->count
= make_number (0);
3704 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3705 h
->hash
= Fmake_vector (size
, Qnil
);
3706 h
->next
= Fmake_vector (size
, Qnil
);
3707 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3708 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3709 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3711 /* Set up the free list. */
3712 for (i
= 0; i
< sz
- 1; ++i
)
3713 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3714 h
->next_free
= make_number (0);
3716 XSET_HASH_TABLE (table
, h
);
3717 xassert (HASH_TABLE_P (table
));
3718 xassert (XHASH_TABLE (table
) == h
);
3720 /* Maybe add this hash table to the list of all weak hash tables. */
3722 h
->next_weak
= Qnil
;
3725 h
->next_weak
= Vweak_hash_tables
;
3726 Vweak_hash_tables
= table
;
3733 /* Return a copy of hash table H1. Keys and values are not copied,
3734 only the table itself is. */
3737 copy_hash_table (h1
)
3738 struct Lisp_Hash_Table
*h1
;
3741 struct Lisp_Hash_Table
*h2
;
3742 struct Lisp_Vector
*next
;
3744 h2
= allocate_hash_table ();
3745 next
= h2
->vec_next
;
3746 bcopy (h1
, h2
, sizeof *h2
);
3747 h2
->vec_next
= next
;
3748 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3749 h2
->hash
= Fcopy_sequence (h1
->hash
);
3750 h2
->next
= Fcopy_sequence (h1
->next
);
3751 h2
->index
= Fcopy_sequence (h1
->index
);
3752 XSET_HASH_TABLE (table
, h2
);
3754 /* Maybe add this hash table to the list of all weak hash tables. */
3755 if (!NILP (h2
->weak
))
3757 h2
->next_weak
= Vweak_hash_tables
;
3758 Vweak_hash_tables
= table
;
3765 /* Resize hash table H if it's too full. If H cannot be resized
3766 because it's already too large, throw an error. */
3769 maybe_resize_hash_table (h
)
3770 struct Lisp_Hash_Table
*h
;
3772 if (NILP (h
->next_free
))
3774 int old_size
= HASH_TABLE_SIZE (h
);
3775 int i
, new_size
, index_size
;
3777 if (INTEGERP (h
->rehash_size
))
3778 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3780 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3781 new_size
= max (old_size
+ 1, new_size
);
3782 index_size
= next_almost_prime ((int)
3784 / XFLOATINT (h
->rehash_threshold
)));
3785 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3786 error ("Hash table too large to resize");
3788 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3789 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3790 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3791 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3793 /* Update the free list. Do it so that new entries are added at
3794 the end of the free list. This makes some operations like
3796 for (i
= old_size
; i
< new_size
- 1; ++i
)
3797 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3799 if (!NILP (h
->next_free
))
3801 Lisp_Object last
, next
;
3803 last
= h
->next_free
;
3804 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3808 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3811 XSETFASTINT (h
->next_free
, old_size
);
3814 for (i
= 0; i
< old_size
; ++i
)
3815 if (!NILP (HASH_HASH (h
, i
)))
3817 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3818 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3819 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3820 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3826 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3827 the hash code of KEY. Value is the index of the entry in H
3828 matching KEY, or -1 if not found. */
3831 hash_lookup (h
, key
, hash
)
3832 struct Lisp_Hash_Table
*h
;
3837 int start_of_bucket
;
3840 hash_code
= h
->hashfn (h
, key
);
3844 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3845 idx
= HASH_INDEX (h
, start_of_bucket
);
3847 /* We need not gcpro idx since it's either an integer or nil. */
3850 int i
= XFASTINT (idx
);
3851 if (EQ (key
, HASH_KEY (h
, i
))
3853 && h
->cmpfn (h
, key
, hash_code
,
3854 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3856 idx
= HASH_NEXT (h
, i
);
3859 return NILP (idx
) ? -1 : XFASTINT (idx
);
3863 /* Put an entry into hash table H that associates KEY with VALUE.
3864 HASH is a previously computed hash code of KEY.
3865 Value is the index of the entry in H matching KEY. */
3868 hash_put (h
, key
, value
, hash
)
3869 struct Lisp_Hash_Table
*h
;
3870 Lisp_Object key
, value
;
3873 int start_of_bucket
, i
;
3875 xassert ((hash
& ~VALMASK
) == 0);
3877 /* Increment count after resizing because resizing may fail. */
3878 maybe_resize_hash_table (h
);
3879 h
->count
= make_number (XFASTINT (h
->count
) + 1);
3881 /* Store key/value in the key_and_value vector. */
3882 i
= XFASTINT (h
->next_free
);
3883 h
->next_free
= HASH_NEXT (h
, i
);
3884 HASH_KEY (h
, i
) = key
;
3885 HASH_VALUE (h
, i
) = value
;
3887 /* Remember its hash code. */
3888 HASH_HASH (h
, i
) = make_number (hash
);
3890 /* Add new entry to its collision chain. */
3891 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
3892 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3893 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3898 /* Remove the entry matching KEY from hash table H, if there is one. */
3901 hash_remove (h
, key
)
3902 struct Lisp_Hash_Table
*h
;
3906 int start_of_bucket
;
3907 Lisp_Object idx
, prev
;
3909 hash_code
= h
->hashfn (h
, key
);
3910 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3911 idx
= HASH_INDEX (h
, start_of_bucket
);
3914 /* We need not gcpro idx, prev since they're either integers or nil. */
3917 int i
= XFASTINT (idx
);
3919 if (EQ (key
, HASH_KEY (h
, i
))
3921 && h
->cmpfn (h
, key
, hash_code
,
3922 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3924 /* Take entry out of collision chain. */
3926 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3928 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3930 /* Clear slots in key_and_value and add the slots to
3932 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3933 HASH_NEXT (h
, i
) = h
->next_free
;
3934 h
->next_free
= make_number (i
);
3935 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3936 xassert (XINT (h
->count
) >= 0);
3942 idx
= HASH_NEXT (h
, i
);
3948 /* Clear hash table H. */
3952 struct Lisp_Hash_Table
*h
;
3954 if (XFASTINT (h
->count
) > 0)
3956 int i
, size
= HASH_TABLE_SIZE (h
);
3958 for (i
= 0; i
< size
; ++i
)
3960 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3961 HASH_KEY (h
, i
) = Qnil
;
3962 HASH_VALUE (h
, i
) = Qnil
;
3963 HASH_HASH (h
, i
) = Qnil
;
3966 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
3967 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
3969 h
->next_free
= make_number (0);
3970 h
->count
= make_number (0);
3976 /************************************************************************
3978 ************************************************************************/
3980 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3981 entries from the table that don't survive the current GC.
3982 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3983 non-zero if anything was marked. */
3986 sweep_weak_table (h
, remove_entries_p
)
3987 struct Lisp_Hash_Table
*h
;
3988 int remove_entries_p
;
3990 int bucket
, n
, marked
;
3992 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
3995 for (bucket
= 0; bucket
< n
; ++bucket
)
3997 Lisp_Object idx
, next
, prev
;
3999 /* Follow collision chain, removing entries that
4000 don't survive this garbage collection. */
4002 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4004 int i
= XFASTINT (idx
);
4005 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4006 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4009 if (EQ (h
->weak
, Qkey
))
4010 remove_p
= !key_known_to_survive_p
;
4011 else if (EQ (h
->weak
, Qvalue
))
4012 remove_p
= !value_known_to_survive_p
;
4013 else if (EQ (h
->weak
, Qkey_or_value
))
4014 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4015 else if (EQ (h
->weak
, Qkey_and_value
))
4016 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4020 next
= HASH_NEXT (h
, i
);
4022 if (remove_entries_p
)
4026 /* Take out of collision chain. */
4028 HASH_INDEX (h
, bucket
) = next
;
4030 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4032 /* Add to free list. */
4033 HASH_NEXT (h
, i
) = h
->next_free
;
4036 /* Clear key, value, and hash. */
4037 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4038 HASH_HASH (h
, i
) = Qnil
;
4040 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4047 /* Make sure key and value survive. */
4048 if (!key_known_to_survive_p
)
4050 mark_object (&HASH_KEY (h
, i
));
4054 if (!value_known_to_survive_p
)
4056 mark_object (&HASH_VALUE (h
, i
));
4067 /* Remove elements from weak hash tables that don't survive the
4068 current garbage collection. Remove weak tables that don't survive
4069 from Vweak_hash_tables. Called from gc_sweep. */
4072 sweep_weak_hash_tables ()
4074 Lisp_Object table
, used
, next
;
4075 struct Lisp_Hash_Table
*h
;
4078 /* Mark all keys and values that are in use. Keep on marking until
4079 there is no more change. This is necessary for cases like
4080 value-weak table A containing an entry X -> Y, where Y is used in a
4081 key-weak table B, Z -> Y. If B comes after A in the list of weak
4082 tables, X -> Y might be removed from A, although when looking at B
4083 one finds that it shouldn't. */
4087 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4089 h
= XHASH_TABLE (table
);
4090 if (h
->size
& ARRAY_MARK_FLAG
)
4091 marked
|= sweep_weak_table (h
, 0);
4096 /* Remove tables and entries that aren't used. */
4097 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4099 h
= XHASH_TABLE (table
);
4100 next
= h
->next_weak
;
4102 if (h
->size
& ARRAY_MARK_FLAG
)
4104 /* TABLE is marked as used. Sweep its contents. */
4105 if (XFASTINT (h
->count
) > 0)
4106 sweep_weak_table (h
, 1);
4108 /* Add table to the list of used weak hash tables. */
4109 h
->next_weak
= used
;
4114 Vweak_hash_tables
= used
;
4119 /***********************************************************************
4120 Hash Code Computation
4121 ***********************************************************************/
4123 /* Maximum depth up to which to dive into Lisp structures. */
4125 #define SXHASH_MAX_DEPTH 3
4127 /* Maximum length up to which to take list and vector elements into
4130 #define SXHASH_MAX_LEN 7
4132 /* Combine two integers X and Y for hashing. */
4134 #define SXHASH_COMBINE(X, Y) \
4135 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4139 /* Return a hash for string PTR which has length LEN. The hash
4140 code returned is guaranteed to fit in a Lisp integer. */
4143 sxhash_string (ptr
, len
)
4147 unsigned char *p
= ptr
;
4148 unsigned char *end
= p
+ len
;
4157 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4160 return hash
& VALMASK
;
4164 /* Return a hash for list LIST. DEPTH is the current depth in the
4165 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4168 sxhash_list (list
, depth
)
4175 if (depth
< SXHASH_MAX_DEPTH
)
4177 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4178 list
= XCDR (list
), ++i
)
4180 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4181 hash
= SXHASH_COMBINE (hash
, hash2
);
4188 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4189 the Lisp structure. */
4192 sxhash_vector (vec
, depth
)
4196 unsigned hash
= XVECTOR (vec
)->size
;
4199 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4200 for (i
= 0; i
< n
; ++i
)
4202 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4203 hash
= SXHASH_COMBINE (hash
, hash2
);
4210 /* Return a hash for bool-vector VECTOR. */
4213 sxhash_bool_vector (vec
)
4216 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4219 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4220 for (i
= 0; i
< n
; ++i
)
4221 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4227 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4228 structure. Value is an unsigned integer clipped to VALMASK. */
4237 if (depth
> SXHASH_MAX_DEPTH
)
4240 switch (XTYPE (obj
))
4247 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4248 XSYMBOL (obj
)->name
->size
);
4256 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4259 /* This can be everything from a vector to an overlay. */
4260 case Lisp_Vectorlike
:
4262 /* According to the CL HyperSpec, two arrays are equal only if
4263 they are `eq', except for strings and bit-vectors. In
4264 Emacs, this works differently. We have to compare element
4266 hash
= sxhash_vector (obj
, depth
);
4267 else if (BOOL_VECTOR_P (obj
))
4268 hash
= sxhash_bool_vector (obj
);
4270 /* Others are `equal' if they are `eq', so let's take their
4276 hash
= sxhash_list (obj
, depth
);
4281 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4282 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4283 for (hash
= 0; p
< e
; ++p
)
4284 hash
= SXHASH_COMBINE (hash
, *p
);
4292 return hash
& VALMASK
;
4297 /***********************************************************************
4299 ***********************************************************************/
4302 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4303 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4307 unsigned hash
= sxhash (obj
, 0);;
4308 return make_number (hash
);
4312 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4313 doc
: /* Create and return a new hash table.
4315 Arguments are specified as keyword/argument pairs. The following
4316 arguments are defined:
4318 :test TEST -- TEST must be a symbol that specifies how to compare
4319 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4320 `equal'. User-supplied test and hash functions can be specified via
4321 `define-hash-table-test'.
4323 :size SIZE -- A hint as to how many elements will be put in the table.
4326 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4327 fills up. If REHASH-SIZE is an integer, add that many space. If it
4328 is a float, it must be > 1.0, and the new size is computed by
4329 multiplying the old size with that factor. Default is 1.5.
4331 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4332 Resize the hash table when ratio of the number of entries in the
4333 table. Default is 0.8.
4335 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4336 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4337 returned is a weak table. Key/value pairs are removed from a weak
4338 hash table when there are no non-weak references pointing to their
4339 key, value, one of key or value, or both key and value, depending on
4340 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4343 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4348 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4349 Lisp_Object user_test
, user_hash
;
4353 /* The vector `used' is used to keep track of arguments that
4354 have been consumed. */
4355 used
= (char *) alloca (nargs
* sizeof *used
);
4356 bzero (used
, nargs
* sizeof *used
);
4358 /* See if there's a `:test TEST' among the arguments. */
4359 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4360 test
= i
< 0 ? Qeql
: args
[i
];
4361 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4363 /* See if it is a user-defined test. */
4366 prop
= Fget (test
, Qhash_table_test
);
4367 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4368 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4370 user_test
= XCAR (prop
);
4371 user_hash
= XCAR (XCDR (prop
));
4374 user_test
= user_hash
= Qnil
;
4376 /* See if there's a `:size SIZE' argument. */
4377 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4378 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4379 if (!INTEGERP (size
) || XINT (size
) < 0)
4381 list2 (build_string ("Invalid hash table size"),
4384 /* Look for `:rehash-size SIZE'. */
4385 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4386 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4387 if (!NUMBERP (rehash_size
)
4388 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4389 || XFLOATINT (rehash_size
) <= 1.0)
4391 list2 (build_string ("Invalid hash table rehash size"),
4394 /* Look for `:rehash-threshold THRESHOLD'. */
4395 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4396 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4397 if (!FLOATP (rehash_threshold
)
4398 || XFLOATINT (rehash_threshold
) <= 0.0
4399 || XFLOATINT (rehash_threshold
) > 1.0)
4401 list2 (build_string ("Invalid hash table rehash threshold"),
4404 /* Look for `:weakness WEAK'. */
4405 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4406 weak
= i
< 0 ? Qnil
: args
[i
];
4408 weak
= Qkey_and_value
;
4411 && !EQ (weak
, Qvalue
)
4412 && !EQ (weak
, Qkey_or_value
)
4413 && !EQ (weak
, Qkey_and_value
))
4414 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4417 /* Now, all args should have been used up, or there's a problem. */
4418 for (i
= 0; i
< nargs
; ++i
)
4421 list2 (build_string ("Invalid argument list"), args
[i
]));
4423 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4424 user_test
, user_hash
);
4428 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4429 doc
: /* Return a copy of hash table TABLE. */)
4433 return copy_hash_table (check_hash_table (table
));
4437 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4438 doc
: /* Create a new hash table.
4440 Optional first argument TEST specifies how to compare keys in the
4441 table. Predefined tests are `eq', `eql', and `equal'. Default is
4442 `eql'. New tests can be defined with `define-hash-table-test'. */)
4446 Lisp_Object args
[2];
4448 args
[1] = NILP (test
) ? Qeql
: test
;
4449 return Fmake_hash_table (2, args
);
4453 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4454 doc
: /* Return the number of elements in TABLE. */)
4458 return check_hash_table (table
)->count
;
4462 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4463 Shash_table_rehash_size
, 1, 1, 0,
4464 doc
: /* Return the current rehash size of TABLE. */)
4468 return check_hash_table (table
)->rehash_size
;
4472 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4473 Shash_table_rehash_threshold
, 1, 1, 0,
4474 doc
: /* Return the current rehash threshold of TABLE. */)
4478 return check_hash_table (table
)->rehash_threshold
;
4482 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4483 doc
: /* Return the size of TABLE.
4484 The size can be used as an argument to `make-hash-table' to create
4485 a hash table than can hold as many elements of TABLE holds
4486 without need for resizing. */)
4490 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4491 return make_number (HASH_TABLE_SIZE (h
));
4495 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4496 doc
: /* Return the test TABLE uses. */)
4500 return check_hash_table (table
)->test
;
4504 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4506 doc
: /* Return the weakness of TABLE. */)
4510 return check_hash_table (table
)->weak
;
4514 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4515 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4519 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4523 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4524 doc
: /* Clear hash table TABLE. */)
4528 hash_clear (check_hash_table (table
));
4533 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4534 doc
: /* Look up KEY in TABLE and return its associated value.
4535 If KEY is not found, return DFLT which defaults to nil. */)
4537 Lisp_Object key
, table
, dflt
;
4539 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4540 int i
= hash_lookup (h
, key
, NULL
);
4541 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4545 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4546 doc
: /* Associate KEY with VALUE in hash table TABLE.
4547 If KEY is already present in table, replace its current value with
4550 Lisp_Object key
, value
, table
;
4552 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4556 i
= hash_lookup (h
, key
, &hash
);
4558 HASH_VALUE (h
, i
) = value
;
4560 hash_put (h
, key
, value
, hash
);
4566 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4567 doc
: /* Remove KEY from TABLE. */)
4569 Lisp_Object key
, table
;
4571 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4572 hash_remove (h
, key
);
4577 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4578 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4579 FUNCTION is called with 2 arguments KEY and VALUE. */)
4581 Lisp_Object function
, table
;
4583 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4584 Lisp_Object args
[3];
4587 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4588 if (!NILP (HASH_HASH (h
, i
)))
4591 args
[1] = HASH_KEY (h
, i
);
4592 args
[2] = HASH_VALUE (h
, i
);
4600 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4601 Sdefine_hash_table_test
, 3, 3, 0,
4602 doc
: /* Define a new hash table test with name NAME, a symbol.
4604 In hash tables created with NAME specified as test, use TEST to
4605 compare keys, and HASH for computing hash codes of keys.
4607 TEST must be a function taking two arguments and returning non-nil if
4608 both arguments are the same. HASH must be a function taking one
4609 argument and return an integer that is the hash code of the argument.
4610 Hash code computation should use the whole value range of integers,
4611 including negative integers. */)
4613 Lisp_Object name
, test
, hash
;
4615 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4620 /************************************************************************
4622 ************************************************************************/
4626 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4627 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4629 A message digest is a cryptographic checksum of a document, and the
4630 algorithm to calculate it is defined in RFC 1321.
4632 The two optional arguments START and END are character positions
4633 specifying for which part of OBJECT the message digest should be
4634 computed. If nil or omitted, the digest is computed for the whole
4637 The MD5 message digest is computed from the result of encoding the
4638 text in a coding system, not directly from the internal Emacs form of
4639 the text. The optional fourth argument CODING-SYSTEM specifies which
4640 coding system to encode the text with. It should be the same coding
4641 system that you used or will use when actually writing the text into a
4644 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4645 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4646 system would be chosen by default for writing this text into a file.
4648 If OBJECT is a string, the most preferred coding system (see the
4649 command `prefer-coding-system') is used.
4651 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4652 guesswork fails. Normally, an error is signaled in such case. */)
4653 (object
, start
, end
, coding_system
, noerror
)
4654 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4656 unsigned char digest
[16];
4657 unsigned char value
[33];
4661 int start_char
= 0, end_char
= 0;
4662 int start_byte
= 0, end_byte
= 0;
4664 register struct buffer
*bp
;
4667 if (STRINGP (object
))
4669 if (NILP (coding_system
))
4671 /* Decide the coding-system to encode the data with. */
4673 if (STRING_MULTIBYTE (object
))
4674 /* use default, we can't guess correct value */
4675 coding_system
= preferred_coding_system ();
4677 coding_system
= Qraw_text
;
4680 if (NILP (Fcoding_system_p (coding_system
)))
4682 /* Invalid coding system. */
4684 if (!NILP (noerror
))
4685 coding_system
= Qraw_text
;
4688 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4691 if (STRING_MULTIBYTE (object
))
4692 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4694 size
= XSTRING (object
)->size
;
4695 size_byte
= STRING_BYTES (XSTRING (object
));
4699 CHECK_NUMBER (start
);
4701 start_char
= XINT (start
);
4706 start_byte
= string_char_to_byte (object
, start_char
);
4712 end_byte
= size_byte
;
4718 end_char
= XINT (end
);
4723 end_byte
= string_char_to_byte (object
, end_char
);
4726 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4727 args_out_of_range_3 (object
, make_number (start_char
),
4728 make_number (end_char
));
4732 CHECK_BUFFER (object
);
4734 bp
= XBUFFER (object
);
4740 CHECK_NUMBER_COERCE_MARKER (start
);
4748 CHECK_NUMBER_COERCE_MARKER (end
);
4753 temp
= b
, b
= e
, e
= temp
;
4755 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
4756 args_out_of_range (start
, end
);
4758 if (NILP (coding_system
))
4760 /* Decide the coding-system to encode the data with.
4761 See fileio.c:Fwrite-region */
4763 if (!NILP (Vcoding_system_for_write
))
4764 coding_system
= Vcoding_system_for_write
;
4767 int force_raw_text
= 0;
4769 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4770 if (NILP (coding_system
)
4771 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4773 coding_system
= Qnil
;
4774 if (NILP (current_buffer
->enable_multibyte_characters
))
4778 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4780 /* Check file-coding-system-alist. */
4781 Lisp_Object args
[4], val
;
4783 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4784 args
[3] = Fbuffer_file_name(object
);
4785 val
= Ffind_operation_coding_system (4, args
);
4786 if (CONSP (val
) && !NILP (XCDR (val
)))
4787 coding_system
= XCDR (val
);
4790 if (NILP (coding_system
)
4791 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4793 /* If we still have not decided a coding system, use the
4794 default value of buffer-file-coding-system. */
4795 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4799 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4800 /* Confirm that VAL can surely encode the current region. */
4801 coding_system
= call3 (Vselect_safe_coding_system_function
,
4802 make_number (b
), make_number (e
),
4806 coding_system
= Qraw_text
;
4809 if (NILP (Fcoding_system_p (coding_system
)))
4811 /* Invalid coding system. */
4813 if (!NILP (noerror
))
4814 coding_system
= Qraw_text
;
4817 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4821 object
= make_buffer_string (b
, e
, 0);
4823 if (STRING_MULTIBYTE (object
))
4824 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4827 md5_buffer (XSTRING (object
)->data
+ start_byte
,
4828 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
4831 for (i
= 0; i
< 16; i
++)
4832 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4835 return make_string (value
, 32);
4842 /* Hash table stuff. */
4843 Qhash_table_p
= intern ("hash-table-p");
4844 staticpro (&Qhash_table_p
);
4845 Qeq
= intern ("eq");
4847 Qeql
= intern ("eql");
4849 Qequal
= intern ("equal");
4850 staticpro (&Qequal
);
4851 QCtest
= intern (":test");
4852 staticpro (&QCtest
);
4853 QCsize
= intern (":size");
4854 staticpro (&QCsize
);
4855 QCrehash_size
= intern (":rehash-size");
4856 staticpro (&QCrehash_size
);
4857 QCrehash_threshold
= intern (":rehash-threshold");
4858 staticpro (&QCrehash_threshold
);
4859 QCweakness
= intern (":weakness");
4860 staticpro (&QCweakness
);
4861 Qkey
= intern ("key");
4863 Qvalue
= intern ("value");
4864 staticpro (&Qvalue
);
4865 Qhash_table_test
= intern ("hash-table-test");
4866 staticpro (&Qhash_table_test
);
4867 Qkey_or_value
= intern ("key-or-value");
4868 staticpro (&Qkey_or_value
);
4869 Qkey_and_value
= intern ("key-and-value");
4870 staticpro (&Qkey_and_value
);
4873 defsubr (&Smake_hash_table
);
4874 defsubr (&Scopy_hash_table
);
4875 defsubr (&Smakehash
);
4876 defsubr (&Shash_table_count
);
4877 defsubr (&Shash_table_rehash_size
);
4878 defsubr (&Shash_table_rehash_threshold
);
4879 defsubr (&Shash_table_size
);
4880 defsubr (&Shash_table_test
);
4881 defsubr (&Shash_table_weakness
);
4882 defsubr (&Shash_table_p
);
4883 defsubr (&Sclrhash
);
4884 defsubr (&Sgethash
);
4885 defsubr (&Sputhash
);
4886 defsubr (&Sremhash
);
4887 defsubr (&Smaphash
);
4888 defsubr (&Sdefine_hash_table_test
);
4890 Qstring_lessp
= intern ("string-lessp");
4891 staticpro (&Qstring_lessp
);
4892 Qprovide
= intern ("provide");
4893 staticpro (&Qprovide
);
4894 Qrequire
= intern ("require");
4895 staticpro (&Qrequire
);
4896 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4897 staticpro (&Qyes_or_no_p_history
);
4898 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4899 staticpro (&Qcursor_in_echo_area
);
4900 Qwidget_type
= intern ("widget-type");
4901 staticpro (&Qwidget_type
);
4903 staticpro (&string_char_byte_cache_string
);
4904 string_char_byte_cache_string
= Qnil
;
4906 require_nesting_list
= Qnil
;
4907 staticpro (&require_nesting_list
);
4909 Fset (Qyes_or_no_p_history
, Qnil
);
4911 DEFVAR_LISP ("features", &Vfeatures
,
4912 doc
: /* A list of symbols which are the features of the executing emacs.
4913 Used by `featurep' and `require', and altered by `provide'. */);
4915 Qsubfeatures
= intern ("subfeatures");
4916 staticpro (&Qsubfeatures
);
4918 Qcodeset
= intern ("codeset");
4919 staticpro (&Qcodeset
);
4920 Qdays
= intern ("days");
4922 Qmonths
= intern ("months");
4923 staticpro (&Qmonths
);
4925 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4926 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4927 This applies to y-or-n and yes-or-no questions asked by commands
4928 invoked by mouse clicks and mouse menu items. */);
4931 defsubr (&Sidentity
);
4934 defsubr (&Ssafe_length
);
4935 defsubr (&Sstring_bytes
);
4936 defsubr (&Sstring_equal
);
4937 defsubr (&Scompare_strings
);
4938 defsubr (&Sstring_lessp
);
4941 defsubr (&Svconcat
);
4942 defsubr (&Scopy_sequence
);
4943 defsubr (&Sstring_make_multibyte
);
4944 defsubr (&Sstring_make_unibyte
);
4945 defsubr (&Sstring_as_multibyte
);
4946 defsubr (&Sstring_as_unibyte
);
4947 defsubr (&Sstring_to_multibyte
);
4948 defsubr (&Scopy_alist
);
4949 defsubr (&Ssubstring
);
4961 defsubr (&Snreverse
);
4962 defsubr (&Sreverse
);
4964 defsubr (&Splist_get
);
4966 defsubr (&Splist_put
);
4969 defsubr (&Sfillarray
);
4973 defsubr (&Smapconcat
);
4974 defsubr (&Sy_or_n_p
);
4975 defsubr (&Syes_or_no_p
);
4976 defsubr (&Sload_average
);
4977 defsubr (&Sfeaturep
);
4978 defsubr (&Srequire
);
4979 defsubr (&Sprovide
);
4980 defsubr (&Splist_member
);
4981 defsubr (&Swidget_put
);
4982 defsubr (&Swidget_get
);
4983 defsubr (&Swidget_apply
);
4984 defsubr (&Sbase64_encode_region
);
4985 defsubr (&Sbase64_decode_region
);
4986 defsubr (&Sbase64_encode_string
);
4987 defsubr (&Sbase64_decode_string
);
4989 defsubr (&Slanginfo
);
4996 Vweak_hash_tables
= Qnil
;