1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005 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. */
30 /* On Mac OS, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 /* Nonzero enables use of a file dialog for file name
63 questions asked by mouse commands. */
66 extern int minibuffer_auto_raise
;
67 extern Lisp_Object minibuf_window
;
68 extern Lisp_Object Vlocale_coding_system
;
69 extern int load_in_progress
;
71 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
72 Lisp_Object Qyes_or_no_p_history
;
73 Lisp_Object Qcursor_in_echo_area
;
74 Lisp_Object Qwidget_type
;
75 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
77 extern Lisp_Object Qinput_method_function
;
79 static int internal_equal ();
81 extern long get_random ();
82 extern void seed_random ();
88 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
89 doc
: /* Return the argument unchanged. */)
96 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
97 doc
: /* Return a pseudo-random number.
98 All integers representable in Lisp are equally likely.
99 On most systems, this is 29 bits' worth.
100 With positive integer argument N, return random number in interval [0,N).
101 With argument t, set the random number seed from the current time and pid. */)
106 Lisp_Object lispy_val
;
107 unsigned long denominator
;
110 seed_random (getpid () + time (NULL
));
111 if (NATNUMP (n
) && XFASTINT (n
) != 0)
113 /* Try to take our random number from the higher bits of VAL,
114 not the lower, since (says Gentzel) the low bits of `random'
115 are less random than the higher ones. We do this by using the
116 quotient rather than the remainder. At the high end of the RNG
117 it's possible to get a quotient larger than n; discarding
118 these values eliminates the bias that would otherwise appear
119 when using a large n. */
120 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
122 val
= get_random () / denominator
;
123 while (val
>= XFASTINT (n
));
127 XSETINT (lispy_val
, val
);
131 /* Random data-structure functions */
133 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
134 doc
: /* Return the length of vector, list or string SEQUENCE.
135 A byte-code function object is also allowed.
136 If the string contains multibyte characters, this is not necessarily
137 the number of bytes in the string; it is the number of characters.
138 To get the number of bytes, use `string-bytes'. */)
140 register Lisp_Object sequence
;
142 register Lisp_Object val
;
146 if (STRINGP (sequence
))
147 XSETFASTINT (val
, SCHARS (sequence
));
148 else if (VECTORP (sequence
))
149 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
150 else if (SUB_CHAR_TABLE_P (sequence
))
151 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
152 else if (CHAR_TABLE_P (sequence
))
153 XSETFASTINT (val
, MAX_CHAR
);
154 else if (BOOL_VECTOR_P (sequence
))
155 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
156 else if (COMPILEDP (sequence
))
157 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
158 else if (CONSP (sequence
))
161 while (CONSP (sequence
))
163 sequence
= XCDR (sequence
);
166 if (!CONSP (sequence
))
169 sequence
= XCDR (sequence
);
174 if (!NILP (sequence
))
175 wrong_type_argument (Qlistp
, sequence
);
177 val
= make_number (i
);
179 else if (NILP (sequence
))
180 XSETFASTINT (val
, 0);
183 sequence
= wrong_type_argument (Qsequencep
, sequence
);
189 /* This does not check for quits. That is safe since it must terminate. */
191 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
192 doc
: /* Return the length of a list, but avoid error or infinite loop.
193 This function never gets an error. If LIST is not really a list,
194 it returns 0. If LIST is circular, it returns a finite value
195 which is at least the number of distinct elements. */)
199 Lisp_Object tail
, halftail
, length
;
202 /* halftail is used to detect circular lists. */
204 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
206 if (EQ (tail
, halftail
) && len
!= 0)
210 halftail
= XCDR (halftail
);
213 XSETINT (length
, len
);
217 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
218 doc
: /* Return the number of bytes in STRING.
219 If STRING is a multibyte string, this is greater than the length of STRING. */)
223 CHECK_STRING (string
);
224 return make_number (SBYTES (string
));
227 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
228 doc
: /* Return t if two strings have identical contents.
229 Case is significant, but text properties are ignored.
230 Symbols are also allowed; their print names are used instead. */)
232 register Lisp_Object s1
, s2
;
235 s1
= SYMBOL_NAME (s1
);
237 s2
= SYMBOL_NAME (s2
);
241 if (SCHARS (s1
) != SCHARS (s2
)
242 || SBYTES (s1
) != SBYTES (s2
)
243 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
248 DEFUN ("compare-strings", Fcompare_strings
,
249 Scompare_strings
, 6, 7, 0,
250 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
251 In string STR1, skip the first START1 characters and stop at END1.
252 In string STR2, skip the first START2 characters and stop at END2.
253 END1 and END2 default to the full lengths of the respective strings.
255 Case is significant in this comparison if IGNORE-CASE is nil.
256 Unibyte strings are converted to multibyte for comparison.
258 The value is t if the strings (or specified portions) match.
259 If string STR1 is less, the value is a negative number N;
260 - 1 - N is the number of characters that match at the beginning.
261 If string STR1 is greater, the value is a positive number N;
262 N - 1 is the number of characters that match at the beginning. */)
263 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
264 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
266 register int end1_char
, end2_char
;
267 register int i1
, i1_byte
, i2
, i2_byte
;
272 start1
= make_number (0);
274 start2
= make_number (0);
275 CHECK_NATNUM (start1
);
276 CHECK_NATNUM (start2
);
285 i1_byte
= string_char_to_byte (str1
, i1
);
286 i2_byte
= string_char_to_byte (str2
, i2
);
288 end1_char
= SCHARS (str1
);
289 if (! NILP (end1
) && end1_char
> XINT (end1
))
290 end1_char
= XINT (end1
);
292 end2_char
= SCHARS (str2
);
293 if (! NILP (end2
) && end2_char
> XINT (end2
))
294 end2_char
= XINT (end2
);
296 while (i1
< end1_char
&& i2
< end2_char
)
298 /* When we find a mismatch, we must compare the
299 characters, not just the bytes. */
302 if (STRING_MULTIBYTE (str1
))
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
306 c1
= SREF (str1
, i1
++);
307 c1
= unibyte_char_to_multibyte (c1
);
310 if (STRING_MULTIBYTE (str2
))
311 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
314 c2
= SREF (str2
, i2
++);
315 c2
= unibyte_char_to_multibyte (c2
);
321 if (! NILP (ignore_case
))
325 tem
= Fupcase (make_number (c1
));
327 tem
= Fupcase (make_number (c2
));
334 /* Note that I1 has already been incremented
335 past the character that we are comparing;
336 hence we don't add or subtract 1 here. */
338 return make_number (- i1
+ XINT (start1
));
340 return make_number (i1
- XINT (start1
));
344 return make_number (i1
- XINT (start1
) + 1);
346 return make_number (- i1
+ XINT (start1
) - 1);
351 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
352 doc
: /* Return t if first arg string is less than second in lexicographic order.
354 Symbols are also allowed; their print names are used instead. */)
356 register Lisp_Object s1
, s2
;
359 register int i1
, i1_byte
, i2
, i2_byte
;
362 s1
= SYMBOL_NAME (s1
);
364 s2
= SYMBOL_NAME (s2
);
368 i1
= i1_byte
= i2
= i2_byte
= 0;
371 if (end
> SCHARS (s2
))
376 /* When we find a mismatch, we must compare the
377 characters, not just the bytes. */
380 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
381 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
384 return c1
< c2
? Qt
: Qnil
;
386 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
389 static Lisp_Object
concat ();
400 return concat (2, args
, Lisp_String
, 0);
402 return concat (2, &s1
, Lisp_String
, 0);
403 #endif /* NO_ARG_ARRAY */
409 Lisp_Object s1
, s2
, s3
;
416 return concat (3, args
, Lisp_String
, 0);
418 return concat (3, &s1
, Lisp_String
, 0);
419 #endif /* NO_ARG_ARRAY */
422 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
423 doc
: /* Concatenate all the arguments and make the result a list.
424 The result is a list whose elements are the elements of all the arguments.
425 Each argument may be a list, vector or string.
426 The last argument is not copied, just used as the tail of the new list.
427 usage: (append &rest SEQUENCES) */)
432 return concat (nargs
, args
, Lisp_Cons
, 1);
435 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
436 doc
: /* Concatenate all the arguments and make the result a string.
437 The result is a string whose elements are the elements of all the arguments.
438 Each argument may be a string or a list or vector of characters (integers).
439 usage: (concat &rest SEQUENCES) */)
444 return concat (nargs
, args
, Lisp_String
, 0);
447 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
448 doc
: /* Concatenate all the arguments and make the result a vector.
449 The result is a vector whose elements are the elements of all the arguments.
450 Each argument may be a list, vector or string.
451 usage: (vconcat &rest SEQUENCES) */)
456 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
459 /* Return a copy of a sub char table ARG. The elements except for a
460 nested sub char table are not copied. */
462 copy_sub_char_table (arg
)
465 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
468 /* Copy all the contents. */
469 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
470 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
471 /* Recursively copy any sub char-tables in the ordinary slots. */
472 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
473 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
474 XCHAR_TABLE (copy
)->contents
[i
]
475 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
481 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
482 doc
: /* Return a copy of a list, vector, string or char-table.
483 The elements of a list or vector are not copied; they are shared
484 with the original. */)
488 if (NILP (arg
)) return arg
;
490 if (CHAR_TABLE_P (arg
))
495 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
496 /* Copy all the slots, including the extra ones. */
497 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
498 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
499 * sizeof (Lisp_Object
)));
501 /* Recursively copy any sub char tables in the ordinary slots
502 for multibyte characters. */
503 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
504 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
505 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
506 XCHAR_TABLE (copy
)->contents
[i
]
507 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
512 if (BOOL_VECTOR_P (arg
))
516 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
517 / BOOL_VECTOR_BITS_PER_CHAR
);
519 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
520 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
525 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
526 arg
= wrong_type_argument (Qsequencep
, arg
);
527 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
530 /* This structure holds information of an argument of `concat' that is
531 a string and has text properties to be copied. */
534 int argnum
; /* refer to ARGS (arguments of `concat') */
535 int from
; /* refer to ARGS[argnum] (argument string) */
536 int to
; /* refer to VAL (the target string) */
540 concat (nargs
, args
, target_type
, last_special
)
543 enum Lisp_Type target_type
;
547 register Lisp_Object tail
;
548 register Lisp_Object
this;
550 int toindex_byte
= 0;
551 register int result_len
;
552 register int result_len_byte
;
554 Lisp_Object last_tail
;
557 /* When we make a multibyte string, we can't copy text properties
558 while concatinating each string because the length of resulting
559 string can't be decided until we finish the whole concatination.
560 So, we record strings that have text properties to be copied
561 here, and copy the text properties after the concatination. */
562 struct textprop_rec
*textprops
= NULL
;
563 /* Number of elments in textprops. */
564 int num_textprops
= 0;
569 /* In append, the last arg isn't treated like the others */
570 if (last_special
&& nargs
> 0)
573 last_tail
= args
[nargs
];
578 /* Canonicalize each argument. */
579 for (argnum
= 0; argnum
< nargs
; argnum
++)
582 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
583 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
585 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
589 /* Compute total length in chars of arguments in RESULT_LEN.
590 If desired output is a string, also compute length in bytes
591 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
592 whether the result should be a multibyte string. */
596 for (argnum
= 0; argnum
< nargs
; argnum
++)
600 len
= XFASTINT (Flength (this));
601 if (target_type
== Lisp_String
)
603 /* We must count the number of bytes needed in the string
604 as well as the number of characters. */
610 for (i
= 0; i
< len
; i
++)
612 ch
= XVECTOR (this)->contents
[i
];
614 wrong_type_argument (Qintegerp
, ch
);
615 this_len_byte
= CHAR_BYTES (XINT (ch
));
616 result_len_byte
+= this_len_byte
;
617 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
620 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
621 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
622 else if (CONSP (this))
623 for (; CONSP (this); this = XCDR (this))
627 wrong_type_argument (Qintegerp
, ch
);
628 this_len_byte
= CHAR_BYTES (XINT (ch
));
629 result_len_byte
+= this_len_byte
;
630 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
633 else if (STRINGP (this))
635 if (STRING_MULTIBYTE (this))
638 result_len_byte
+= SBYTES (this);
641 result_len_byte
+= count_size_as_multibyte (SDATA (this),
649 if (! some_multibyte
)
650 result_len_byte
= result_len
;
652 /* Create the output object. */
653 if (target_type
== Lisp_Cons
)
654 val
= Fmake_list (make_number (result_len
), Qnil
);
655 else if (target_type
== Lisp_Vectorlike
)
656 val
= Fmake_vector (make_number (result_len
), Qnil
);
657 else if (some_multibyte
)
658 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
660 val
= make_uninit_string (result_len
);
662 /* In `append', if all but last arg are nil, return last arg. */
663 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
666 /* Copy the contents of the args into the result. */
668 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
670 toindex
= 0, toindex_byte
= 0;
674 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
676 for (argnum
= 0; argnum
< nargs
; argnum
++)
680 register unsigned int thisindex
= 0;
681 register unsigned int thisindex_byte
= 0;
685 thislen
= Flength (this), thisleni
= XINT (thislen
);
687 /* Between strings of the same kind, copy fast. */
688 if (STRINGP (this) && STRINGP (val
)
689 && STRING_MULTIBYTE (this) == some_multibyte
)
691 int thislen_byte
= SBYTES (this);
693 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
695 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
697 textprops
[num_textprops
].argnum
= argnum
;
698 textprops
[num_textprops
].from
= 0;
699 textprops
[num_textprops
++].to
= toindex
;
701 toindex_byte
+= thislen_byte
;
703 STRING_SET_CHARS (val
, SCHARS (val
));
705 /* Copy a single-byte string to a multibyte string. */
706 else if (STRINGP (this) && STRINGP (val
))
708 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
710 textprops
[num_textprops
].argnum
= argnum
;
711 textprops
[num_textprops
].from
= 0;
712 textprops
[num_textprops
++].to
= toindex
;
714 toindex_byte
+= copy_text (SDATA (this),
715 SDATA (val
) + toindex_byte
,
716 SCHARS (this), 0, 1);
720 /* Copy element by element. */
723 register Lisp_Object elt
;
725 /* Fetch next element of `this' arg into `elt', or break if
726 `this' is exhausted. */
727 if (NILP (this)) break;
729 elt
= XCAR (this), this = XCDR (this);
730 else if (thisindex
>= thisleni
)
732 else if (STRINGP (this))
735 if (STRING_MULTIBYTE (this))
737 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
740 XSETFASTINT (elt
, c
);
744 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
746 && (XINT (elt
) >= 0240
747 || (XINT (elt
) >= 0200
748 && ! NILP (Vnonascii_translation_table
)))
749 && XINT (elt
) < 0400)
751 c
= unibyte_char_to_multibyte (XINT (elt
));
756 else if (BOOL_VECTOR_P (this))
759 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
760 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
767 elt
= XVECTOR (this)->contents
[thisindex
++];
769 /* Store this element into the result. */
776 else if (VECTORP (val
))
777 XVECTOR (val
)->contents
[toindex
++] = elt
;
781 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
785 += CHAR_STRING (XINT (elt
),
786 SDATA (val
) + toindex_byte
);
788 SSET (val
, toindex_byte
++, XINT (elt
));
792 /* If we have any multibyte characters,
793 we already decided to make a multibyte string. */
796 /* P exists as a variable
797 to avoid a bug on the Masscomp C compiler. */
798 unsigned char *p
= SDATA (val
) + toindex_byte
;
800 toindex_byte
+= CHAR_STRING (c
, p
);
807 XSETCDR (prev
, last_tail
);
809 if (num_textprops
> 0)
812 int last_to_end
= -1;
814 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
816 this = args
[textprops
[argnum
].argnum
];
817 props
= text_property_list (this,
819 make_number (SCHARS (this)),
821 /* If successive arguments have properites, be sure that the
822 value of `composition' property be the copy. */
823 if (last_to_end
== textprops
[argnum
].to
)
824 make_composition_value_copy (props
);
825 add_text_properties_from_list (val
, props
,
826 make_number (textprops
[argnum
].to
));
827 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
835 static Lisp_Object string_char_byte_cache_string
;
836 static int string_char_byte_cache_charpos
;
837 static int string_char_byte_cache_bytepos
;
840 clear_string_char_byte_cache ()
842 string_char_byte_cache_string
= Qnil
;
845 /* Return the character index corresponding to CHAR_INDEX in STRING. */
848 string_char_to_byte (string
, char_index
)
853 int best_below
, best_below_byte
;
854 int best_above
, best_above_byte
;
856 best_below
= best_below_byte
= 0;
857 best_above
= SCHARS (string
);
858 best_above_byte
= SBYTES (string
);
859 if (best_above
== best_above_byte
)
862 if (EQ (string
, string_char_byte_cache_string
))
864 if (string_char_byte_cache_charpos
< char_index
)
866 best_below
= string_char_byte_cache_charpos
;
867 best_below_byte
= string_char_byte_cache_bytepos
;
871 best_above
= string_char_byte_cache_charpos
;
872 best_above_byte
= string_char_byte_cache_bytepos
;
876 if (char_index
- best_below
< best_above
- char_index
)
878 while (best_below
< char_index
)
881 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
882 best_below
, best_below_byte
);
885 i_byte
= best_below_byte
;
889 while (best_above
> char_index
)
891 unsigned char *pend
= SDATA (string
) + best_above_byte
;
892 unsigned char *pbeg
= pend
- best_above_byte
;
893 unsigned char *p
= pend
- 1;
896 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
897 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
898 if (bytes
== pend
- p
)
899 best_above_byte
-= bytes
;
900 else if (bytes
> pend
- p
)
901 best_above_byte
-= (pend
- p
);
907 i_byte
= best_above_byte
;
910 string_char_byte_cache_bytepos
= i_byte
;
911 string_char_byte_cache_charpos
= i
;
912 string_char_byte_cache_string
= string
;
917 /* Return the character index corresponding to BYTE_INDEX in STRING. */
920 string_byte_to_char (string
, byte_index
)
925 int best_below
, best_below_byte
;
926 int best_above
, best_above_byte
;
928 best_below
= best_below_byte
= 0;
929 best_above
= SCHARS (string
);
930 best_above_byte
= SBYTES (string
);
931 if (best_above
== best_above_byte
)
934 if (EQ (string
, string_char_byte_cache_string
))
936 if (string_char_byte_cache_bytepos
< byte_index
)
938 best_below
= string_char_byte_cache_charpos
;
939 best_below_byte
= string_char_byte_cache_bytepos
;
943 best_above
= string_char_byte_cache_charpos
;
944 best_above_byte
= string_char_byte_cache_bytepos
;
948 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
950 while (best_below_byte
< byte_index
)
953 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
954 best_below
, best_below_byte
);
957 i_byte
= best_below_byte
;
961 while (best_above_byte
> byte_index
)
963 unsigned char *pend
= SDATA (string
) + best_above_byte
;
964 unsigned char *pbeg
= pend
- best_above_byte
;
965 unsigned char *p
= pend
- 1;
968 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
969 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
970 if (bytes
== pend
- p
)
971 best_above_byte
-= bytes
;
972 else if (bytes
> pend
- p
)
973 best_above_byte
-= (pend
- p
);
979 i_byte
= best_above_byte
;
982 string_char_byte_cache_bytepos
= i_byte
;
983 string_char_byte_cache_charpos
= i
;
984 string_char_byte_cache_string
= string
;
989 /* Convert STRING to a multibyte string.
990 Single-byte characters 0240 through 0377 are converted
991 by adding nonascii_insert_offset to each. */
994 string_make_multibyte (string
)
1002 if (STRING_MULTIBYTE (string
))
1005 nbytes
= count_size_as_multibyte (SDATA (string
),
1007 /* If all the chars are ASCII, they won't need any more bytes
1008 once converted. In that case, we can return STRING itself. */
1009 if (nbytes
== SBYTES (string
))
1012 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1013 copy_text (SDATA (string
), buf
, SBYTES (string
),
1016 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1023 /* Convert STRING to a multibyte string without changing each
1024 character codes. Thus, characters 0200 trough 0237 are converted
1025 to eight-bit-control characters, and characters 0240 through 0377
1026 are converted eight-bit-graphic characters. */
1029 string_to_multibyte (string
)
1037 if (STRING_MULTIBYTE (string
))
1040 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1041 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1042 any more bytes once converted. */
1043 if (nbytes
== SBYTES (string
))
1044 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1046 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1047 bcopy (SDATA (string
), buf
, SBYTES (string
));
1048 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1050 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1057 /* Convert STRING to a single-byte string. */
1060 string_make_unibyte (string
)
1068 if (! STRING_MULTIBYTE (string
))
1071 nchars
= SCHARS (string
);
1073 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1074 copy_text (SDATA (string
), buf
, SBYTES (string
),
1077 ret
= make_unibyte_string (buf
, nchars
);
1083 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1085 doc
: /* Return the multibyte equivalent of STRING.
1086 If STRING is unibyte and contains non-ASCII characters, the function
1087 `unibyte-char-to-multibyte' is used to convert each unibyte character
1088 to a multibyte character. In this case, the returned string is a
1089 newly created string with no text properties. If STRING is multibyte
1090 or entirely ASCII, it is returned unchanged. In particular, when
1091 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1092 \(When the characters are all ASCII, Emacs primitives will treat the
1093 string the same way whether it is unibyte or multibyte.) */)
1097 CHECK_STRING (string
);
1099 return string_make_multibyte (string
);
1102 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1104 doc
: /* Return the unibyte equivalent of STRING.
1105 Multibyte character codes are converted to unibyte according to
1106 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1107 If the lookup in the translation table fails, this function takes just
1108 the low 8 bits of each character. */)
1112 CHECK_STRING (string
);
1114 return string_make_unibyte (string
);
1117 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1119 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1120 If STRING is unibyte, the result is STRING itself.
1121 Otherwise it is a newly created string, with no text properties.
1122 If STRING is multibyte and contains a character of charset
1123 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1124 corresponding single byte. */)
1128 CHECK_STRING (string
);
1130 if (STRING_MULTIBYTE (string
))
1132 int bytes
= SBYTES (string
);
1133 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1135 bcopy (SDATA (string
), str
, bytes
);
1136 bytes
= str_as_unibyte (str
, bytes
);
1137 string
= make_unibyte_string (str
, bytes
);
1143 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1145 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1146 If STRING is multibyte, the result is STRING itself.
1147 Otherwise it is a newly created string, with no text properties.
1148 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1149 part of a multibyte form), it is converted to the corresponding
1150 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.
1151 Beware, this often doesn't really do what you think it does.
1152 It is similar to (decode-coding-string STRING 'emacs-mule-unix).
1153 If you're not sure, whether to use `string-as-multibyte' or
1154 `string-to-multibyte', use `string-to-multibyte'. Beware:
1155 (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
1156 (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
1157 (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
1158 (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
1160 (aref (string-as-multibyte "\201\300") 0) -> 2240
1161 (aref (string-as-multibyte "\201\300") 1) -> <error> */)
1165 CHECK_STRING (string
);
1167 if (! STRING_MULTIBYTE (string
))
1169 Lisp_Object new_string
;
1172 parse_str_as_multibyte (SDATA (string
),
1175 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1176 bcopy (SDATA (string
), SDATA (new_string
),
1178 if (nbytes
!= SBYTES (string
))
1179 str_as_multibyte (SDATA (new_string
), nbytes
,
1180 SBYTES (string
), NULL
);
1181 string
= new_string
;
1182 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1187 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1189 doc
: /* Return a multibyte string with the same individual chars as STRING.
1190 If STRING is multibyte, the result is STRING itself.
1191 Otherwise it is a newly created string, with no text properties.
1192 Characters 0200 through 0237 are converted to eight-bit-control
1193 characters of the same character code. Characters 0240 through 0377
1194 are converted to eight-bit-graphic characters of the same character
1196 This is similar to (decode-coding-string STRING 'binary) */)
1200 CHECK_STRING (string
);
1202 return string_to_multibyte (string
);
1206 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1207 doc
: /* Return a copy of ALIST.
1208 This is an alist which represents the same mapping from objects to objects,
1209 but does not share the alist structure with ALIST.
1210 The objects mapped (cars and cdrs of elements of the alist)
1211 are shared, however.
1212 Elements of ALIST that are not conses are also shared. */)
1216 register Lisp_Object tem
;
1221 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1222 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1224 register Lisp_Object car
;
1228 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1233 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1234 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1235 TO may be nil or omitted; then the substring runs to the end of STRING.
1236 FROM and TO start at 0. If either is negative, it counts from the end.
1238 This function allows vectors as well as strings. */)
1241 register Lisp_Object from
, to
;
1246 int from_char
, to_char
;
1247 int from_byte
= 0, to_byte
= 0;
1249 if (! (STRINGP (string
) || VECTORP (string
)))
1250 wrong_type_argument (Qarrayp
, string
);
1252 CHECK_NUMBER (from
);
1254 if (STRINGP (string
))
1256 size
= SCHARS (string
);
1257 size_byte
= SBYTES (string
);
1260 size
= XVECTOR (string
)->size
;
1265 to_byte
= size_byte
;
1271 to_char
= XINT (to
);
1275 if (STRINGP (string
))
1276 to_byte
= string_char_to_byte (string
, to_char
);
1279 from_char
= XINT (from
);
1282 if (STRINGP (string
))
1283 from_byte
= string_char_to_byte (string
, from_char
);
1285 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1286 args_out_of_range_3 (string
, make_number (from_char
),
1287 make_number (to_char
));
1289 if (STRINGP (string
))
1291 res
= make_specified_string (SDATA (string
) + from_byte
,
1292 to_char
- from_char
, to_byte
- from_byte
,
1293 STRING_MULTIBYTE (string
));
1294 copy_text_properties (make_number (from_char
), make_number (to_char
),
1295 string
, make_number (0), res
, Qnil
);
1298 res
= Fvector (to_char
- from_char
,
1299 XVECTOR (string
)->contents
+ from_char
);
1305 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1306 doc
: /* Return a substring of STRING, without text properties.
1307 It starts at index FROM and ending before TO.
1308 TO may be nil or omitted; then the substring runs to the end of STRING.
1309 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1310 If FROM or TO is negative, it counts from the end.
1312 With one argument, just copy STRING without its properties. */)
1315 register Lisp_Object from
, to
;
1317 int size
, size_byte
;
1318 int from_char
, to_char
;
1319 int from_byte
, to_byte
;
1321 CHECK_STRING (string
);
1323 size
= SCHARS (string
);
1324 size_byte
= SBYTES (string
);
1327 from_char
= from_byte
= 0;
1330 CHECK_NUMBER (from
);
1331 from_char
= XINT (from
);
1335 from_byte
= string_char_to_byte (string
, from_char
);
1341 to_byte
= size_byte
;
1347 to_char
= XINT (to
);
1351 to_byte
= string_char_to_byte (string
, to_char
);
1354 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1355 args_out_of_range_3 (string
, make_number (from_char
),
1356 make_number (to_char
));
1358 return make_specified_string (SDATA (string
) + from_byte
,
1359 to_char
- from_char
, to_byte
- from_byte
,
1360 STRING_MULTIBYTE (string
));
1363 /* Extract a substring of STRING, giving start and end positions
1364 both in characters and in bytes. */
1367 substring_both (string
, from
, from_byte
, to
, to_byte
)
1369 int from
, from_byte
, to
, to_byte
;
1375 if (! (STRINGP (string
) || VECTORP (string
)))
1376 wrong_type_argument (Qarrayp
, string
);
1378 if (STRINGP (string
))
1380 size
= SCHARS (string
);
1381 size_byte
= SBYTES (string
);
1384 size
= XVECTOR (string
)->size
;
1386 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1387 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1389 if (STRINGP (string
))
1391 res
= make_specified_string (SDATA (string
) + from_byte
,
1392 to
- from
, to_byte
- from_byte
,
1393 STRING_MULTIBYTE (string
));
1394 copy_text_properties (make_number (from
), make_number (to
),
1395 string
, make_number (0), res
, Qnil
);
1398 res
= Fvector (to
- from
,
1399 XVECTOR (string
)->contents
+ from
);
1404 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1405 doc
: /* Take cdr N times on LIST, returns the result. */)
1408 register Lisp_Object list
;
1410 register int i
, num
;
1413 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1417 wrong_type_argument (Qlistp
, list
);
1423 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1424 doc
: /* Return the Nth element of LIST.
1425 N counts from zero. If LIST is not that long, nil is returned. */)
1427 Lisp_Object n
, list
;
1429 return Fcar (Fnthcdr (n
, list
));
1432 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1433 doc
: /* Return element of SEQUENCE at index N. */)
1435 register Lisp_Object sequence
, n
;
1440 if (CONSP (sequence
) || NILP (sequence
))
1441 return Fcar (Fnthcdr (n
, sequence
));
1442 else if (STRINGP (sequence
) || VECTORP (sequence
)
1443 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1444 return Faref (sequence
, n
);
1446 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1450 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1451 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1452 The value is actually the tail of LIST whose car is ELT. */)
1454 register Lisp_Object elt
;
1457 register Lisp_Object tail
;
1458 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1460 register Lisp_Object tem
;
1462 wrong_type_argument (Qlistp
, list
);
1464 if (! NILP (Fequal (elt
, tem
)))
1471 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1472 doc
: /* Return non-nil if ELT is an element of LIST.
1473 Comparison done with EQ. The value is actually the tail of LIST
1474 whose car is ELT. */)
1476 Lisp_Object elt
, list
;
1480 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1484 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1488 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1495 if (!CONSP (list
) && !NILP (list
))
1496 list
= wrong_type_argument (Qlistp
, list
);
1501 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1502 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1503 The value is actually the first element of LIST whose car is KEY.
1504 Elements of LIST that are not conses are ignored. */)
1506 Lisp_Object key
, list
;
1513 || (CONSP (XCAR (list
))
1514 && EQ (XCAR (XCAR (list
)), key
)))
1519 || (CONSP (XCAR (list
))
1520 && EQ (XCAR (XCAR (list
)), key
)))
1525 || (CONSP (XCAR (list
))
1526 && EQ (XCAR (XCAR (list
)), key
)))
1534 result
= XCAR (list
);
1535 else if (NILP (list
))
1538 result
= wrong_type_argument (Qlistp
, list
);
1543 /* Like Fassq but never report an error and do not allow quits.
1544 Use only on lists known never to be circular. */
1547 assq_no_quit (key
, list
)
1548 Lisp_Object key
, list
;
1551 && (!CONSP (XCAR (list
))
1552 || !EQ (XCAR (XCAR (list
)), key
)))
1555 return CONSP (list
) ? XCAR (list
) : Qnil
;
1558 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1559 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1560 The value is actually the first element of LIST whose car equals KEY. */)
1562 Lisp_Object key
, list
;
1564 Lisp_Object result
, car
;
1569 || (CONSP (XCAR (list
))
1570 && (car
= XCAR (XCAR (list
)),
1571 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1576 || (CONSP (XCAR (list
))
1577 && (car
= XCAR (XCAR (list
)),
1578 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1583 || (CONSP (XCAR (list
))
1584 && (car
= XCAR (XCAR (list
)),
1585 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1593 result
= XCAR (list
);
1594 else if (NILP (list
))
1597 result
= wrong_type_argument (Qlistp
, list
);
1602 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1603 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1604 The value is actually the first element of LIST whose cdr is KEY. */)
1606 register Lisp_Object key
;
1614 || (CONSP (XCAR (list
))
1615 && EQ (XCDR (XCAR (list
)), key
)))
1620 || (CONSP (XCAR (list
))
1621 && EQ (XCDR (XCAR (list
)), key
)))
1626 || (CONSP (XCAR (list
))
1627 && EQ (XCDR (XCAR (list
)), key
)))
1636 else if (CONSP (list
))
1637 result
= XCAR (list
);
1639 result
= wrong_type_argument (Qlistp
, list
);
1644 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1645 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1646 The value is actually the first element of LIST whose cdr equals KEY. */)
1648 Lisp_Object key
, list
;
1650 Lisp_Object result
, cdr
;
1655 || (CONSP (XCAR (list
))
1656 && (cdr
= XCDR (XCAR (list
)),
1657 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1662 || (CONSP (XCAR (list
))
1663 && (cdr
= XCDR (XCAR (list
)),
1664 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1669 || (CONSP (XCAR (list
))
1670 && (cdr
= XCDR (XCAR (list
)),
1671 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1679 result
= XCAR (list
);
1680 else if (NILP (list
))
1683 result
= wrong_type_argument (Qlistp
, list
);
1688 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1689 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1690 The modified LIST is returned. Comparison is done with `eq'.
1691 If the first member of LIST is ELT, there is no way to remove it by side effect;
1692 therefore, write `(setq foo (delq element foo))'
1693 to be sure of changing the value of `foo'. */)
1695 register Lisp_Object elt
;
1698 register Lisp_Object tail
, prev
;
1699 register Lisp_Object tem
;
1703 while (!NILP (tail
))
1706 wrong_type_argument (Qlistp
, list
);
1713 Fsetcdr (prev
, XCDR (tail
));
1723 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1724 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1725 SEQ must be a list, a vector, or a string.
1726 The modified SEQ is returned. Comparison is done with `equal'.
1727 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1728 is not a side effect; it is simply using a different sequence.
1729 Therefore, write `(setq foo (delete element foo))'
1730 to be sure of changing the value of `foo'. */)
1732 Lisp_Object elt
, seq
;
1738 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1739 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1742 if (n
!= ASIZE (seq
))
1744 struct Lisp_Vector
*p
= allocate_vector (n
);
1746 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1747 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1748 p
->contents
[n
++] = AREF (seq
, i
);
1750 XSETVECTOR (seq
, p
);
1753 else if (STRINGP (seq
))
1755 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1758 for (i
= nchars
= nbytes
= ibyte
= 0;
1760 ++i
, ibyte
+= cbytes
)
1762 if (STRING_MULTIBYTE (seq
))
1764 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1765 SBYTES (seq
) - ibyte
);
1766 cbytes
= CHAR_BYTES (c
);
1774 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1781 if (nchars
!= SCHARS (seq
))
1785 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1786 if (!STRING_MULTIBYTE (seq
))
1787 STRING_SET_UNIBYTE (tem
);
1789 for (i
= nchars
= nbytes
= ibyte
= 0;
1791 ++i
, ibyte
+= cbytes
)
1793 if (STRING_MULTIBYTE (seq
))
1795 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1796 SBYTES (seq
) - ibyte
);
1797 cbytes
= CHAR_BYTES (c
);
1805 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1807 unsigned char *from
= SDATA (seq
) + ibyte
;
1808 unsigned char *to
= SDATA (tem
) + nbytes
;
1814 for (n
= cbytes
; n
--; )
1824 Lisp_Object tail
, prev
;
1826 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1829 wrong_type_argument (Qlistp
, seq
);
1831 if (!NILP (Fequal (elt
, XCAR (tail
))))
1836 Fsetcdr (prev
, XCDR (tail
));
1847 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1848 doc
: /* Reverse LIST by modifying cdr pointers.
1849 Return the reversed list. */)
1853 register Lisp_Object prev
, tail
, next
;
1855 if (NILP (list
)) return list
;
1858 while (!NILP (tail
))
1862 wrong_type_argument (Qlistp
, list
);
1864 Fsetcdr (tail
, prev
);
1871 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1872 doc
: /* Reverse LIST, copying. Return the reversed list.
1873 See also the function `nreverse', which is used more often. */)
1879 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1882 new = Fcons (XCAR (list
), new);
1885 wrong_type_argument (Qconsp
, list
);
1889 Lisp_Object
merge ();
1891 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1892 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1893 Returns the sorted list. LIST is modified by side effects.
1894 PREDICATE is called with two elements of LIST, and should return t
1895 if the first element is "less" than the second. */)
1897 Lisp_Object list
, predicate
;
1899 Lisp_Object front
, back
;
1900 register Lisp_Object len
, tem
;
1901 struct gcpro gcpro1
, gcpro2
;
1902 register int length
;
1905 len
= Flength (list
);
1906 length
= XINT (len
);
1910 XSETINT (len
, (length
/ 2) - 1);
1911 tem
= Fnthcdr (len
, list
);
1913 Fsetcdr (tem
, Qnil
);
1915 GCPRO2 (front
, back
);
1916 front
= Fsort (front
, predicate
);
1917 back
= Fsort (back
, predicate
);
1919 return merge (front
, back
, predicate
);
1923 merge (org_l1
, org_l2
, pred
)
1924 Lisp_Object org_l1
, org_l2
;
1928 register Lisp_Object tail
;
1930 register Lisp_Object l1
, l2
;
1931 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1938 /* It is sufficient to protect org_l1 and org_l2.
1939 When l1 and l2 are updated, we copy the new values
1940 back into the org_ vars. */
1941 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1961 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1977 Fsetcdr (tail
, tem
);
1983 #if 0 /* Unsafe version. */
1984 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1985 doc
: /* Extract a value from a property list.
1986 PLIST is a property list, which is a list of the form
1987 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1988 corresponding to the given PROP, or nil if PROP is not
1989 one of the properties on the list. */)
1997 CONSP (tail
) && CONSP (XCDR (tail
));
1998 tail
= XCDR (XCDR (tail
)))
2000 if (EQ (prop
, XCAR (tail
)))
2001 return XCAR (XCDR (tail
));
2003 /* This function can be called asynchronously
2004 (setup_coding_system). Don't QUIT in that case. */
2005 if (!interrupt_input_blocked
)
2010 wrong_type_argument (Qlistp
, prop
);
2016 /* This does not check for quits. That is safe since it must terminate. */
2018 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2019 doc
: /* Extract a value from a property list.
2020 PLIST is a property list, which is a list of the form
2021 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2022 corresponding to the given PROP, or nil if PROP is not one of the
2023 properties on the list. This function never signals an error. */)
2028 Lisp_Object tail
, halftail
;
2030 /* halftail is used to detect circular lists. */
2031 tail
= halftail
= plist
;
2032 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2034 if (EQ (prop
, XCAR (tail
)))
2035 return XCAR (XCDR (tail
));
2037 tail
= XCDR (XCDR (tail
));
2038 halftail
= XCDR (halftail
);
2039 if (EQ (tail
, halftail
))
2046 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2047 doc
: /* Return the value of SYMBOL's PROPNAME property.
2048 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2050 Lisp_Object symbol
, propname
;
2052 CHECK_SYMBOL (symbol
);
2053 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2056 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2057 doc
: /* Change value in PLIST of PROP to VAL.
2058 PLIST is a property list, which is a list of the form
2059 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2060 If PROP is already a property on the list, its value is set to VAL,
2061 otherwise the new PROP VAL pair is added. The new plist is returned;
2062 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2063 The PLIST is modified by side effects. */)
2066 register Lisp_Object prop
;
2069 register Lisp_Object tail
, prev
;
2070 Lisp_Object newcell
;
2072 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2073 tail
= XCDR (XCDR (tail
)))
2075 if (EQ (prop
, XCAR (tail
)))
2077 Fsetcar (XCDR (tail
), val
);
2084 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2088 Fsetcdr (XCDR (prev
), newcell
);
2092 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2093 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2094 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2095 (symbol
, propname
, value
)
2096 Lisp_Object symbol
, propname
, value
;
2098 CHECK_SYMBOL (symbol
);
2099 XSYMBOL (symbol
)->plist
2100 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2104 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2105 doc
: /* Extract a value from a property list, comparing with `equal'.
2106 PLIST is a property list, which is a list of the form
2107 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2108 corresponding to the given PROP, or nil if PROP is not
2109 one of the properties on the list. */)
2117 CONSP (tail
) && CONSP (XCDR (tail
));
2118 tail
= XCDR (XCDR (tail
)))
2120 if (! NILP (Fequal (prop
, XCAR (tail
))))
2121 return XCAR (XCDR (tail
));
2127 wrong_type_argument (Qlistp
, prop
);
2132 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2133 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2134 PLIST is a property list, which is a list of the form
2135 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2136 If PROP is already a property on the list, its value is set to VAL,
2137 otherwise the new PROP VAL pair is added. The new plist is returned;
2138 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2139 The PLIST is modified by side effects. */)
2142 register Lisp_Object prop
;
2145 register Lisp_Object tail
, prev
;
2146 Lisp_Object newcell
;
2148 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2149 tail
= XCDR (XCDR (tail
)))
2151 if (! NILP (Fequal (prop
, XCAR (tail
))))
2153 Fsetcar (XCDR (tail
), val
);
2160 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2164 Fsetcdr (XCDR (prev
), newcell
);
2168 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2169 doc
: /* Return t if the two args are the same Lisp object.
2170 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2172 Lisp_Object obj1
, obj2
;
2175 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2177 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2180 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2181 doc
: /* Return t if two Lisp objects have similar structure and contents.
2182 They must have the same data type.
2183 Conses are compared by comparing the cars and the cdrs.
2184 Vectors and strings are compared element by element.
2185 Numbers are compared by value, but integers cannot equal floats.
2186 (Use `=' if you want integers and floats to be able to be equal.)
2187 Symbols must match exactly. */)
2189 register Lisp_Object o1
, o2
;
2191 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2194 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2195 doc
: /* Return t if two Lisp objects have similar structure and contents.
2196 This is like `equal' except that it compares the text properties
2197 of strings. (`equal' ignores text properties.) */)
2199 register Lisp_Object o1
, o2
;
2201 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2204 /* DEPTH is current depth of recursion. Signal an error if it
2206 PROPS, if non-nil, means compare string text properties too. */
2209 internal_equal (o1
, o2
, depth
, props
)
2210 register Lisp_Object o1
, o2
;
2214 error ("Stack overflow in equal");
2220 if (XTYPE (o1
) != XTYPE (o2
))
2229 d1
= extract_float (o1
);
2230 d2
= extract_float (o2
);
2231 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2232 though they are not =. */
2233 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2237 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2244 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2248 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2250 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2253 o1
= XOVERLAY (o1
)->plist
;
2254 o2
= XOVERLAY (o2
)->plist
;
2259 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2260 && (XMARKER (o1
)->buffer
== 0
2261 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2265 case Lisp_Vectorlike
:
2268 EMACS_INT size
= XVECTOR (o1
)->size
;
2269 /* Pseudovectors have the type encoded in the size field, so this test
2270 actually checks that the objects have the same type as well as the
2272 if (XVECTOR (o2
)->size
!= size
)
2274 /* Boolvectors are compared much like strings. */
2275 if (BOOL_VECTOR_P (o1
))
2278 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2279 / BOOL_VECTOR_BITS_PER_CHAR
);
2281 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2283 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2288 if (WINDOW_CONFIGURATIONP (o1
))
2289 return compare_window_configurations (o1
, o2
, 0);
2291 /* Aside from them, only true vectors, char-tables, and compiled
2292 functions are sensible to compare, so eliminate the others now. */
2293 if (size
& PSEUDOVECTOR_FLAG
)
2295 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2297 size
&= PSEUDOVECTOR_SIZE_MASK
;
2299 for (i
= 0; i
< size
; i
++)
2302 v1
= XVECTOR (o1
)->contents
[i
];
2303 v2
= XVECTOR (o2
)->contents
[i
];
2304 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2312 if (SCHARS (o1
) != SCHARS (o2
))
2314 if (SBYTES (o1
) != SBYTES (o2
))
2316 if (bcmp (SDATA (o1
), SDATA (o2
),
2319 if (props
&& !compare_string_intervals (o1
, o2
))
2325 case Lisp_Type_Limit
:
2332 extern Lisp_Object
Fmake_char_internal ();
2334 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2335 doc
: /* Store each element of ARRAY with ITEM.
2336 ARRAY is a vector, string, char-table, or bool-vector. */)
2338 Lisp_Object array
, item
;
2340 register int size
, index
, charval
;
2342 if (VECTORP (array
))
2344 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2345 size
= XVECTOR (array
)->size
;
2346 for (index
= 0; index
< size
; index
++)
2349 else if (CHAR_TABLE_P (array
))
2351 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2352 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2353 for (index
= 0; index
< size
; index
++)
2355 XCHAR_TABLE (array
)->defalt
= Qnil
;
2357 else if (STRINGP (array
))
2359 register unsigned char *p
= SDATA (array
);
2360 CHECK_NUMBER (item
);
2361 charval
= XINT (item
);
2362 size
= SCHARS (array
);
2363 if (STRING_MULTIBYTE (array
))
2365 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2366 int len
= CHAR_STRING (charval
, str
);
2367 int size_byte
= SBYTES (array
);
2368 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2371 if (size
!= size_byte
)
2374 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2375 if (len
!= this_len
)
2376 error ("Attempt to change byte length of a string");
2379 for (i
= 0; i
< size_byte
; i
++)
2380 *p
++ = str
[i
% len
];
2383 for (index
= 0; index
< size
; index
++)
2386 else if (BOOL_VECTOR_P (array
))
2388 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2390 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2391 / BOOL_VECTOR_BITS_PER_CHAR
);
2393 charval
= (! NILP (item
) ? -1 : 0);
2394 for (index
= 0; index
< size_in_chars
- 1; index
++)
2396 if (index
< size_in_chars
)
2398 /* Mask out bits beyond the vector size. */
2399 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2400 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2406 array
= wrong_type_argument (Qarrayp
, array
);
2412 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2414 doc
: /* Clear the contents of STRING.
2415 This makes STRING unibyte and may change its length. */)
2420 CHECK_STRING (string
);
2421 len
= SBYTES (string
);
2422 bzero (SDATA (string
), len
);
2423 STRING_SET_CHARS (string
, len
);
2424 STRING_SET_UNIBYTE (string
);
2428 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2430 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2432 Lisp_Object char_table
;
2434 CHECK_CHAR_TABLE (char_table
);
2436 return XCHAR_TABLE (char_table
)->purpose
;
2439 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2441 doc
: /* Return the parent char-table of CHAR-TABLE.
2442 The value is either nil or another char-table.
2443 If CHAR-TABLE holds nil for a given character,
2444 then the actual applicable value is inherited from the parent char-table
2445 \(or from its parents, if necessary). */)
2447 Lisp_Object char_table
;
2449 CHECK_CHAR_TABLE (char_table
);
2451 return XCHAR_TABLE (char_table
)->parent
;
2454 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2456 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2457 Return PARENT. PARENT must be either nil or another char-table. */)
2458 (char_table
, parent
)
2459 Lisp_Object char_table
, parent
;
2463 CHECK_CHAR_TABLE (char_table
);
2467 CHECK_CHAR_TABLE (parent
);
2469 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2470 if (EQ (temp
, char_table
))
2471 error ("Attempt to make a chartable be its own parent");
2474 XCHAR_TABLE (char_table
)->parent
= parent
;
2479 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2481 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2483 Lisp_Object char_table
, n
;
2485 CHECK_CHAR_TABLE (char_table
);
2488 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2489 args_out_of_range (char_table
, n
);
2491 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2494 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2495 Sset_char_table_extra_slot
,
2497 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2498 (char_table
, n
, value
)
2499 Lisp_Object char_table
, n
, value
;
2501 CHECK_CHAR_TABLE (char_table
);
2504 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2505 args_out_of_range (char_table
, n
);
2507 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2510 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2512 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2513 RANGE should be nil (for the default value)
2514 a vector which identifies a character set or a row of a character set,
2515 a character set name, or a character code. */)
2517 Lisp_Object char_table
, range
;
2519 CHECK_CHAR_TABLE (char_table
);
2521 if (EQ (range
, Qnil
))
2522 return XCHAR_TABLE (char_table
)->defalt
;
2523 else if (INTEGERP (range
))
2524 return Faref (char_table
, range
);
2525 else if (SYMBOLP (range
))
2527 Lisp_Object charset_info
;
2529 charset_info
= Fget (range
, Qcharset
);
2530 CHECK_VECTOR (charset_info
);
2532 return Faref (char_table
,
2533 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2536 else if (VECTORP (range
))
2538 if (XVECTOR (range
)->size
== 1)
2539 return Faref (char_table
,
2540 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2543 int size
= XVECTOR (range
)->size
;
2544 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2545 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2546 size
<= 1 ? Qnil
: val
[1],
2547 size
<= 2 ? Qnil
: val
[2]);
2548 return Faref (char_table
, ch
);
2552 error ("Invalid RANGE argument to `char-table-range'");
2556 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2558 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2559 RANGE should be t (for all characters), nil (for the default value),
2560 a character set, a vector which identifies a character set, a row of a
2561 character set, or a character code. Return VALUE. */)
2562 (char_table
, range
, value
)
2563 Lisp_Object char_table
, range
, value
;
2567 CHECK_CHAR_TABLE (char_table
);
2570 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2572 /* Don't set these special slots used for default values of
2573 ascii, eight-bit-control, and eight-bit-graphic. */
2574 if (i
!= CHAR_TABLE_DEFAULT_SLOT_ASCII
2575 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2576 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
)
2577 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2579 else if (EQ (range
, Qnil
))
2580 XCHAR_TABLE (char_table
)->defalt
= value
;
2581 else if (SYMBOLP (range
))
2583 Lisp_Object charset_info
;
2586 charset_info
= Fget (range
, Qcharset
);
2587 if (! VECTORP (charset_info
)
2588 || ! NATNUMP (AREF (charset_info
, 0))
2589 || (charset_id
= XINT (AREF (charset_info
, 0)),
2590 ! CHARSET_DEFINED_P (charset_id
)))
2591 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2593 if (charset_id
== CHARSET_ASCII
)
2594 for (i
= 0; i
< 128; i
++)
2595 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2596 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2597 for (i
= 128; i
< 160; i
++)
2598 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2599 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2600 for (i
= 160; i
< 256; i
++)
2601 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2603 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2605 else if (INTEGERP (range
))
2606 Faset (char_table
, range
, value
);
2607 else if (VECTORP (range
))
2609 int size
= XVECTOR (range
)->size
;
2610 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2611 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2612 size
<= 1 ? Qnil
: val
[1],
2613 size
<= 2 ? Qnil
: val
[2]);
2614 Faset (char_table
, ch
, value
);
2617 error ("Invalid RANGE argument to `set-char-table-range'");
2622 DEFUN ("set-char-table-default", Fset_char_table_default
,
2623 Sset_char_table_default
, 3, 3, 0,
2624 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2625 The generic character specifies the group of characters.
2626 If CH is a normal character, set the default value for a group of
2627 characters to which CH belongs.
2628 See also the documentation of `make-char'. */)
2629 (char_table
, ch
, value
)
2630 Lisp_Object char_table
, ch
, value
;
2632 int c
, charset
, code1
, code2
;
2635 CHECK_CHAR_TABLE (char_table
);
2639 SPLIT_CHAR (c
, charset
, code1
, code2
);
2641 /* Since we may want to set the default value for a character set
2642 not yet defined, we check only if the character set is in the
2643 valid range or not, instead of it is already defined or not. */
2644 if (! CHARSET_VALID_P (charset
))
2645 invalid_character (c
);
2647 if (SINGLE_BYTE_CHAR_P (c
))
2649 /* We use special slots for the default values of single byte
2652 = (c
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2653 : c
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2654 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2656 return (XCHAR_TABLE (char_table
)->contents
[default_slot
] = value
);
2659 /* Even if C is not a generic char, we had better behave as if a
2660 generic char is specified. */
2661 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2663 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2664 if (! SUB_CHAR_TABLE_P (temp
))
2666 temp
= make_sub_char_table (temp
);
2667 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = temp
;
2671 XCHAR_TABLE (temp
)->defalt
= value
;
2675 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2676 if (SUB_CHAR_TABLE_P (temp
))
2677 XCHAR_TABLE (temp
)->defalt
= value
;
2679 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2683 /* Look up the element in TABLE at index CH,
2684 and return it as an integer.
2685 If the element is nil, return CH itself.
2686 (Actually we do that for any non-integer.) */
2689 char_table_translate (table
, ch
)
2694 value
= Faref (table
, make_number (ch
));
2695 if (! INTEGERP (value
))
2697 return XINT (value
);
2701 optimize_sub_char_table (table
, chars
)
2709 from
= 33, to
= 127;
2711 from
= 32, to
= 128;
2713 if (!SUB_CHAR_TABLE_P (*table
))
2715 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2716 for (; from
< to
; from
++)
2717 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2722 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2723 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2731 CHECK_CHAR_TABLE (table
);
2733 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2735 elt
= XCHAR_TABLE (table
)->contents
[i
];
2736 if (!SUB_CHAR_TABLE_P (elt
))
2738 dim
= CHARSET_DIMENSION (i
- 128);
2740 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2741 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2742 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2748 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2749 character or group of characters that share a value.
2750 DEPTH is the current depth in the originally specified
2751 chartable, and INDICES contains the vector indices
2752 for the levels our callers have descended.
2754 ARG is passed to C_FUNCTION when that is called. */
2757 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2758 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2759 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2763 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2765 GCPRO4 (arg
, table
, subtable
, function
);
2769 /* At first, handle ASCII and 8-bit European characters. */
2770 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2772 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2774 elt
= XCHAR_TABLE (subtable
)->defalt
;
2776 elt
= Faref (subtable
, make_number (i
));
2778 (*c_function
) (arg
, make_number (i
), elt
);
2780 call2 (function
, make_number (i
), elt
);
2782 #if 0 /* If the char table has entries for higher characters,
2783 we should report them. */
2784 if (NILP (current_buffer
->enable_multibyte_characters
))
2790 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2794 int charset
= XFASTINT (indices
[0]) - 128;
2797 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2798 if (CHARSET_CHARS (charset
) == 94)
2807 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2808 XSETFASTINT (indices
[depth
], i
);
2809 charset
= XFASTINT (indices
[0]) - 128;
2811 && (!CHARSET_DEFINED_P (charset
)
2812 || charset
== CHARSET_8_BIT_CONTROL
2813 || charset
== CHARSET_8_BIT_GRAPHIC
))
2816 if (SUB_CHAR_TABLE_P (elt
))
2819 error ("Too deep char table");
2820 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2826 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2827 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2828 c
= MAKE_CHAR (charset
, c1
, c2
);
2831 elt
= XCHAR_TABLE (subtable
)->defalt
;
2833 elt
= Faref (table
, make_number (c
));
2836 (*c_function
) (arg
, make_number (c
), elt
);
2838 call2 (function
, make_number (c
), elt
);
2844 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2846 void_call2 (a
, b
, c
)
2847 Lisp_Object a
, b
, c
;
2852 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2854 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2855 FUNCTION is called with two arguments--a key and a value.
2856 The key is always a possible IDX argument to `aref'. */)
2857 (function
, char_table
)
2858 Lisp_Object function
, char_table
;
2860 /* The depth of char table is at most 3. */
2861 Lisp_Object indices
[3];
2863 CHECK_CHAR_TABLE (char_table
);
2865 /* When Lisp_Object is represented as a union, `call2' cannot directly
2866 be passed to map_char_table because it returns a Lisp_Object rather
2867 than returning nothing.
2868 Casting leads to crashes on some architectures. -stef */
2869 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2873 /* Return a value for character C in char-table TABLE. Store the
2874 actual index for that value in *IDX. Ignore the default value of
2878 char_table_ref_and_index (table
, c
, idx
)
2882 int charset
, c1
, c2
;
2885 if (SINGLE_BYTE_CHAR_P (c
))
2888 return XCHAR_TABLE (table
)->contents
[c
];
2890 SPLIT_CHAR (c
, charset
, c1
, c2
);
2891 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2892 *idx
= MAKE_CHAR (charset
, 0, 0);
2893 if (!SUB_CHAR_TABLE_P (elt
))
2895 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2896 return XCHAR_TABLE (elt
)->defalt
;
2897 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2898 *idx
= MAKE_CHAR (charset
, c1
, 0);
2899 if (!SUB_CHAR_TABLE_P (elt
))
2901 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2902 return XCHAR_TABLE (elt
)->defalt
;
2904 return XCHAR_TABLE (elt
)->contents
[c2
];
2914 Lisp_Object args
[2];
2917 return Fnconc (2, args
);
2919 return Fnconc (2, &s1
);
2920 #endif /* NO_ARG_ARRAY */
2923 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2924 doc
: /* Concatenate any number of lists by altering them.
2925 Only the last argument is not altered, and need not be a list.
2926 usage: (nconc &rest LISTS) */)
2931 register int argnum
;
2932 register Lisp_Object tail
, tem
, val
;
2936 for (argnum
= 0; argnum
< nargs
; argnum
++)
2939 if (NILP (tem
)) continue;
2944 if (argnum
+ 1 == nargs
) break;
2947 tem
= wrong_type_argument (Qlistp
, tem
);
2956 tem
= args
[argnum
+ 1];
2957 Fsetcdr (tail
, tem
);
2959 args
[argnum
+ 1] = tail
;
2965 /* This is the guts of all mapping functions.
2966 Apply FN to each element of SEQ, one by one,
2967 storing the results into elements of VALS, a C vector of Lisp_Objects.
2968 LENI is the length of VALS, which should also be the length of SEQ. */
2971 mapcar1 (leni
, vals
, fn
, seq
)
2974 Lisp_Object fn
, seq
;
2976 register Lisp_Object tail
;
2979 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2983 /* Don't let vals contain any garbage when GC happens. */
2984 for (i
= 0; i
< leni
; i
++)
2987 GCPRO3 (dummy
, fn
, seq
);
2989 gcpro1
.nvars
= leni
;
2993 /* We need not explicitly protect `tail' because it is used only on lists, and
2994 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2998 for (i
= 0; i
< leni
; i
++)
3000 dummy
= XVECTOR (seq
)->contents
[i
];
3001 dummy
= call1 (fn
, dummy
);
3006 else if (BOOL_VECTOR_P (seq
))
3008 for (i
= 0; i
< leni
; i
++)
3011 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
3012 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
3017 dummy
= call1 (fn
, dummy
);
3022 else if (STRINGP (seq
))
3026 for (i
= 0, i_byte
= 0; i
< leni
;)
3031 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3032 XSETFASTINT (dummy
, c
);
3033 dummy
= call1 (fn
, dummy
);
3035 vals
[i_before
] = dummy
;
3038 else /* Must be a list, since Flength did not get an error */
3041 for (i
= 0; i
< leni
; i
++)
3043 dummy
= call1 (fn
, Fcar (tail
));
3053 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3054 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3055 In between each pair of results, stick in SEPARATOR. Thus, " " as
3056 SEPARATOR results in spaces between the values returned by FUNCTION.
3057 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3058 (function
, sequence
, separator
)
3059 Lisp_Object function
, sequence
, separator
;
3064 register Lisp_Object
*args
;
3066 struct gcpro gcpro1
;
3070 len
= Flength (sequence
);
3072 nargs
= leni
+ leni
- 1;
3073 if (nargs
< 0) return build_string ("");
3075 SAFE_ALLOCA_LISP (args
, nargs
);
3078 mapcar1 (leni
, args
, function
, sequence
);
3081 for (i
= leni
- 1; i
>= 0; i
--)
3082 args
[i
+ i
] = args
[i
];
3084 for (i
= 1; i
< nargs
; i
+= 2)
3085 args
[i
] = separator
;
3087 ret
= Fconcat (nargs
, args
);
3093 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3094 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3095 The result is a list just as long as SEQUENCE.
3096 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3097 (function
, sequence
)
3098 Lisp_Object function
, sequence
;
3100 register Lisp_Object len
;
3102 register Lisp_Object
*args
;
3106 len
= Flength (sequence
);
3107 leni
= XFASTINT (len
);
3109 SAFE_ALLOCA_LISP (args
, leni
);
3111 mapcar1 (leni
, args
, function
, sequence
);
3113 ret
= Flist (leni
, args
);
3119 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3120 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3121 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3122 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3123 (function
, sequence
)
3124 Lisp_Object function
, sequence
;
3128 leni
= XFASTINT (Flength (sequence
));
3129 mapcar1 (leni
, 0, function
, sequence
);
3134 /* Anything that calls this function must protect from GC! */
3136 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3137 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3138 Takes one argument, which is the string to display to ask the question.
3139 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3140 No confirmation of the answer is requested; a single character is enough.
3141 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3142 the bindings in `query-replace-map'; see the documentation of that variable
3143 for more information. In this case, the useful bindings are `act', `skip',
3144 `recenter', and `quit'.\)
3146 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3147 is nil and `use-dialog-box' is non-nil. */)
3151 register Lisp_Object obj
, key
, def
, map
;
3152 register int answer
;
3153 Lisp_Object xprompt
;
3154 Lisp_Object args
[2];
3155 struct gcpro gcpro1
, gcpro2
;
3156 int count
= SPECPDL_INDEX ();
3158 specbind (Qcursor_in_echo_area
, Qt
);
3160 map
= Fsymbol_value (intern ("query-replace-map"));
3162 CHECK_STRING (prompt
);
3164 GCPRO2 (prompt
, xprompt
);
3166 #ifdef HAVE_X_WINDOWS
3167 if (display_hourglass_p
)
3168 cancel_hourglass ();
3175 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3179 Lisp_Object pane
, menu
;
3180 redisplay_preserve_echo_area (3);
3181 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3182 Fcons (Fcons (build_string ("No"), Qnil
),
3184 menu
= Fcons (prompt
, pane
);
3185 obj
= Fx_popup_dialog (Qt
, menu
);
3186 answer
= !NILP (obj
);
3189 #endif /* HAVE_MENUS */
3190 cursor_in_echo_area
= 1;
3191 choose_minibuf_frame ();
3194 Lisp_Object pargs
[3];
3196 /* Colorize prompt according to `minibuffer-prompt' face. */
3197 pargs
[0] = build_string ("%s(y or n) ");
3198 pargs
[1] = intern ("face");
3199 pargs
[2] = intern ("minibuffer-prompt");
3200 args
[0] = Fpropertize (3, pargs
);
3205 if (minibuffer_auto_raise
)
3207 Lisp_Object mini_frame
;
3209 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3211 Fraise_frame (mini_frame
);
3214 obj
= read_filtered_event (1, 0, 0, 0);
3215 cursor_in_echo_area
= 0;
3216 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3219 key
= Fmake_vector (make_number (1), obj
);
3220 def
= Flookup_key (map
, key
, Qt
);
3222 if (EQ (def
, intern ("skip")))
3227 else if (EQ (def
, intern ("act")))
3232 else if (EQ (def
, intern ("recenter")))
3238 else if (EQ (def
, intern ("quit")))
3240 /* We want to exit this command for exit-prefix,
3241 and this is the only way to do it. */
3242 else if (EQ (def
, intern ("exit-prefix")))
3247 /* If we don't clear this, then the next call to read_char will
3248 return quit_char again, and we'll enter an infinite loop. */
3253 if (EQ (xprompt
, prompt
))
3255 args
[0] = build_string ("Please answer y or n. ");
3257 xprompt
= Fconcat (2, args
);
3262 if (! noninteractive
)
3264 cursor_in_echo_area
= -1;
3265 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3269 unbind_to (count
, Qnil
);
3270 return answer
? Qt
: Qnil
;
3273 /* This is how C code calls `yes-or-no-p' and allows the user
3276 Anything that calls this function must protect from GC! */
3279 do_yes_or_no_p (prompt
)
3282 return call1 (intern ("yes-or-no-p"), prompt
);
3285 /* Anything that calls this function must protect from GC! */
3287 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3288 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3289 Takes one argument, which is the string to display to ask the question.
3290 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3291 The user must confirm the answer with RET,
3292 and can edit it until it has been confirmed.
3294 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3295 is nil, and `use-dialog-box' is non-nil. */)
3299 register Lisp_Object ans
;
3300 Lisp_Object args
[2];
3301 struct gcpro gcpro1
;
3303 CHECK_STRING (prompt
);
3306 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3310 Lisp_Object pane
, menu
, obj
;
3311 redisplay_preserve_echo_area (4);
3312 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3313 Fcons (Fcons (build_string ("No"), Qnil
),
3316 menu
= Fcons (prompt
, pane
);
3317 obj
= Fx_popup_dialog (Qt
, menu
);
3321 #endif /* HAVE_MENUS */
3324 args
[1] = build_string ("(yes or no) ");
3325 prompt
= Fconcat (2, args
);
3331 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3332 Qyes_or_no_p_history
, Qnil
,
3334 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3339 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3347 message ("Please answer yes or no.");
3348 Fsleep_for (make_number (2), Qnil
);
3352 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3353 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3355 Each of the three load averages is multiplied by 100, then converted
3358 When USE-FLOATS is non-nil, floats will be used instead of integers.
3359 These floats are not multiplied by 100.
3361 If the 5-minute or 15-minute load averages are not available, return a
3362 shortened list, containing only those averages which are available.
3364 An error is thrown if the load average can't be obtained. In some
3365 cases making it work would require Emacs being installed setuid or
3366 setgid so that it can read kernel information, and that usually isn't
3369 Lisp_Object use_floats
;
3372 int loads
= getloadavg (load_ave
, 3);
3373 Lisp_Object ret
= Qnil
;
3376 error ("load-average not implemented for this operating system");
3380 Lisp_Object load
= (NILP (use_floats
) ?
3381 make_number ((int) (100.0 * load_ave
[loads
]))
3382 : make_float (load_ave
[loads
]));
3383 ret
= Fcons (load
, ret
);
3389 Lisp_Object Vfeatures
, Qsubfeatures
;
3390 extern Lisp_Object Vafter_load_alist
;
3392 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3393 doc
: /* Returns t if FEATURE is present in this Emacs.
3395 Use this to conditionalize execution of lisp code based on the
3396 presence or absence of emacs or environment extensions.
3397 Use `provide' to declare that a feature is available. This function
3398 looks at the value of the variable `features'. The optional argument
3399 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3400 (feature
, subfeature
)
3401 Lisp_Object feature
, subfeature
;
3403 register Lisp_Object tem
;
3404 CHECK_SYMBOL (feature
);
3405 tem
= Fmemq (feature
, Vfeatures
);
3406 if (!NILP (tem
) && !NILP (subfeature
))
3407 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3408 return (NILP (tem
)) ? Qnil
: Qt
;
3411 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3412 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3413 The optional argument SUBFEATURES should be a list of symbols listing
3414 particular subfeatures supported in this version of FEATURE. */)
3415 (feature
, subfeatures
)
3416 Lisp_Object feature
, subfeatures
;
3418 register Lisp_Object tem
;
3419 CHECK_SYMBOL (feature
);
3420 CHECK_LIST (subfeatures
);
3421 if (!NILP (Vautoload_queue
))
3422 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3423 tem
= Fmemq (feature
, Vfeatures
);
3425 Vfeatures
= Fcons (feature
, Vfeatures
);
3426 if (!NILP (subfeatures
))
3427 Fput (feature
, Qsubfeatures
, subfeatures
);
3428 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3430 /* Run any load-hooks for this file. */
3431 tem
= Fassq (feature
, Vafter_load_alist
);
3433 Fprogn (XCDR (tem
));
3438 /* `require' and its subroutines. */
3440 /* List of features currently being require'd, innermost first. */
3442 Lisp_Object require_nesting_list
;
3445 require_unwind (old_value
)
3446 Lisp_Object old_value
;
3448 return require_nesting_list
= old_value
;
3451 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3452 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3453 If FEATURE is not a member of the list `features', then the feature
3454 is not loaded; so load the file FILENAME.
3455 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3456 and `load' will try to load this name appended with the suffix `.elc' or
3457 `.el', in that order. The name without appended suffix will not be used.
3458 If the optional third argument NOERROR is non-nil,
3459 then return nil if the file is not found instead of signaling an error.
3460 Normally the return value is FEATURE.
3461 The normal messages at start and end of loading FILENAME are suppressed. */)
3462 (feature
, filename
, noerror
)
3463 Lisp_Object feature
, filename
, noerror
;
3465 register Lisp_Object tem
;
3466 struct gcpro gcpro1
, gcpro2
;
3468 CHECK_SYMBOL (feature
);
3470 /* Record the presence of `require' in this file
3471 even if the feature specified is already loaded.
3472 But not more than once in any file,
3473 and not when we aren't loading a file. */
3474 if (load_in_progress
)
3476 tem
= Fcons (Qrequire
, feature
);
3477 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3478 LOADHIST_ATTACH (tem
);
3480 tem
= Fmemq (feature
, Vfeatures
);
3484 int count
= SPECPDL_INDEX ();
3487 /* This is to make sure that loadup.el gives a clear picture
3488 of what files are preloaded and when. */
3489 if (! NILP (Vpurify_flag
))
3490 error ("(require %s) while preparing to dump",
3491 SDATA (SYMBOL_NAME (feature
)));
3493 /* A certain amount of recursive `require' is legitimate,
3494 but if we require the same feature recursively 3 times,
3496 tem
= require_nesting_list
;
3497 while (! NILP (tem
))
3499 if (! NILP (Fequal (feature
, XCAR (tem
))))
3504 error ("Recursive `require' for feature `%s'",
3505 SDATA (SYMBOL_NAME (feature
)));
3507 /* Update the list for any nested `require's that occur. */
3508 record_unwind_protect (require_unwind
, require_nesting_list
);
3509 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3511 /* Value saved here is to be restored into Vautoload_queue */
3512 record_unwind_protect (un_autoload
, Vautoload_queue
);
3513 Vautoload_queue
= Qt
;
3515 /* Load the file. */
3516 GCPRO2 (feature
, filename
);
3517 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3518 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3521 /* If load failed entirely, return nil. */
3523 return unbind_to (count
, Qnil
);
3525 tem
= Fmemq (feature
, Vfeatures
);
3527 error ("Required feature `%s' was not provided",
3528 SDATA (SYMBOL_NAME (feature
)));
3530 /* Once loading finishes, don't undo it. */
3531 Vautoload_queue
= Qt
;
3532 feature
= unbind_to (count
, feature
);
3538 /* Primitives for work of the "widget" library.
3539 In an ideal world, this section would not have been necessary.
3540 However, lisp function calls being as slow as they are, it turns
3541 out that some functions in the widget library (wid-edit.el) are the
3542 bottleneck of Widget operation. Here is their translation to C,
3543 for the sole reason of efficiency. */
3545 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3546 doc
: /* Return non-nil if PLIST has the property PROP.
3547 PLIST is a property list, which is a list of the form
3548 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3549 Unlike `plist-get', this allows you to distinguish between a missing
3550 property and a property with the value nil.
3551 The value is actually the tail of PLIST whose car is PROP. */)
3553 Lisp_Object plist
, prop
;
3555 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3558 plist
= XCDR (plist
);
3559 plist
= CDR (plist
);
3564 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3565 doc
: /* In WIDGET, set PROPERTY to VALUE.
3566 The value can later be retrieved with `widget-get'. */)
3567 (widget
, property
, value
)
3568 Lisp_Object widget
, property
, value
;
3570 CHECK_CONS (widget
);
3571 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3575 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3576 doc
: /* In WIDGET, get the value of PROPERTY.
3577 The value could either be specified when the widget was created, or
3578 later with `widget-put'. */)
3580 Lisp_Object widget
, property
;
3588 CHECK_CONS (widget
);
3589 tmp
= Fplist_member (XCDR (widget
), property
);
3595 tmp
= XCAR (widget
);
3598 widget
= Fget (tmp
, Qwidget_type
);
3602 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3603 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3604 ARGS are passed as extra arguments to the function.
3605 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3610 /* This function can GC. */
3611 Lisp_Object newargs
[3];
3612 struct gcpro gcpro1
, gcpro2
;
3615 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3616 newargs
[1] = args
[0];
3617 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3618 GCPRO2 (newargs
[0], newargs
[2]);
3619 result
= Fapply (3, newargs
);
3624 #ifdef HAVE_LANGINFO_CODESET
3625 #include <langinfo.h>
3628 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3629 doc
: /* Access locale data ITEM for the current C locale, if available.
3630 ITEM should be one of the following:
3632 `codeset', returning the character set as a string (locale item CODESET);
3634 `days', returning a 7-element vector of day names (locale items DAY_n);
3636 `months', returning a 12-element vector of month names (locale items MON_n);
3638 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3639 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3641 If the system can't provide such information through a call to
3642 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3644 See also Info node `(libc)Locales'.
3646 The data read from the system are decoded using `locale-coding-system'. */)
3651 #ifdef HAVE_LANGINFO_CODESET
3653 if (EQ (item
, Qcodeset
))
3655 str
= nl_langinfo (CODESET
);
3656 return build_string (str
);
3659 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3661 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3662 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3664 synchronize_system_time_locale ();
3665 for (i
= 0; i
< 7; i
++)
3667 str
= nl_langinfo (days
[i
]);
3668 val
= make_unibyte_string (str
, strlen (str
));
3669 /* Fixme: Is this coding system necessarily right, even if
3670 it is consistent with CODESET? If not, what to do? */
3671 Faset (v
, make_number (i
),
3672 code_convert_string_norecord (val
, Vlocale_coding_system
,
3679 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3681 struct Lisp_Vector
*p
= allocate_vector (12);
3682 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3683 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3685 synchronize_system_time_locale ();
3686 for (i
= 0; i
< 12; i
++)
3688 str
= nl_langinfo (months
[i
]);
3689 val
= make_unibyte_string (str
, strlen (str
));
3691 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3693 XSETVECTOR (val
, p
);
3697 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3698 but is in the locale files. This could be used by ps-print. */
3700 else if (EQ (item
, Qpaper
))
3702 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3703 make_number (nl_langinfo (PAPER_HEIGHT
)));
3705 #endif /* PAPER_WIDTH */
3706 #endif /* HAVE_LANGINFO_CODESET*/
3710 /* base64 encode/decode functions (RFC 2045).
3711 Based on code from GNU recode. */
3713 #define MIME_LINE_LENGTH 76
3715 #define IS_ASCII(Character) \
3717 #define IS_BASE64(Character) \
3718 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3719 #define IS_BASE64_IGNORABLE(Character) \
3720 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3721 || (Character) == '\f' || (Character) == '\r')
3723 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3724 character or return retval if there are no characters left to
3726 #define READ_QUADRUPLET_BYTE(retval) \
3731 if (nchars_return) \
3732 *nchars_return = nchars; \
3737 while (IS_BASE64_IGNORABLE (c))
3739 /* Table of characters coding the 64 values. */
3740 static char base64_value_to_char
[64] =
3742 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3743 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3744 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3745 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3746 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3747 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3748 '8', '9', '+', '/' /* 60-63 */
3751 /* Table of base64 values for first 128 characters. */
3752 static short base64_char_to_value
[128] =
3754 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3755 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3756 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3757 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3758 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3759 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3760 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3761 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3762 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3763 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3764 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3765 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3766 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3769 /* The following diagram shows the logical steps by which three octets
3770 get transformed into four base64 characters.
3772 .--------. .--------. .--------.
3773 |aaaaaabb| |bbbbcccc| |ccdddddd|
3774 `--------' `--------' `--------'
3776 .--------+--------+--------+--------.
3777 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3778 `--------+--------+--------+--------'
3780 .--------+--------+--------+--------.
3781 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3782 `--------+--------+--------+--------'
3784 The octets are divided into 6 bit chunks, which are then encoded into
3785 base64 characters. */
3788 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3789 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3791 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3793 doc
: /* Base64-encode the region between BEG and END.
3794 Return the length of the encoded text.
3795 Optional third argument NO-LINE-BREAK means do not break long lines
3796 into shorter lines. */)
3797 (beg
, end
, no_line_break
)
3798 Lisp_Object beg
, end
, no_line_break
;
3801 int allength
, length
;
3802 int ibeg
, iend
, encoded_length
;
3806 validate_region (&beg
, &end
);
3808 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3809 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3810 move_gap_both (XFASTINT (beg
), ibeg
);
3812 /* We need to allocate enough room for encoding the text.
3813 We need 33 1/3% more space, plus a newline every 76
3814 characters, and then we round up. */
3815 length
= iend
- ibeg
;
3816 allength
= length
+ length
/3 + 1;
3817 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3819 SAFE_ALLOCA (encoded
, char *, allength
);
3820 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3821 NILP (no_line_break
),
3822 !NILP (current_buffer
->enable_multibyte_characters
));
3823 if (encoded_length
> allength
)
3826 if (encoded_length
< 0)
3828 /* The encoding wasn't possible. */
3830 error ("Multibyte character in data for base64 encoding");
3833 /* Now we have encoded the region, so we insert the new contents
3834 and delete the old. (Insert first in order to preserve markers.) */
3835 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3836 insert (encoded
, encoded_length
);
3838 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3840 /* If point was outside of the region, restore it exactly; else just
3841 move to the beginning of the region. */
3842 if (old_pos
>= XFASTINT (end
))
3843 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3844 else if (old_pos
> XFASTINT (beg
))
3845 old_pos
= XFASTINT (beg
);
3848 /* We return the length of the encoded text. */
3849 return make_number (encoded_length
);
3852 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3854 doc
: /* Base64-encode STRING and return the result.
3855 Optional second argument NO-LINE-BREAK means do not break long lines
3856 into shorter lines. */)
3857 (string
, no_line_break
)
3858 Lisp_Object string
, no_line_break
;
3860 int allength
, length
, encoded_length
;
3862 Lisp_Object encoded_string
;
3865 CHECK_STRING (string
);
3867 /* We need to allocate enough room for encoding the text.
3868 We need 33 1/3% more space, plus a newline every 76
3869 characters, and then we round up. */
3870 length
= SBYTES (string
);
3871 allength
= length
+ length
/3 + 1;
3872 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3874 /* We need to allocate enough room for decoding the text. */
3875 SAFE_ALLOCA (encoded
, char *, allength
);
3877 encoded_length
= base64_encode_1 (SDATA (string
),
3878 encoded
, length
, NILP (no_line_break
),
3879 STRING_MULTIBYTE (string
));
3880 if (encoded_length
> allength
)
3883 if (encoded_length
< 0)
3885 /* The encoding wasn't possible. */
3887 error ("Multibyte character in data for base64 encoding");
3890 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3893 return encoded_string
;
3897 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3904 int counter
= 0, i
= 0;
3914 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3922 /* Wrap line every 76 characters. */
3926 if (counter
< MIME_LINE_LENGTH
/ 4)
3935 /* Process first byte of a triplet. */
3937 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3938 value
= (0x03 & c
) << 4;
3940 /* Process second byte of a triplet. */
3944 *e
++ = base64_value_to_char
[value
];
3952 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3960 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3961 value
= (0x0f & c
) << 2;
3963 /* Process third byte of a triplet. */
3967 *e
++ = base64_value_to_char
[value
];
3974 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3982 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3983 *e
++ = base64_value_to_char
[0x3f & c
];
3990 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3992 doc
: /* Base64-decode the region between BEG and END.
3993 Return the length of the decoded text.
3994 If the region can't be decoded, signal an error and don't modify the buffer. */)
3996 Lisp_Object beg
, end
;
3998 int ibeg
, iend
, length
, allength
;
4003 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
4006 validate_region (&beg
, &end
);
4008 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
4009 iend
= CHAR_TO_BYTE (XFASTINT (end
));
4011 length
= iend
- ibeg
;
4013 /* We need to allocate enough room for decoding the text. If we are
4014 working on a multibyte buffer, each decoded code may occupy at
4016 allength
= multibyte
? length
* 2 : length
;
4017 SAFE_ALLOCA (decoded
, char *, allength
);
4019 move_gap_both (XFASTINT (beg
), ibeg
);
4020 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
4021 multibyte
, &inserted_chars
);
4022 if (decoded_length
> allength
)
4025 if (decoded_length
< 0)
4027 /* The decoding wasn't possible. */
4029 error ("Invalid base64 data");
4032 /* Now we have decoded the region, so we insert the new contents
4033 and delete the old. (Insert first in order to preserve markers.) */
4034 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4035 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4038 /* Delete the original text. */
4039 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4040 iend
+ decoded_length
, 1);
4042 /* If point was outside of the region, restore it exactly; else just
4043 move to the beginning of the region. */
4044 if (old_pos
>= XFASTINT (end
))
4045 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4046 else if (old_pos
> XFASTINT (beg
))
4047 old_pos
= XFASTINT (beg
);
4048 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4050 return make_number (inserted_chars
);
4053 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4055 doc
: /* Base64-decode STRING and return the result. */)
4060 int length
, decoded_length
;
4061 Lisp_Object decoded_string
;
4064 CHECK_STRING (string
);
4066 length
= SBYTES (string
);
4067 /* We need to allocate enough room for decoding the text. */
4068 SAFE_ALLOCA (decoded
, char *, length
);
4070 /* The decoded result should be unibyte. */
4071 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4073 if (decoded_length
> length
)
4075 else if (decoded_length
>= 0)
4076 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4078 decoded_string
= Qnil
;
4081 if (!STRINGP (decoded_string
))
4082 error ("Invalid base64 data");
4084 return decoded_string
;
4087 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4088 MULTIBYTE is nonzero, the decoded result should be in multibyte
4089 form. If NCHARS_RETRUN is not NULL, store the number of produced
4090 characters in *NCHARS_RETURN. */
4093 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4103 unsigned long value
;
4108 /* Process first byte of a quadruplet. */
4110 READ_QUADRUPLET_BYTE (e
-to
);
4114 value
= base64_char_to_value
[c
] << 18;
4116 /* Process second byte of a quadruplet. */
4118 READ_QUADRUPLET_BYTE (-1);
4122 value
|= base64_char_to_value
[c
] << 12;
4124 c
= (unsigned char) (value
>> 16);
4126 e
+= CHAR_STRING (c
, e
);
4131 /* Process third byte of a quadruplet. */
4133 READ_QUADRUPLET_BYTE (-1);
4137 READ_QUADRUPLET_BYTE (-1);
4146 value
|= base64_char_to_value
[c
] << 6;
4148 c
= (unsigned char) (0xff & value
>> 8);
4150 e
+= CHAR_STRING (c
, e
);
4155 /* Process fourth byte of a quadruplet. */
4157 READ_QUADRUPLET_BYTE (-1);
4164 value
|= base64_char_to_value
[c
];
4166 c
= (unsigned char) (0xff & value
);
4168 e
+= CHAR_STRING (c
, e
);
4177 /***********************************************************************
4179 ***** Hash Tables *****
4181 ***********************************************************************/
4183 /* Implemented by gerd@gnu.org. This hash table implementation was
4184 inspired by CMUCL hash tables. */
4188 1. For small tables, association lists are probably faster than
4189 hash tables because they have lower overhead.
4191 For uses of hash tables where the O(1) behavior of table
4192 operations is not a requirement, it might therefore be a good idea
4193 not to hash. Instead, we could just do a linear search in the
4194 key_and_value vector of the hash table. This could be done
4195 if a `:linear-search t' argument is given to make-hash-table. */
4198 /* The list of all weak hash tables. Don't staticpro this one. */
4200 Lisp_Object Vweak_hash_tables
;
4202 /* Various symbols. */
4204 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4205 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4206 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4208 /* Function prototypes. */
4210 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4211 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4212 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4213 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4214 Lisp_Object
, unsigned));
4215 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4216 Lisp_Object
, unsigned));
4217 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4218 unsigned, Lisp_Object
, unsigned));
4219 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4220 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4221 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4222 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4224 static unsigned sxhash_string
P_ ((unsigned char *, int));
4225 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4226 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4227 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4228 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4232 /***********************************************************************
4234 ***********************************************************************/
4236 /* If OBJ is a Lisp hash table, return a pointer to its struct
4237 Lisp_Hash_Table. Otherwise, signal an error. */
4239 static struct Lisp_Hash_Table
*
4240 check_hash_table (obj
)
4243 CHECK_HASH_TABLE (obj
);
4244 return XHASH_TABLE (obj
);
4248 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4252 next_almost_prime (n
)
4265 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4266 which USED[I] is non-zero. If found at index I in ARGS, set
4267 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4268 -1. This function is used to extract a keyword/argument pair from
4269 a DEFUN parameter list. */
4272 get_key_arg (key
, nargs
, args
, used
)
4280 for (i
= 0; i
< nargs
- 1; ++i
)
4281 if (!used
[i
] && EQ (args
[i
], key
))
4296 /* Return a Lisp vector which has the same contents as VEC but has
4297 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4298 vector that are not copied from VEC are set to INIT. */
4301 larger_vector (vec
, new_size
, init
)
4306 struct Lisp_Vector
*v
;
4309 xassert (VECTORP (vec
));
4310 old_size
= XVECTOR (vec
)->size
;
4311 xassert (new_size
>= old_size
);
4313 v
= allocate_vector (new_size
);
4314 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4315 old_size
* sizeof *v
->contents
);
4316 for (i
= old_size
; i
< new_size
; ++i
)
4317 v
->contents
[i
] = init
;
4318 XSETVECTOR (vec
, v
);
4323 /***********************************************************************
4325 ***********************************************************************/
4327 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4328 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4329 KEY2 are the same. */
4332 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4333 struct Lisp_Hash_Table
*h
;
4334 Lisp_Object key1
, key2
;
4335 unsigned hash1
, hash2
;
4337 return (FLOATP (key1
)
4339 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4343 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4344 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4345 KEY2 are the same. */
4348 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4349 struct Lisp_Hash_Table
*h
;
4350 Lisp_Object key1
, key2
;
4351 unsigned hash1
, hash2
;
4353 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4357 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4358 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4359 if KEY1 and KEY2 are the same. */
4362 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4363 struct Lisp_Hash_Table
*h
;
4364 Lisp_Object key1
, key2
;
4365 unsigned hash1
, hash2
;
4369 Lisp_Object args
[3];
4371 args
[0] = h
->user_cmp_function
;
4374 return !NILP (Ffuncall (3, args
));
4381 /* Value is a hash code for KEY for use in hash table H which uses
4382 `eq' to compare keys. The hash code returned is guaranteed to fit
4383 in a Lisp integer. */
4387 struct Lisp_Hash_Table
*h
;
4390 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4391 xassert ((hash
& ~INTMASK
) == 0);
4396 /* Value is a hash code for KEY for use in hash table H which uses
4397 `eql' to compare keys. The hash code returned is guaranteed to fit
4398 in a Lisp integer. */
4402 struct Lisp_Hash_Table
*h
;
4407 hash
= sxhash (key
, 0);
4409 hash
= XUINT (key
) ^ XGCTYPE (key
);
4410 xassert ((hash
& ~INTMASK
) == 0);
4415 /* Value is a hash code for KEY for use in hash table H which uses
4416 `equal' to compare keys. The hash code returned is guaranteed to fit
4417 in a Lisp integer. */
4420 hashfn_equal (h
, key
)
4421 struct Lisp_Hash_Table
*h
;
4424 unsigned hash
= sxhash (key
, 0);
4425 xassert ((hash
& ~INTMASK
) == 0);
4430 /* Value is a hash code for KEY for use in hash table H which uses as
4431 user-defined function to compare keys. The hash code returned is
4432 guaranteed to fit in a Lisp integer. */
4435 hashfn_user_defined (h
, key
)
4436 struct Lisp_Hash_Table
*h
;
4439 Lisp_Object args
[2], hash
;
4441 args
[0] = h
->user_hash_function
;
4443 hash
= Ffuncall (2, args
);
4444 if (!INTEGERP (hash
))
4446 list2 (build_string ("Invalid hash code returned from \
4447 user-supplied hash function"),
4449 return XUINT (hash
);
4453 /* Create and initialize a new hash table.
4455 TEST specifies the test the hash table will use to compare keys.
4456 It must be either one of the predefined tests `eq', `eql' or
4457 `equal' or a symbol denoting a user-defined test named TEST with
4458 test and hash functions USER_TEST and USER_HASH.
4460 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4462 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4463 new size when it becomes full is computed by adding REHASH_SIZE to
4464 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4465 table's new size is computed by multiplying its old size with
4468 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4469 be resized when the ratio of (number of entries in the table) /
4470 (table size) is >= REHASH_THRESHOLD.
4472 WEAK specifies the weakness of the table. If non-nil, it must be
4473 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4476 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4477 user_test
, user_hash
)
4478 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4479 Lisp_Object user_test
, user_hash
;
4481 struct Lisp_Hash_Table
*h
;
4483 int index_size
, i
, sz
;
4485 /* Preconditions. */
4486 xassert (SYMBOLP (test
));
4487 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4488 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4489 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4490 xassert (FLOATP (rehash_threshold
)
4491 && XFLOATINT (rehash_threshold
) > 0
4492 && XFLOATINT (rehash_threshold
) <= 1.0);
4494 if (XFASTINT (size
) == 0)
4495 size
= make_number (1);
4497 /* Allocate a table and initialize it. */
4498 h
= allocate_hash_table ();
4500 /* Initialize hash table slots. */
4501 sz
= XFASTINT (size
);
4504 if (EQ (test
, Qeql
))
4506 h
->cmpfn
= cmpfn_eql
;
4507 h
->hashfn
= hashfn_eql
;
4509 else if (EQ (test
, Qeq
))
4512 h
->hashfn
= hashfn_eq
;
4514 else if (EQ (test
, Qequal
))
4516 h
->cmpfn
= cmpfn_equal
;
4517 h
->hashfn
= hashfn_equal
;
4521 h
->user_cmp_function
= user_test
;
4522 h
->user_hash_function
= user_hash
;
4523 h
->cmpfn
= cmpfn_user_defined
;
4524 h
->hashfn
= hashfn_user_defined
;
4528 h
->rehash_threshold
= rehash_threshold
;
4529 h
->rehash_size
= rehash_size
;
4530 h
->count
= make_number (0);
4531 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4532 h
->hash
= Fmake_vector (size
, Qnil
);
4533 h
->next
= Fmake_vector (size
, Qnil
);
4534 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4535 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4536 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4538 /* Set up the free list. */
4539 for (i
= 0; i
< sz
- 1; ++i
)
4540 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4541 h
->next_free
= make_number (0);
4543 XSET_HASH_TABLE (table
, h
);
4544 xassert (HASH_TABLE_P (table
));
4545 xassert (XHASH_TABLE (table
) == h
);
4547 /* Maybe add this hash table to the list of all weak hash tables. */
4549 h
->next_weak
= Qnil
;
4552 h
->next_weak
= Vweak_hash_tables
;
4553 Vweak_hash_tables
= table
;
4560 /* Return a copy of hash table H1. Keys and values are not copied,
4561 only the table itself is. */
4564 copy_hash_table (h1
)
4565 struct Lisp_Hash_Table
*h1
;
4568 struct Lisp_Hash_Table
*h2
;
4569 struct Lisp_Vector
*next
;
4571 h2
= allocate_hash_table ();
4572 next
= h2
->vec_next
;
4573 bcopy (h1
, h2
, sizeof *h2
);
4574 h2
->vec_next
= next
;
4575 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4576 h2
->hash
= Fcopy_sequence (h1
->hash
);
4577 h2
->next
= Fcopy_sequence (h1
->next
);
4578 h2
->index
= Fcopy_sequence (h1
->index
);
4579 XSET_HASH_TABLE (table
, h2
);
4581 /* Maybe add this hash table to the list of all weak hash tables. */
4582 if (!NILP (h2
->weak
))
4584 h2
->next_weak
= Vweak_hash_tables
;
4585 Vweak_hash_tables
= table
;
4592 /* Resize hash table H if it's too full. If H cannot be resized
4593 because it's already too large, throw an error. */
4596 maybe_resize_hash_table (h
)
4597 struct Lisp_Hash_Table
*h
;
4599 if (NILP (h
->next_free
))
4601 int old_size
= HASH_TABLE_SIZE (h
);
4602 int i
, new_size
, index_size
;
4604 if (INTEGERP (h
->rehash_size
))
4605 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4607 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4608 new_size
= max (old_size
+ 1, new_size
);
4609 index_size
= next_almost_prime ((int)
4611 / XFLOATINT (h
->rehash_threshold
)));
4612 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4613 error ("Hash table too large to resize");
4615 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4616 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4617 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4618 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4620 /* Update the free list. Do it so that new entries are added at
4621 the end of the free list. This makes some operations like
4623 for (i
= old_size
; i
< new_size
- 1; ++i
)
4624 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4626 if (!NILP (h
->next_free
))
4628 Lisp_Object last
, next
;
4630 last
= h
->next_free
;
4631 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4635 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4638 XSETFASTINT (h
->next_free
, old_size
);
4641 for (i
= 0; i
< old_size
; ++i
)
4642 if (!NILP (HASH_HASH (h
, i
)))
4644 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4645 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4646 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4647 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4653 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4654 the hash code of KEY. Value is the index of the entry in H
4655 matching KEY, or -1 if not found. */
4658 hash_lookup (h
, key
, hash
)
4659 struct Lisp_Hash_Table
*h
;
4664 int start_of_bucket
;
4667 hash_code
= h
->hashfn (h
, key
);
4671 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4672 idx
= HASH_INDEX (h
, start_of_bucket
);
4674 /* We need not gcpro idx since it's either an integer or nil. */
4677 int i
= XFASTINT (idx
);
4678 if (EQ (key
, HASH_KEY (h
, i
))
4680 && h
->cmpfn (h
, key
, hash_code
,
4681 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4683 idx
= HASH_NEXT (h
, i
);
4686 return NILP (idx
) ? -1 : XFASTINT (idx
);
4690 /* Put an entry into hash table H that associates KEY with VALUE.
4691 HASH is a previously computed hash code of KEY.
4692 Value is the index of the entry in H matching KEY. */
4695 hash_put (h
, key
, value
, hash
)
4696 struct Lisp_Hash_Table
*h
;
4697 Lisp_Object key
, value
;
4700 int start_of_bucket
, i
;
4702 xassert ((hash
& ~INTMASK
) == 0);
4704 /* Increment count after resizing because resizing may fail. */
4705 maybe_resize_hash_table (h
);
4706 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4708 /* Store key/value in the key_and_value vector. */
4709 i
= XFASTINT (h
->next_free
);
4710 h
->next_free
= HASH_NEXT (h
, i
);
4711 HASH_KEY (h
, i
) = key
;
4712 HASH_VALUE (h
, i
) = value
;
4714 /* Remember its hash code. */
4715 HASH_HASH (h
, i
) = make_number (hash
);
4717 /* Add new entry to its collision chain. */
4718 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4719 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4720 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4725 /* Remove the entry matching KEY from hash table H, if there is one. */
4728 hash_remove (h
, key
)
4729 struct Lisp_Hash_Table
*h
;
4733 int start_of_bucket
;
4734 Lisp_Object idx
, prev
;
4736 hash_code
= h
->hashfn (h
, key
);
4737 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4738 idx
= HASH_INDEX (h
, start_of_bucket
);
4741 /* We need not gcpro idx, prev since they're either integers or nil. */
4744 int i
= XFASTINT (idx
);
4746 if (EQ (key
, HASH_KEY (h
, i
))
4748 && h
->cmpfn (h
, key
, hash_code
,
4749 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4751 /* Take entry out of collision chain. */
4753 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4755 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4757 /* Clear slots in key_and_value and add the slots to
4759 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4760 HASH_NEXT (h
, i
) = h
->next_free
;
4761 h
->next_free
= make_number (i
);
4762 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4763 xassert (XINT (h
->count
) >= 0);
4769 idx
= HASH_NEXT (h
, i
);
4775 /* Clear hash table H. */
4779 struct Lisp_Hash_Table
*h
;
4781 if (XFASTINT (h
->count
) > 0)
4783 int i
, size
= HASH_TABLE_SIZE (h
);
4785 for (i
= 0; i
< size
; ++i
)
4787 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4788 HASH_KEY (h
, i
) = Qnil
;
4789 HASH_VALUE (h
, i
) = Qnil
;
4790 HASH_HASH (h
, i
) = Qnil
;
4793 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4794 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4796 h
->next_free
= make_number (0);
4797 h
->count
= make_number (0);
4803 /************************************************************************
4805 ************************************************************************/
4807 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4808 entries from the table that don't survive the current GC.
4809 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4810 non-zero if anything was marked. */
4813 sweep_weak_table (h
, remove_entries_p
)
4814 struct Lisp_Hash_Table
*h
;
4815 int remove_entries_p
;
4817 int bucket
, n
, marked
;
4819 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4822 for (bucket
= 0; bucket
< n
; ++bucket
)
4824 Lisp_Object idx
, next
, prev
;
4826 /* Follow collision chain, removing entries that
4827 don't survive this garbage collection. */
4829 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4831 int i
= XFASTINT (idx
);
4832 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4833 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4836 if (EQ (h
->weak
, Qkey
))
4837 remove_p
= !key_known_to_survive_p
;
4838 else if (EQ (h
->weak
, Qvalue
))
4839 remove_p
= !value_known_to_survive_p
;
4840 else if (EQ (h
->weak
, Qkey_or_value
))
4841 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4842 else if (EQ (h
->weak
, Qkey_and_value
))
4843 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4847 next
= HASH_NEXT (h
, i
);
4849 if (remove_entries_p
)
4853 /* Take out of collision chain. */
4855 HASH_INDEX (h
, bucket
) = next
;
4857 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4859 /* Add to free list. */
4860 HASH_NEXT (h
, i
) = h
->next_free
;
4863 /* Clear key, value, and hash. */
4864 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4865 HASH_HASH (h
, i
) = Qnil
;
4867 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4878 /* Make sure key and value survive. */
4879 if (!key_known_to_survive_p
)
4881 mark_object (HASH_KEY (h
, i
));
4885 if (!value_known_to_survive_p
)
4887 mark_object (HASH_VALUE (h
, i
));
4898 /* Remove elements from weak hash tables that don't survive the
4899 current garbage collection. Remove weak tables that don't survive
4900 from Vweak_hash_tables. Called from gc_sweep. */
4903 sweep_weak_hash_tables ()
4905 Lisp_Object table
, used
, next
;
4906 struct Lisp_Hash_Table
*h
;
4909 /* Mark all keys and values that are in use. Keep on marking until
4910 there is no more change. This is necessary for cases like
4911 value-weak table A containing an entry X -> Y, where Y is used in a
4912 key-weak table B, Z -> Y. If B comes after A in the list of weak
4913 tables, X -> Y might be removed from A, although when looking at B
4914 one finds that it shouldn't. */
4918 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4920 h
= XHASH_TABLE (table
);
4921 if (h
->size
& ARRAY_MARK_FLAG
)
4922 marked
|= sweep_weak_table (h
, 0);
4927 /* Remove tables and entries that aren't used. */
4928 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4930 h
= XHASH_TABLE (table
);
4931 next
= h
->next_weak
;
4933 if (h
->size
& ARRAY_MARK_FLAG
)
4935 /* TABLE is marked as used. Sweep its contents. */
4936 if (XFASTINT (h
->count
) > 0)
4937 sweep_weak_table (h
, 1);
4939 /* Add table to the list of used weak hash tables. */
4940 h
->next_weak
= used
;
4945 Vweak_hash_tables
= used
;
4950 /***********************************************************************
4951 Hash Code Computation
4952 ***********************************************************************/
4954 /* Maximum depth up to which to dive into Lisp structures. */
4956 #define SXHASH_MAX_DEPTH 3
4958 /* Maximum length up to which to take list and vector elements into
4961 #define SXHASH_MAX_LEN 7
4963 /* Combine two integers X and Y for hashing. */
4965 #define SXHASH_COMBINE(X, Y) \
4966 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4970 /* Return a hash for string PTR which has length LEN. The hash
4971 code returned is guaranteed to fit in a Lisp integer. */
4974 sxhash_string (ptr
, len
)
4978 unsigned char *p
= ptr
;
4979 unsigned char *end
= p
+ len
;
4988 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4991 return hash
& INTMASK
;
4995 /* Return a hash for list LIST. DEPTH is the current depth in the
4996 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4999 sxhash_list (list
, depth
)
5006 if (depth
< SXHASH_MAX_DEPTH
)
5008 CONSP (list
) && i
< SXHASH_MAX_LEN
;
5009 list
= XCDR (list
), ++i
)
5011 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
5012 hash
= SXHASH_COMBINE (hash
, hash2
);
5019 /* Return a hash for vector VECTOR. DEPTH is the current depth in
5020 the Lisp structure. */
5023 sxhash_vector (vec
, depth
)
5027 unsigned hash
= XVECTOR (vec
)->size
;
5030 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5031 for (i
= 0; i
< n
; ++i
)
5033 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5034 hash
= SXHASH_COMBINE (hash
, hash2
);
5041 /* Return a hash for bool-vector VECTOR. */
5044 sxhash_bool_vector (vec
)
5047 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5050 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5051 for (i
= 0; i
< n
; ++i
)
5052 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5058 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5059 structure. Value is an unsigned integer clipped to INTMASK. */
5068 if (depth
> SXHASH_MAX_DEPTH
)
5071 switch (XTYPE (obj
))
5082 obj
= SYMBOL_NAME (obj
);
5086 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5089 /* This can be everything from a vector to an overlay. */
5090 case Lisp_Vectorlike
:
5092 /* According to the CL HyperSpec, two arrays are equal only if
5093 they are `eq', except for strings and bit-vectors. In
5094 Emacs, this works differently. We have to compare element
5096 hash
= sxhash_vector (obj
, depth
);
5097 else if (BOOL_VECTOR_P (obj
))
5098 hash
= sxhash_bool_vector (obj
);
5100 /* Others are `equal' if they are `eq', so let's take their
5106 hash
= sxhash_list (obj
, depth
);
5111 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5112 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5113 for (hash
= 0; p
< e
; ++p
)
5114 hash
= SXHASH_COMBINE (hash
, *p
);
5122 return hash
& INTMASK
;
5127 /***********************************************************************
5129 ***********************************************************************/
5132 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5133 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5137 unsigned hash
= sxhash (obj
, 0);;
5138 return make_number (hash
);
5142 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5143 doc
: /* Create and return a new hash table.
5145 Arguments are specified as keyword/argument pairs. The following
5146 arguments are defined:
5148 :test TEST -- TEST must be a symbol that specifies how to compare
5149 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5150 `equal'. User-supplied test and hash functions can be specified via
5151 `define-hash-table-test'.
5153 :size SIZE -- A hint as to how many elements will be put in the table.
5156 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5157 fills up. If REHASH-SIZE is an integer, add that many space. If it
5158 is a float, it must be > 1.0, and the new size is computed by
5159 multiplying the old size with that factor. Default is 1.5.
5161 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5162 Resize the hash table when ratio of the number of entries in the
5163 table. Default is 0.8.
5165 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5166 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5167 returned is a weak table. Key/value pairs are removed from a weak
5168 hash table when there are no non-weak references pointing to their
5169 key, value, one of key or value, or both key and value, depending on
5170 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5173 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5178 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5179 Lisp_Object user_test
, user_hash
;
5183 /* The vector `used' is used to keep track of arguments that
5184 have been consumed. */
5185 used
= (char *) alloca (nargs
* sizeof *used
);
5186 bzero (used
, nargs
* sizeof *used
);
5188 /* See if there's a `:test TEST' among the arguments. */
5189 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5190 test
= i
< 0 ? Qeql
: args
[i
];
5191 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5193 /* See if it is a user-defined test. */
5196 prop
= Fget (test
, Qhash_table_test
);
5197 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5198 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5200 user_test
= XCAR (prop
);
5201 user_hash
= XCAR (XCDR (prop
));
5204 user_test
= user_hash
= Qnil
;
5206 /* See if there's a `:size SIZE' argument. */
5207 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5208 size
= i
< 0 ? Qnil
: args
[i
];
5210 size
= make_number (DEFAULT_HASH_SIZE
);
5211 else if (!INTEGERP (size
) || XINT (size
) < 0)
5213 list2 (build_string ("Invalid hash table size"),
5216 /* Look for `:rehash-size SIZE'. */
5217 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5218 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5219 if (!NUMBERP (rehash_size
)
5220 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5221 || XFLOATINT (rehash_size
) <= 1.0)
5223 list2 (build_string ("Invalid hash table rehash size"),
5226 /* Look for `:rehash-threshold THRESHOLD'. */
5227 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5228 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5229 if (!FLOATP (rehash_threshold
)
5230 || XFLOATINT (rehash_threshold
) <= 0.0
5231 || XFLOATINT (rehash_threshold
) > 1.0)
5233 list2 (build_string ("Invalid hash table rehash threshold"),
5236 /* Look for `:weakness WEAK'. */
5237 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5238 weak
= i
< 0 ? Qnil
: args
[i
];
5240 weak
= Qkey_and_value
;
5243 && !EQ (weak
, Qvalue
)
5244 && !EQ (weak
, Qkey_or_value
)
5245 && !EQ (weak
, Qkey_and_value
))
5246 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5249 /* Now, all args should have been used up, or there's a problem. */
5250 for (i
= 0; i
< nargs
; ++i
)
5253 list2 (build_string ("Invalid argument list"), args
[i
]));
5255 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5256 user_test
, user_hash
);
5260 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5261 doc
: /* Return a copy of hash table TABLE. */)
5265 return copy_hash_table (check_hash_table (table
));
5269 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5270 doc
: /* Return the number of elements in TABLE. */)
5274 return check_hash_table (table
)->count
;
5278 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5279 Shash_table_rehash_size
, 1, 1, 0,
5280 doc
: /* Return the current rehash size of TABLE. */)
5284 return check_hash_table (table
)->rehash_size
;
5288 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5289 Shash_table_rehash_threshold
, 1, 1, 0,
5290 doc
: /* Return the current rehash threshold of TABLE. */)
5294 return check_hash_table (table
)->rehash_threshold
;
5298 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5299 doc
: /* Return the size of TABLE.
5300 The size can be used as an argument to `make-hash-table' to create
5301 a hash table than can hold as many elements of TABLE holds
5302 without need for resizing. */)
5306 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5307 return make_number (HASH_TABLE_SIZE (h
));
5311 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5312 doc
: /* Return the test TABLE uses. */)
5316 return check_hash_table (table
)->test
;
5320 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5322 doc
: /* Return the weakness of TABLE. */)
5326 return check_hash_table (table
)->weak
;
5330 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5331 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5335 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5339 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5340 doc
: /* Clear hash table TABLE. */)
5344 hash_clear (check_hash_table (table
));
5349 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5350 doc
: /* Look up KEY in TABLE and return its associated value.
5351 If KEY is not found, return DFLT which defaults to nil. */)
5353 Lisp_Object key
, table
, dflt
;
5355 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5356 int i
= hash_lookup (h
, key
, NULL
);
5357 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5361 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5362 doc
: /* Associate KEY with VALUE in hash table TABLE.
5363 If KEY is already present in table, replace its current value with
5366 Lisp_Object key
, value
, table
;
5368 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5372 i
= hash_lookup (h
, key
, &hash
);
5374 HASH_VALUE (h
, i
) = value
;
5376 hash_put (h
, key
, value
, hash
);
5382 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5383 doc
: /* Remove KEY from TABLE. */)
5385 Lisp_Object key
, table
;
5387 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5388 hash_remove (h
, key
);
5393 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5394 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5395 FUNCTION is called with 2 arguments KEY and VALUE. */)
5397 Lisp_Object function
, table
;
5399 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5400 Lisp_Object args
[3];
5403 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5404 if (!NILP (HASH_HASH (h
, i
)))
5407 args
[1] = HASH_KEY (h
, i
);
5408 args
[2] = HASH_VALUE (h
, i
);
5416 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5417 Sdefine_hash_table_test
, 3, 3, 0,
5418 doc
: /* Define a new hash table test with name NAME, a symbol.
5420 In hash tables created with NAME specified as test, use TEST to
5421 compare keys, and HASH for computing hash codes of keys.
5423 TEST must be a function taking two arguments and returning non-nil if
5424 both arguments are the same. HASH must be a function taking one
5425 argument and return an integer that is the hash code of the argument.
5426 Hash code computation should use the whole value range of integers,
5427 including negative integers. */)
5429 Lisp_Object name
, test
, hash
;
5431 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5436 /************************************************************************
5438 ************************************************************************/
5443 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5444 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5446 A message digest is a cryptographic checksum of a document, and the
5447 algorithm to calculate it is defined in RFC 1321.
5449 The two optional arguments START and END are character positions
5450 specifying for which part of OBJECT the message digest should be
5451 computed. If nil or omitted, the digest is computed for the whole
5454 The MD5 message digest is computed from the result of encoding the
5455 text in a coding system, not directly from the internal Emacs form of
5456 the text. The optional fourth argument CODING-SYSTEM specifies which
5457 coding system to encode the text with. It should be the same coding
5458 system that you used or will use when actually writing the text into a
5461 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5462 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5463 system would be chosen by default for writing this text into a file.
5465 If OBJECT is a string, the most preferred coding system (see the
5466 command `prefer-coding-system') is used.
5468 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5469 guesswork fails. Normally, an error is signaled in such case. */)
5470 (object
, start
, end
, coding_system
, noerror
)
5471 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5473 unsigned char digest
[16];
5474 unsigned char value
[33];
5478 int start_char
= 0, end_char
= 0;
5479 int start_byte
= 0, end_byte
= 0;
5481 register struct buffer
*bp
;
5484 if (STRINGP (object
))
5486 if (NILP (coding_system
))
5488 /* Decide the coding-system to encode the data with. */
5490 if (STRING_MULTIBYTE (object
))
5491 /* use default, we can't guess correct value */
5492 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5494 coding_system
= Qraw_text
;
5497 if (NILP (Fcoding_system_p (coding_system
)))
5499 /* Invalid coding system. */
5501 if (!NILP (noerror
))
5502 coding_system
= Qraw_text
;
5505 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5508 if (STRING_MULTIBYTE (object
))
5509 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5511 size
= SCHARS (object
);
5512 size_byte
= SBYTES (object
);
5516 CHECK_NUMBER (start
);
5518 start_char
= XINT (start
);
5523 start_byte
= string_char_to_byte (object
, start_char
);
5529 end_byte
= size_byte
;
5535 end_char
= XINT (end
);
5540 end_byte
= string_char_to_byte (object
, end_char
);
5543 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5544 args_out_of_range_3 (object
, make_number (start_char
),
5545 make_number (end_char
));
5549 struct buffer
*prev
= current_buffer
;
5551 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5553 CHECK_BUFFER (object
);
5555 bp
= XBUFFER (object
);
5556 if (bp
!= current_buffer
)
5557 set_buffer_internal (bp
);
5563 CHECK_NUMBER_COERCE_MARKER (start
);
5571 CHECK_NUMBER_COERCE_MARKER (end
);
5576 temp
= b
, b
= e
, e
= temp
;
5578 if (!(BEGV
<= b
&& e
<= ZV
))
5579 args_out_of_range (start
, end
);
5581 if (NILP (coding_system
))
5583 /* Decide the coding-system to encode the data with.
5584 See fileio.c:Fwrite-region */
5586 if (!NILP (Vcoding_system_for_write
))
5587 coding_system
= Vcoding_system_for_write
;
5590 int force_raw_text
= 0;
5592 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5593 if (NILP (coding_system
)
5594 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5596 coding_system
= Qnil
;
5597 if (NILP (current_buffer
->enable_multibyte_characters
))
5601 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5603 /* Check file-coding-system-alist. */
5604 Lisp_Object args
[4], val
;
5606 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5607 args
[3] = Fbuffer_file_name(object
);
5608 val
= Ffind_operation_coding_system (4, args
);
5609 if (CONSP (val
) && !NILP (XCDR (val
)))
5610 coding_system
= XCDR (val
);
5613 if (NILP (coding_system
)
5614 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5616 /* If we still have not decided a coding system, use the
5617 default value of buffer-file-coding-system. */
5618 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5622 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5623 /* Confirm that VAL can surely encode the current region. */
5624 coding_system
= call4 (Vselect_safe_coding_system_function
,
5625 make_number (b
), make_number (e
),
5626 coding_system
, Qnil
);
5629 coding_system
= Qraw_text
;
5632 if (NILP (Fcoding_system_p (coding_system
)))
5634 /* Invalid coding system. */
5636 if (!NILP (noerror
))
5637 coding_system
= Qraw_text
;
5640 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5644 object
= make_buffer_string (b
, e
, 0);
5645 if (prev
!= current_buffer
)
5646 set_buffer_internal (prev
);
5647 /* Discard the unwind protect for recovering the current
5651 if (STRING_MULTIBYTE (object
))
5652 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5655 md5_buffer (SDATA (object
) + start_byte
,
5656 SBYTES (object
) - (size_byte
- end_byte
),
5659 for (i
= 0; i
< 16; i
++)
5660 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5663 return make_string (value
, 32);
5670 /* Hash table stuff. */
5671 Qhash_table_p
= intern ("hash-table-p");
5672 staticpro (&Qhash_table_p
);
5673 Qeq
= intern ("eq");
5675 Qeql
= intern ("eql");
5677 Qequal
= intern ("equal");
5678 staticpro (&Qequal
);
5679 QCtest
= intern (":test");
5680 staticpro (&QCtest
);
5681 QCsize
= intern (":size");
5682 staticpro (&QCsize
);
5683 QCrehash_size
= intern (":rehash-size");
5684 staticpro (&QCrehash_size
);
5685 QCrehash_threshold
= intern (":rehash-threshold");
5686 staticpro (&QCrehash_threshold
);
5687 QCweakness
= intern (":weakness");
5688 staticpro (&QCweakness
);
5689 Qkey
= intern ("key");
5691 Qvalue
= intern ("value");
5692 staticpro (&Qvalue
);
5693 Qhash_table_test
= intern ("hash-table-test");
5694 staticpro (&Qhash_table_test
);
5695 Qkey_or_value
= intern ("key-or-value");
5696 staticpro (&Qkey_or_value
);
5697 Qkey_and_value
= intern ("key-and-value");
5698 staticpro (&Qkey_and_value
);
5701 defsubr (&Smake_hash_table
);
5702 defsubr (&Scopy_hash_table
);
5703 defsubr (&Shash_table_count
);
5704 defsubr (&Shash_table_rehash_size
);
5705 defsubr (&Shash_table_rehash_threshold
);
5706 defsubr (&Shash_table_size
);
5707 defsubr (&Shash_table_test
);
5708 defsubr (&Shash_table_weakness
);
5709 defsubr (&Shash_table_p
);
5710 defsubr (&Sclrhash
);
5711 defsubr (&Sgethash
);
5712 defsubr (&Sputhash
);
5713 defsubr (&Sremhash
);
5714 defsubr (&Smaphash
);
5715 defsubr (&Sdefine_hash_table_test
);
5717 Qstring_lessp
= intern ("string-lessp");
5718 staticpro (&Qstring_lessp
);
5719 Qprovide
= intern ("provide");
5720 staticpro (&Qprovide
);
5721 Qrequire
= intern ("require");
5722 staticpro (&Qrequire
);
5723 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5724 staticpro (&Qyes_or_no_p_history
);
5725 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5726 staticpro (&Qcursor_in_echo_area
);
5727 Qwidget_type
= intern ("widget-type");
5728 staticpro (&Qwidget_type
);
5730 staticpro (&string_char_byte_cache_string
);
5731 string_char_byte_cache_string
= Qnil
;
5733 require_nesting_list
= Qnil
;
5734 staticpro (&require_nesting_list
);
5736 Fset (Qyes_or_no_p_history
, Qnil
);
5738 DEFVAR_LISP ("features", &Vfeatures
,
5739 doc
: /* A list of symbols which are the features of the executing emacs.
5740 Used by `featurep' and `require', and altered by `provide'. */);
5742 Qsubfeatures
= intern ("subfeatures");
5743 staticpro (&Qsubfeatures
);
5745 #ifdef HAVE_LANGINFO_CODESET
5746 Qcodeset
= intern ("codeset");
5747 staticpro (&Qcodeset
);
5748 Qdays
= intern ("days");
5750 Qmonths
= intern ("months");
5751 staticpro (&Qmonths
);
5752 Qpaper
= intern ("paper");
5753 staticpro (&Qpaper
);
5754 #endif /* HAVE_LANGINFO_CODESET */
5756 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5757 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5758 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5759 invoked by mouse clicks and mouse menu items. */);
5762 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5763 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5764 This applies to commands from menus and tool bar buttons. The value of
5765 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5766 used if both `use-dialog-box' and this variable are non-nil. */);
5767 use_file_dialog
= 1;
5769 defsubr (&Sidentity
);
5772 defsubr (&Ssafe_length
);
5773 defsubr (&Sstring_bytes
);
5774 defsubr (&Sstring_equal
);
5775 defsubr (&Scompare_strings
);
5776 defsubr (&Sstring_lessp
);
5779 defsubr (&Svconcat
);
5780 defsubr (&Scopy_sequence
);
5781 defsubr (&Sstring_make_multibyte
);
5782 defsubr (&Sstring_make_unibyte
);
5783 defsubr (&Sstring_as_multibyte
);
5784 defsubr (&Sstring_as_unibyte
);
5785 defsubr (&Sstring_to_multibyte
);
5786 defsubr (&Scopy_alist
);
5787 defsubr (&Ssubstring
);
5788 defsubr (&Ssubstring_no_properties
);
5800 defsubr (&Snreverse
);
5801 defsubr (&Sreverse
);
5803 defsubr (&Splist_get
);
5805 defsubr (&Splist_put
);
5807 defsubr (&Slax_plist_get
);
5808 defsubr (&Slax_plist_put
);
5811 defsubr (&Sequal_including_properties
);
5812 defsubr (&Sfillarray
);
5813 defsubr (&Sclear_string
);
5814 defsubr (&Schar_table_subtype
);
5815 defsubr (&Schar_table_parent
);
5816 defsubr (&Sset_char_table_parent
);
5817 defsubr (&Schar_table_extra_slot
);
5818 defsubr (&Sset_char_table_extra_slot
);
5819 defsubr (&Schar_table_range
);
5820 defsubr (&Sset_char_table_range
);
5821 defsubr (&Sset_char_table_default
);
5822 defsubr (&Soptimize_char_table
);
5823 defsubr (&Smap_char_table
);
5827 defsubr (&Smapconcat
);
5828 defsubr (&Sy_or_n_p
);
5829 defsubr (&Syes_or_no_p
);
5830 defsubr (&Sload_average
);
5831 defsubr (&Sfeaturep
);
5832 defsubr (&Srequire
);
5833 defsubr (&Sprovide
);
5834 defsubr (&Splist_member
);
5835 defsubr (&Swidget_put
);
5836 defsubr (&Swidget_get
);
5837 defsubr (&Swidget_apply
);
5838 defsubr (&Sbase64_encode_region
);
5839 defsubr (&Sbase64_decode_region
);
5840 defsubr (&Sbase64_encode_string
);
5841 defsubr (&Sbase64_decode_string
);
5843 defsubr (&Slocale_info
);
5850 Vweak_hash_tables
= Qnil
;
5853 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5854 (do not change this comment) */