1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
31 /* On Mac OS, defining this conflicts with precompiled headers. */
33 /* Note on some machines this defines `vector' as a typedef,
34 so make sure we don't use that name in this file. */
38 #endif /* ! MAC_OSX */
47 #include "intervals.h"
50 #include "blockinput.h"
52 #if defined (HAVE_X_WINDOWS)
54 #elif defined (MAC_OS)
60 #define NULL ((POINTER_TYPE *)0)
63 /* Nonzero enables use of dialog boxes for questions
64 asked by mouse commands. */
67 /* Nonzero enables use of a file dialog for file name
68 questions asked by mouse commands. */
71 extern int minibuffer_auto_raise
;
72 extern Lisp_Object minibuf_window
;
73 extern Lisp_Object Vlocale_coding_system
;
74 extern int load_in_progress
;
76 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
77 Lisp_Object Qyes_or_no_p_history
;
78 Lisp_Object Qcursor_in_echo_area
;
79 Lisp_Object Qwidget_type
;
80 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
82 extern Lisp_Object Qinput_method_function
;
84 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
86 extern long get_random ();
87 extern void seed_random
P_ ((long));
93 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
94 doc
: /* Return the argument unchanged. */)
101 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
102 doc
: /* Return a pseudo-random number.
103 All integers representable in Lisp are equally likely.
104 On most systems, this is 29 bits' worth.
105 With positive integer argument N, return random number in interval [0,N).
106 With argument t, set the random number seed from the current time and pid. */)
111 Lisp_Object lispy_val
;
112 unsigned long denominator
;
115 seed_random (getpid () + time (NULL
));
116 if (NATNUMP (n
) && XFASTINT (n
) != 0)
118 /* Try to take our random number from the higher bits of VAL,
119 not the lower, since (says Gentzel) the low bits of `random'
120 are less random than the higher ones. We do this by using the
121 quotient rather than the remainder. At the high end of the RNG
122 it's possible to get a quotient larger than n; discarding
123 these values eliminates the bias that would otherwise appear
124 when using a large n. */
125 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
127 val
= get_random () / denominator
;
128 while (val
>= XFASTINT (n
));
132 XSETINT (lispy_val
, val
);
136 /* Random data-structure functions */
138 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
139 doc
: /* Return the length of vector, list or string SEQUENCE.
140 A byte-code function object is also allowed.
141 If the string contains multibyte characters, this is not necessarily
142 the number of bytes in the string; it is the number of characters.
143 To get the number of bytes, use `string-bytes'. */)
145 register Lisp_Object sequence
;
147 register Lisp_Object val
;
150 if (STRINGP (sequence
))
151 XSETFASTINT (val
, SCHARS (sequence
));
152 else if (VECTORP (sequence
))
153 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
154 else if (SUB_CHAR_TABLE_P (sequence
))
155 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
156 else if (CHAR_TABLE_P (sequence
))
157 XSETFASTINT (val
, MAX_CHAR
);
158 else if (BOOL_VECTOR_P (sequence
))
159 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
160 else if (COMPILEDP (sequence
))
161 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
162 else if (CONSP (sequence
))
165 while (CONSP (sequence
))
167 sequence
= XCDR (sequence
);
170 if (!CONSP (sequence
))
173 sequence
= XCDR (sequence
);
178 CHECK_LIST_END (sequence
, sequence
);
180 val
= make_number (i
);
182 else if (NILP (sequence
))
183 XSETFASTINT (val
, 0);
185 wrong_type_argument (Qsequencep
, sequence
);
190 /* This does not check for quits. That is safe since it must terminate. */
192 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
193 doc
: /* Return the length of a list, but avoid error or infinite loop.
194 This function never gets an error. If LIST is not really a list,
195 it returns 0. If LIST is circular, it returns a finite value
196 which is at least the number of distinct elements. */)
200 Lisp_Object tail
, halftail
, length
;
203 /* halftail is used to detect circular lists. */
205 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
207 if (EQ (tail
, halftail
) && len
!= 0)
211 halftail
= XCDR (halftail
);
214 XSETINT (length
, len
);
218 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
219 doc
: /* Return the number of bytes in STRING.
220 If STRING is a multibyte string, this is greater than the length of STRING. */)
224 CHECK_STRING (string
);
225 return make_number (SBYTES (string
));
228 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
229 doc
: /* Return t if two strings have identical contents.
230 Case is significant, but text properties are ignored.
231 Symbols are also allowed; their print names are used instead. */)
233 register Lisp_Object s1
, s2
;
236 s1
= SYMBOL_NAME (s1
);
238 s2
= SYMBOL_NAME (s2
);
242 if (SCHARS (s1
) != SCHARS (s2
)
243 || SBYTES (s1
) != SBYTES (s2
)
244 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
249 DEFUN ("compare-strings", Fcompare_strings
,
250 Scompare_strings
, 6, 7, 0,
251 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
252 In string STR1, skip the first START1 characters and stop at END1.
253 In string STR2, skip the first START2 characters and stop at END2.
254 END1 and END2 default to the full lengths of the respective strings.
256 Case is significant in this comparison if IGNORE-CASE is nil.
257 Unibyte strings are converted to multibyte for comparison.
259 The value is t if the strings (or specified portions) match.
260 If string STR1 is less, the value is a negative number N;
261 - 1 - N is the number of characters that match at the beginning.
262 If string STR1 is greater, the value is a positive number N;
263 N - 1 is the number of characters that match at the beginning. */)
264 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
265 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
267 register int end1_char
, end2_char
;
268 register int i1
, i1_byte
, i2
, i2_byte
;
273 start1
= make_number (0);
275 start2
= make_number (0);
276 CHECK_NATNUM (start1
);
277 CHECK_NATNUM (start2
);
286 i1_byte
= string_char_to_byte (str1
, i1
);
287 i2_byte
= string_char_to_byte (str2
, i2
);
289 end1_char
= SCHARS (str1
);
290 if (! NILP (end1
) && end1_char
> XINT (end1
))
291 end1_char
= XINT (end1
);
293 end2_char
= SCHARS (str2
);
294 if (! NILP (end2
) && end2_char
> XINT (end2
))
295 end2_char
= XINT (end2
);
297 while (i1
< end1_char
&& i2
< end2_char
)
299 /* When we find a mismatch, we must compare the
300 characters, not just the bytes. */
303 if (STRING_MULTIBYTE (str1
))
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
307 c1
= SREF (str1
, i1
++);
308 c1
= unibyte_char_to_multibyte (c1
);
311 if (STRING_MULTIBYTE (str2
))
312 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
315 c2
= SREF (str2
, i2
++);
316 c2
= unibyte_char_to_multibyte (c2
);
322 if (! NILP (ignore_case
))
326 tem
= Fupcase (make_number (c1
));
328 tem
= Fupcase (make_number (c2
));
335 /* Note that I1 has already been incremented
336 past the character that we are comparing;
337 hence we don't add or subtract 1 here. */
339 return make_number (- i1
+ XINT (start1
));
341 return make_number (i1
- XINT (start1
));
345 return make_number (i1
- XINT (start1
) + 1);
347 return make_number (- i1
+ XINT (start1
) - 1);
352 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
353 doc
: /* Return t if first arg string is less than second in lexicographic order.
355 Symbols are also allowed; their print names are used instead. */)
357 register Lisp_Object s1
, s2
;
360 register int i1
, i1_byte
, i2
, i2_byte
;
363 s1
= SYMBOL_NAME (s1
);
365 s2
= SYMBOL_NAME (s2
);
369 i1
= i1_byte
= i2
= i2_byte
= 0;
372 if (end
> SCHARS (s2
))
377 /* When we find a mismatch, we must compare the
378 characters, not just the bytes. */
381 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
382 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
385 return c1
< c2
? Qt
: Qnil
;
387 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
390 static Lisp_Object
concat ();
401 return concat (2, args
, Lisp_String
, 0);
403 return concat (2, &s1
, Lisp_String
, 0);
404 #endif /* NO_ARG_ARRAY */
410 Lisp_Object s1
, s2
, s3
;
417 return concat (3, args
, Lisp_String
, 0);
419 return concat (3, &s1
, Lisp_String
, 0);
420 #endif /* NO_ARG_ARRAY */
423 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
424 doc
: /* Concatenate all the arguments and make the result a list.
425 The result is a list whose elements are the elements of all the arguments.
426 Each argument may be a list, vector or string.
427 The last argument is not copied, just used as the tail of the new list.
428 usage: (append &rest SEQUENCES) */)
433 return concat (nargs
, args
, Lisp_Cons
, 1);
436 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
437 doc
: /* Concatenate all the arguments and make the result a string.
438 The result is a string whose elements are the elements of all the arguments.
439 Each argument may be a string or a list or vector of characters (integers).
440 usage: (concat &rest SEQUENCES) */)
445 return concat (nargs
, args
, Lisp_String
, 0);
448 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
449 doc
: /* Concatenate all the arguments and make the result a vector.
450 The result is a vector whose elements are the elements of all the arguments.
451 Each argument may be a list, vector or string.
452 usage: (vconcat &rest SEQUENCES) */)
457 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
460 /* Return a copy of a sub char table ARG. The elements except for a
461 nested sub char table are not copied. */
463 copy_sub_char_table (arg
)
466 Lisp_Object copy
= make_sub_char_table (Qnil
);
469 XCHAR_TABLE (copy
)->defalt
= XCHAR_TABLE (arg
)->defalt
;
470 /* Copy all the contents. */
471 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
472 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
473 /* Recursively copy any sub char-tables in the ordinary slots. */
474 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
475 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
476 XCHAR_TABLE (copy
)->contents
[i
]
477 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
483 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
484 doc
: /* Return a copy of a list, vector, string or char-table.
485 The elements of a list or vector are not copied; they are shared
486 with the original. */)
490 if (NILP (arg
)) return arg
;
492 if (CHAR_TABLE_P (arg
))
497 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
498 /* Copy all the slots, including the extra ones. */
499 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
500 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
501 * sizeof (Lisp_Object
)));
503 /* Recursively copy any sub char tables in the ordinary slots
504 for multibyte characters. */
505 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
506 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
507 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
508 XCHAR_TABLE (copy
)->contents
[i
]
509 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
514 if (BOOL_VECTOR_P (arg
))
518 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
519 / BOOL_VECTOR_BITS_PER_CHAR
);
521 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
522 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
527 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
528 wrong_type_argument (Qsequencep
, arg
);
530 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
533 /* This structure holds information of an argument of `concat' that is
534 a string and has text properties to be copied. */
537 int argnum
; /* refer to ARGS (arguments of `concat') */
538 int from
; /* refer to ARGS[argnum] (argument string) */
539 int to
; /* refer to VAL (the target string) */
543 concat (nargs
, args
, target_type
, last_special
)
546 enum Lisp_Type target_type
;
550 register Lisp_Object tail
;
551 register Lisp_Object
this;
553 int toindex_byte
= 0;
554 register int result_len
;
555 register int result_len_byte
;
557 Lisp_Object last_tail
;
560 /* When we make a multibyte string, we can't copy text properties
561 while concatinating each string because the length of resulting
562 string can't be decided until we finish the whole concatination.
563 So, we record strings that have text properties to be copied
564 here, and copy the text properties after the concatination. */
565 struct textprop_rec
*textprops
= NULL
;
566 /* Number of elments in textprops. */
567 int num_textprops
= 0;
572 /* In append, the last arg isn't treated like the others */
573 if (last_special
&& nargs
> 0)
576 last_tail
= args
[nargs
];
581 /* Check each argument. */
582 for (argnum
= 0; argnum
< nargs
; argnum
++)
585 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
586 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
587 wrong_type_argument (Qsequencep
, this);
590 /* Compute total length in chars of arguments in RESULT_LEN.
591 If desired output is a string, also compute length in bytes
592 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
593 whether the result should be a multibyte string. */
597 for (argnum
= 0; argnum
< nargs
; argnum
++)
601 len
= XFASTINT (Flength (this));
602 if (target_type
== Lisp_String
)
604 /* We must count the number of bytes needed in the string
605 as well as the number of characters. */
611 for (i
= 0; i
< len
; i
++)
613 ch
= XVECTOR (this)->contents
[i
];
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 this_len_byte
= CHAR_BYTES (XINT (ch
));
628 result_len_byte
+= this_len_byte
;
629 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
632 else if (STRINGP (this))
634 if (STRING_MULTIBYTE (this))
637 result_len_byte
+= SBYTES (this);
640 result_len_byte
+= count_size_as_multibyte (SDATA (this),
648 if (! some_multibyte
)
649 result_len_byte
= result_len
;
651 /* Create the output object. */
652 if (target_type
== Lisp_Cons
)
653 val
= Fmake_list (make_number (result_len
), Qnil
);
654 else if (target_type
== Lisp_Vectorlike
)
655 val
= Fmake_vector (make_number (result_len
), Qnil
);
656 else if (some_multibyte
)
657 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
659 val
= make_uninit_string (result_len
);
661 /* In `append', if all but last arg are nil, return last arg. */
662 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
665 /* Copy the contents of the args into the result. */
667 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
669 toindex
= 0, toindex_byte
= 0;
673 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
675 for (argnum
= 0; argnum
< nargs
; argnum
++)
679 register unsigned int thisindex
= 0;
680 register unsigned int thisindex_byte
= 0;
684 thislen
= Flength (this), thisleni
= XINT (thislen
);
686 /* Between strings of the same kind, copy fast. */
687 if (STRINGP (this) && STRINGP (val
)
688 && STRING_MULTIBYTE (this) == some_multibyte
)
690 int thislen_byte
= SBYTES (this);
692 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
694 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
696 textprops
[num_textprops
].argnum
= argnum
;
697 textprops
[num_textprops
].from
= 0;
698 textprops
[num_textprops
++].to
= toindex
;
700 toindex_byte
+= thislen_byte
;
702 STRING_SET_CHARS (val
, SCHARS (val
));
704 /* Copy a single-byte string to a multibyte string. */
705 else if (STRINGP (this) && STRINGP (val
))
707 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
709 textprops
[num_textprops
].argnum
= argnum
;
710 textprops
[num_textprops
].from
= 0;
711 textprops
[num_textprops
++].to
= toindex
;
713 toindex_byte
+= copy_text (SDATA (this),
714 SDATA (val
) + toindex_byte
,
715 SCHARS (this), 0, 1);
719 /* Copy element by element. */
722 register Lisp_Object elt
;
724 /* Fetch next element of `this' arg into `elt', or break if
725 `this' is exhausted. */
726 if (NILP (this)) break;
728 elt
= XCAR (this), this = XCDR (this);
729 else if (thisindex
>= thisleni
)
731 else if (STRINGP (this))
734 if (STRING_MULTIBYTE (this))
736 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
739 XSETFASTINT (elt
, c
);
743 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
745 && (XINT (elt
) >= 0240
746 || (XINT (elt
) >= 0200
747 && ! NILP (Vnonascii_translation_table
)))
748 && XINT (elt
) < 0400)
750 c
= unibyte_char_to_multibyte (XINT (elt
));
755 else if (BOOL_VECTOR_P (this))
758 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
759 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
766 elt
= XVECTOR (this)->contents
[thisindex
++];
768 /* Store this element into the result. */
775 else if (VECTORP (val
))
776 XVECTOR (val
)->contents
[toindex
++] = elt
;
780 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
784 += CHAR_STRING (XINT (elt
),
785 SDATA (val
) + toindex_byte
);
787 SSET (val
, toindex_byte
++, XINT (elt
));
791 /* If we have any multibyte characters,
792 we already decided to make a multibyte string. */
795 /* P exists as a variable
796 to avoid a bug on the Masscomp C compiler. */
797 unsigned char *p
= SDATA (val
) + toindex_byte
;
799 toindex_byte
+= CHAR_STRING (c
, p
);
806 XSETCDR (prev
, last_tail
);
808 if (num_textprops
> 0)
811 int last_to_end
= -1;
813 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
815 this = args
[textprops
[argnum
].argnum
];
816 props
= text_property_list (this,
818 make_number (SCHARS (this)),
820 /* If successive arguments have properites, be sure that the
821 value of `composition' property be the copy. */
822 if (last_to_end
== textprops
[argnum
].to
)
823 make_composition_value_copy (props
);
824 add_text_properties_from_list (val
, props
,
825 make_number (textprops
[argnum
].to
));
826 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
834 static Lisp_Object string_char_byte_cache_string
;
835 static int string_char_byte_cache_charpos
;
836 static int string_char_byte_cache_bytepos
;
839 clear_string_char_byte_cache ()
841 string_char_byte_cache_string
= Qnil
;
844 /* Return the character index corresponding to CHAR_INDEX in STRING. */
847 string_char_to_byte (string
, char_index
)
852 int best_below
, best_below_byte
;
853 int best_above
, best_above_byte
;
855 best_below
= best_below_byte
= 0;
856 best_above
= SCHARS (string
);
857 best_above_byte
= SBYTES (string
);
858 if (best_above
== best_above_byte
)
861 if (EQ (string
, string_char_byte_cache_string
))
863 if (string_char_byte_cache_charpos
< char_index
)
865 best_below
= string_char_byte_cache_charpos
;
866 best_below_byte
= string_char_byte_cache_bytepos
;
870 best_above
= string_char_byte_cache_charpos
;
871 best_above_byte
= string_char_byte_cache_bytepos
;
875 if (char_index
- best_below
< best_above
- char_index
)
877 while (best_below
< char_index
)
880 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
881 best_below
, best_below_byte
);
884 i_byte
= best_below_byte
;
888 while (best_above
> char_index
)
890 unsigned char *pend
= SDATA (string
) + best_above_byte
;
891 unsigned char *pbeg
= pend
- best_above_byte
;
892 unsigned char *p
= pend
- 1;
895 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
896 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
897 if (bytes
== pend
- p
)
898 best_above_byte
-= bytes
;
899 else if (bytes
> pend
- p
)
900 best_above_byte
-= (pend
- p
);
906 i_byte
= best_above_byte
;
909 string_char_byte_cache_bytepos
= i_byte
;
910 string_char_byte_cache_charpos
= i
;
911 string_char_byte_cache_string
= string
;
916 /* Return the character index corresponding to BYTE_INDEX in STRING. */
919 string_byte_to_char (string
, byte_index
)
924 int best_below
, best_below_byte
;
925 int best_above
, best_above_byte
;
927 best_below
= best_below_byte
= 0;
928 best_above
= SCHARS (string
);
929 best_above_byte
= SBYTES (string
);
930 if (best_above
== best_above_byte
)
933 if (EQ (string
, string_char_byte_cache_string
))
935 if (string_char_byte_cache_bytepos
< byte_index
)
937 best_below
= string_char_byte_cache_charpos
;
938 best_below_byte
= string_char_byte_cache_bytepos
;
942 best_above
= string_char_byte_cache_charpos
;
943 best_above_byte
= string_char_byte_cache_bytepos
;
947 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
949 while (best_below_byte
< byte_index
)
952 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
953 best_below
, best_below_byte
);
956 i_byte
= best_below_byte
;
960 while (best_above_byte
> byte_index
)
962 unsigned char *pend
= SDATA (string
) + best_above_byte
;
963 unsigned char *pbeg
= pend
- best_above_byte
;
964 unsigned char *p
= pend
- 1;
967 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
968 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
969 if (bytes
== pend
- p
)
970 best_above_byte
-= bytes
;
971 else if (bytes
> pend
- p
)
972 best_above_byte
-= (pend
- p
);
978 i_byte
= best_above_byte
;
981 string_char_byte_cache_bytepos
= i_byte
;
982 string_char_byte_cache_charpos
= i
;
983 string_char_byte_cache_string
= string
;
988 /* Convert STRING to a multibyte string.
989 Single-byte characters 0240 through 0377 are converted
990 by adding nonascii_insert_offset to each. */
993 string_make_multibyte (string
)
1001 if (STRING_MULTIBYTE (string
))
1004 nbytes
= count_size_as_multibyte (SDATA (string
),
1006 /* If all the chars are ASCII, they won't need any more bytes
1007 once converted. In that case, we can return STRING itself. */
1008 if (nbytes
== SBYTES (string
))
1011 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1012 copy_text (SDATA (string
), buf
, SBYTES (string
),
1015 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1022 /* Convert STRING to a multibyte string without changing each
1023 character codes. Thus, characters 0200 trough 0237 are converted
1024 to eight-bit-control characters, and characters 0240 through 0377
1025 are converted eight-bit-graphic characters. */
1028 string_to_multibyte (string
)
1036 if (STRING_MULTIBYTE (string
))
1039 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1040 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1041 any more bytes once converted. */
1042 if (nbytes
== SBYTES (string
))
1043 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1045 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1046 bcopy (SDATA (string
), buf
, SBYTES (string
));
1047 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1049 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1056 /* Convert STRING to a single-byte string. */
1059 string_make_unibyte (string
)
1067 if (! STRING_MULTIBYTE (string
))
1070 nchars
= SCHARS (string
);
1072 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1073 copy_text (SDATA (string
), buf
, SBYTES (string
),
1076 ret
= make_unibyte_string (buf
, nchars
);
1082 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1084 doc
: /* Return the multibyte equivalent of STRING.
1085 If STRING is unibyte and contains non-ASCII characters, the function
1086 `unibyte-char-to-multibyte' is used to convert each unibyte character
1087 to a multibyte character. In this case, the returned string is a
1088 newly created string with no text properties. If STRING is multibyte
1089 or entirely ASCII, it is returned unchanged. In particular, when
1090 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1091 \(When the characters are all ASCII, Emacs primitives will treat the
1092 string the same way whether it is unibyte or multibyte.) */)
1096 CHECK_STRING (string
);
1098 return string_make_multibyte (string
);
1101 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1103 doc
: /* Return the unibyte equivalent of STRING.
1104 Multibyte character codes are converted to unibyte according to
1105 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1106 If the lookup in the translation table fails, this function takes just
1107 the low 8 bits of each character. */)
1111 CHECK_STRING (string
);
1113 return string_make_unibyte (string
);
1116 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1118 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1119 If STRING is unibyte, the result is STRING itself.
1120 Otherwise it is a newly created string, with no text properties.
1121 If STRING is multibyte and contains a character of charset
1122 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1123 corresponding single byte. */)
1127 CHECK_STRING (string
);
1129 if (STRING_MULTIBYTE (string
))
1131 int bytes
= SBYTES (string
);
1132 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1134 bcopy (SDATA (string
), str
, bytes
);
1135 bytes
= str_as_unibyte (str
, bytes
);
1136 string
= make_unibyte_string (str
, bytes
);
1142 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1144 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1145 If STRING is multibyte, the result is STRING itself.
1146 Otherwise it is a newly created string, with no text properties.
1147 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1148 part of a multibyte form), it is converted to the corresponding
1149 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.
1150 Beware, this often doesn't really do what you think it does.
1151 It is similar to (decode-coding-string STRING 'emacs-mule-unix).
1152 If you're not sure, whether to use `string-as-multibyte' or
1153 `string-to-multibyte', use `string-to-multibyte'. Beware:
1154 (aref (string-as-multibyte "\\201") 0) -> 129 (aka ?\\201)
1155 (aref (string-as-multibyte "\\300") 0) -> 192 (aka ?\\300)
1156 (aref (string-as-multibyte "\\300\\201") 0) -> 192 (aka ?\\300)
1157 (aref (string-as-multibyte "\\300\\201") 1) -> 129 (aka ?\\201)
1159 (aref (string-as-multibyte "\\201\\300") 0) -> 2240
1160 (aref (string-as-multibyte "\\201\\300") 1) -> <error> */)
1164 CHECK_STRING (string
);
1166 if (! STRING_MULTIBYTE (string
))
1168 Lisp_Object new_string
;
1171 parse_str_as_multibyte (SDATA (string
),
1174 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1175 bcopy (SDATA (string
), SDATA (new_string
),
1177 if (nbytes
!= SBYTES (string
))
1178 str_as_multibyte (SDATA (new_string
), nbytes
,
1179 SBYTES (string
), NULL
);
1180 string
= new_string
;
1181 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1186 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1188 doc
: /* Return a multibyte string with the same individual chars as STRING.
1189 If STRING is multibyte, the result is STRING itself.
1190 Otherwise it is a newly created string, with no text properties.
1191 Characters 0200 through 0237 are converted to eight-bit-control
1192 characters of the same character code. Characters 0240 through 0377
1193 are converted to eight-bit-graphic characters of the same character
1195 This is similar to (decode-coding-string STRING 'binary) */)
1199 CHECK_STRING (string
);
1201 return string_to_multibyte (string
);
1205 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1206 doc
: /* Return a copy of ALIST.
1207 This is an alist which represents the same mapping from objects to objects,
1208 but does not share the alist structure with ALIST.
1209 The objects mapped (cars and cdrs of elements of the alist)
1210 are shared, however.
1211 Elements of ALIST that are not conses are also shared. */)
1215 register Lisp_Object tem
;
1220 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1221 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1223 register Lisp_Object car
;
1227 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1232 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1233 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1234 TO may be nil or omitted; then the substring runs to the end of STRING.
1235 FROM and TO start at 0. If either is negative, it counts from the end.
1237 This function allows vectors as well as strings. */)
1240 register Lisp_Object from
, to
;
1245 int from_char
, to_char
;
1246 int from_byte
= 0, to_byte
= 0;
1248 CHECK_VECTOR_OR_STRING (string
);
1249 CHECK_NUMBER (from
);
1251 if (STRINGP (string
))
1253 size
= SCHARS (string
);
1254 size_byte
= SBYTES (string
);
1257 size
= XVECTOR (string
)->size
;
1262 to_byte
= size_byte
;
1268 to_char
= XINT (to
);
1272 if (STRINGP (string
))
1273 to_byte
= string_char_to_byte (string
, to_char
);
1276 from_char
= XINT (from
);
1279 if (STRINGP (string
))
1280 from_byte
= string_char_to_byte (string
, from_char
);
1282 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1283 args_out_of_range_3 (string
, make_number (from_char
),
1284 make_number (to_char
));
1286 if (STRINGP (string
))
1288 res
= make_specified_string (SDATA (string
) + from_byte
,
1289 to_char
- from_char
, to_byte
- from_byte
,
1290 STRING_MULTIBYTE (string
));
1291 copy_text_properties (make_number (from_char
), make_number (to_char
),
1292 string
, make_number (0), res
, Qnil
);
1295 res
= Fvector (to_char
- from_char
,
1296 XVECTOR (string
)->contents
+ from_char
);
1302 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1303 doc
: /* Return a substring of STRING, without text properties.
1304 It starts at index FROM and ending before TO.
1305 TO may be nil or omitted; then the substring runs to the end of STRING.
1306 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1307 If FROM or TO is negative, it counts from the end.
1309 With one argument, just copy STRING without its properties. */)
1312 register Lisp_Object from
, to
;
1314 int size
, size_byte
;
1315 int from_char
, to_char
;
1316 int from_byte
, to_byte
;
1318 CHECK_STRING (string
);
1320 size
= SCHARS (string
);
1321 size_byte
= SBYTES (string
);
1324 from_char
= from_byte
= 0;
1327 CHECK_NUMBER (from
);
1328 from_char
= XINT (from
);
1332 from_byte
= string_char_to_byte (string
, from_char
);
1338 to_byte
= size_byte
;
1344 to_char
= XINT (to
);
1348 to_byte
= string_char_to_byte (string
, to_char
);
1351 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1352 args_out_of_range_3 (string
, make_number (from_char
),
1353 make_number (to_char
));
1355 return make_specified_string (SDATA (string
) + from_byte
,
1356 to_char
- from_char
, to_byte
- from_byte
,
1357 STRING_MULTIBYTE (string
));
1360 /* Extract a substring of STRING, giving start and end positions
1361 both in characters and in bytes. */
1364 substring_both (string
, from
, from_byte
, to
, to_byte
)
1366 int from
, from_byte
, to
, to_byte
;
1372 CHECK_VECTOR_OR_STRING (string
);
1374 if (STRINGP (string
))
1376 size
= SCHARS (string
);
1377 size_byte
= SBYTES (string
);
1380 size
= XVECTOR (string
)->size
;
1382 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1383 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1385 if (STRINGP (string
))
1387 res
= make_specified_string (SDATA (string
) + from_byte
,
1388 to
- from
, to_byte
- from_byte
,
1389 STRING_MULTIBYTE (string
));
1390 copy_text_properties (make_number (from
), make_number (to
),
1391 string
, make_number (0), res
, Qnil
);
1394 res
= Fvector (to
- from
,
1395 XVECTOR (string
)->contents
+ from
);
1400 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1401 doc
: /* Take cdr N times on LIST, returns the result. */)
1404 register Lisp_Object list
;
1406 register int i
, num
;
1409 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1412 CHECK_LIST_CONS (list
, list
);
1418 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1419 doc
: /* Return the Nth element of LIST.
1420 N counts from zero. If LIST is not that long, nil is returned. */)
1422 Lisp_Object n
, list
;
1424 return Fcar (Fnthcdr (n
, list
));
1427 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1428 doc
: /* Return element of SEQUENCE at index N. */)
1430 register Lisp_Object sequence
, n
;
1433 if (CONSP (sequence
) || NILP (sequence
))
1434 return Fcar (Fnthcdr (n
, sequence
));
1436 /* Faref signals a "not array" error, so check here. */
1437 CHECK_ARRAY (sequence
, Qsequencep
);
1438 return Faref (sequence
, n
);
1441 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1442 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1443 The value is actually the tail of LIST whose car is ELT. */)
1445 register Lisp_Object elt
;
1448 register Lisp_Object tail
;
1449 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1451 register Lisp_Object tem
;
1452 CHECK_LIST_CONS (tail
, list
);
1454 if (! NILP (Fequal (elt
, tem
)))
1461 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1462 doc
: /* Return non-nil if ELT is an element of LIST.
1463 Comparison done with `eq'. The value is actually the tail of LIST
1464 whose car is ELT. */)
1466 Lisp_Object elt
, list
;
1470 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1474 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1478 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1489 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1490 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1491 The value is actually the first element of LIST whose car is KEY.
1492 Elements of LIST that are not conses are ignored. */)
1494 Lisp_Object key
, list
;
1499 || (CONSP (XCAR (list
))
1500 && EQ (XCAR (XCAR (list
)), key
)))
1505 || (CONSP (XCAR (list
))
1506 && EQ (XCAR (XCAR (list
)), key
)))
1511 || (CONSP (XCAR (list
))
1512 && EQ (XCAR (XCAR (list
)), key
)))
1522 /* Like Fassq but never report an error and do not allow quits.
1523 Use only on lists known never to be circular. */
1526 assq_no_quit (key
, list
)
1527 Lisp_Object key
, list
;
1530 && (!CONSP (XCAR (list
))
1531 || !EQ (XCAR (XCAR (list
)), key
)))
1534 return CAR_SAFE (list
);
1537 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1538 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1539 The value is actually the first element of LIST whose car equals KEY. */)
1541 Lisp_Object key
, list
;
1548 || (CONSP (XCAR (list
))
1549 && (car
= XCAR (XCAR (list
)),
1550 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1555 || (CONSP (XCAR (list
))
1556 && (car
= XCAR (XCAR (list
)),
1557 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1562 || (CONSP (XCAR (list
))
1563 && (car
= XCAR (XCAR (list
)),
1564 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1574 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1575 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1576 The value is actually the first element of LIST whose cdr is KEY. */)
1578 register Lisp_Object key
;
1584 || (CONSP (XCAR (list
))
1585 && EQ (XCDR (XCAR (list
)), key
)))
1590 || (CONSP (XCAR (list
))
1591 && EQ (XCDR (XCAR (list
)), key
)))
1596 || (CONSP (XCAR (list
))
1597 && EQ (XCDR (XCAR (list
)), key
)))
1607 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1608 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1609 The value is actually the first element of LIST whose cdr equals KEY. */)
1611 Lisp_Object key
, list
;
1618 || (CONSP (XCAR (list
))
1619 && (cdr
= XCDR (XCAR (list
)),
1620 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1625 || (CONSP (XCAR (list
))
1626 && (cdr
= XCDR (XCAR (list
)),
1627 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1632 || (CONSP (XCAR (list
))
1633 && (cdr
= XCDR (XCAR (list
)),
1634 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1644 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1645 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1646 The modified LIST is returned. Comparison is done with `eq'.
1647 If the first member of LIST is ELT, there is no way to remove it by side effect;
1648 therefore, write `(setq foo (delq element foo))'
1649 to be sure of changing the value of `foo'. */)
1651 register Lisp_Object elt
;
1654 register Lisp_Object tail
, prev
;
1655 register Lisp_Object tem
;
1659 while (!NILP (tail
))
1661 CHECK_LIST_CONS (tail
, list
);
1668 Fsetcdr (prev
, XCDR (tail
));
1678 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1679 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1680 SEQ must be a list, a vector, or a string.
1681 The modified SEQ is returned. Comparison is done with `equal'.
1682 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1683 is not a side effect; it is simply using a different sequence.
1684 Therefore, write `(setq foo (delete element foo))'
1685 to be sure of changing the value of `foo'. */)
1687 Lisp_Object elt
, seq
;
1693 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1694 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1697 if (n
!= ASIZE (seq
))
1699 struct Lisp_Vector
*p
= allocate_vector (n
);
1701 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1702 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1703 p
->contents
[n
++] = AREF (seq
, i
);
1705 XSETVECTOR (seq
, p
);
1708 else if (STRINGP (seq
))
1710 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1713 for (i
= nchars
= nbytes
= ibyte
= 0;
1715 ++i
, ibyte
+= cbytes
)
1717 if (STRING_MULTIBYTE (seq
))
1719 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1720 SBYTES (seq
) - ibyte
);
1721 cbytes
= CHAR_BYTES (c
);
1729 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1736 if (nchars
!= SCHARS (seq
))
1740 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1741 if (!STRING_MULTIBYTE (seq
))
1742 STRING_SET_UNIBYTE (tem
);
1744 for (i
= nchars
= nbytes
= ibyte
= 0;
1746 ++i
, ibyte
+= cbytes
)
1748 if (STRING_MULTIBYTE (seq
))
1750 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1751 SBYTES (seq
) - ibyte
);
1752 cbytes
= CHAR_BYTES (c
);
1760 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1762 unsigned char *from
= SDATA (seq
) + ibyte
;
1763 unsigned char *to
= SDATA (tem
) + nbytes
;
1769 for (n
= cbytes
; n
--; )
1779 Lisp_Object tail
, prev
;
1781 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1783 CHECK_LIST_CONS (tail
, seq
);
1785 if (!NILP (Fequal (elt
, XCAR (tail
))))
1790 Fsetcdr (prev
, XCDR (tail
));
1801 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1802 doc
: /* Reverse LIST by modifying cdr pointers.
1803 Return the reversed list. */)
1807 register Lisp_Object prev
, tail
, next
;
1809 if (NILP (list
)) return list
;
1812 while (!NILP (tail
))
1815 CHECK_LIST_CONS (tail
, list
);
1817 Fsetcdr (tail
, prev
);
1824 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1825 doc
: /* Reverse LIST, copying. Return the reversed list.
1826 See also the function `nreverse', which is used more often. */)
1832 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1835 new = Fcons (XCAR (list
), new);
1837 CHECK_LIST_END (list
, list
);
1841 Lisp_Object
merge ();
1843 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1844 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1845 Returns the sorted list. LIST is modified by side effects.
1846 PREDICATE is called with two elements of LIST, and should return non-nil
1847 if the first element should sort before the second. */)
1849 Lisp_Object list
, predicate
;
1851 Lisp_Object front
, back
;
1852 register Lisp_Object len
, tem
;
1853 struct gcpro gcpro1
, gcpro2
;
1854 register int length
;
1857 len
= Flength (list
);
1858 length
= XINT (len
);
1862 XSETINT (len
, (length
/ 2) - 1);
1863 tem
= Fnthcdr (len
, list
);
1865 Fsetcdr (tem
, Qnil
);
1867 GCPRO2 (front
, back
);
1868 front
= Fsort (front
, predicate
);
1869 back
= Fsort (back
, predicate
);
1871 return merge (front
, back
, predicate
);
1875 merge (org_l1
, org_l2
, pred
)
1876 Lisp_Object org_l1
, org_l2
;
1880 register Lisp_Object tail
;
1882 register Lisp_Object l1
, l2
;
1883 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1890 /* It is sufficient to protect org_l1 and org_l2.
1891 When l1 and l2 are updated, we copy the new values
1892 back into the org_ vars. */
1893 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1913 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1929 Fsetcdr (tail
, tem
);
1935 #if 0 /* Unsafe version. */
1936 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1937 doc
: /* Extract a value from a property list.
1938 PLIST is a property list, which is a list of the form
1939 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1940 corresponding to the given PROP, or nil if PROP is not
1941 one of the properties on the list. */)
1949 CONSP (tail
) && CONSP (XCDR (tail
));
1950 tail
= XCDR (XCDR (tail
)))
1952 if (EQ (prop
, XCAR (tail
)))
1953 return XCAR (XCDR (tail
));
1955 /* This function can be called asynchronously
1956 (setup_coding_system). Don't QUIT in that case. */
1957 if (!interrupt_input_blocked
)
1961 CHECK_LIST_END (tail
, prop
);
1967 /* This does not check for quits. That is safe since it must terminate. */
1969 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1970 doc
: /* Extract a value from a property list.
1971 PLIST is a property list, which is a list of the form
1972 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1973 corresponding to the given PROP, or nil if PROP is not one of the
1974 properties on the list. This function never signals an error. */)
1979 Lisp_Object tail
, halftail
;
1981 /* halftail is used to detect circular lists. */
1982 tail
= halftail
= plist
;
1983 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1985 if (EQ (prop
, XCAR (tail
)))
1986 return XCAR (XCDR (tail
));
1988 tail
= XCDR (XCDR (tail
));
1989 halftail
= XCDR (halftail
);
1990 if (EQ (tail
, halftail
))
1997 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1998 doc
: /* Return the value of SYMBOL's PROPNAME property.
1999 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2001 Lisp_Object symbol
, propname
;
2003 CHECK_SYMBOL (symbol
);
2004 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2007 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2008 doc
: /* Change value in PLIST of PROP to VAL.
2009 PLIST is a property list, which is a list of the form
2010 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2011 If PROP is already a property on the list, its value is set to VAL,
2012 otherwise the new PROP VAL pair is added. The new plist is returned;
2013 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2014 The PLIST is modified by side effects. */)
2017 register Lisp_Object prop
;
2020 register Lisp_Object tail
, prev
;
2021 Lisp_Object newcell
;
2023 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2024 tail
= XCDR (XCDR (tail
)))
2026 if (EQ (prop
, XCAR (tail
)))
2028 Fsetcar (XCDR (tail
), val
);
2035 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2039 Fsetcdr (XCDR (prev
), newcell
);
2043 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2044 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2045 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2046 (symbol
, propname
, value
)
2047 Lisp_Object symbol
, propname
, value
;
2049 CHECK_SYMBOL (symbol
);
2050 XSYMBOL (symbol
)->plist
2051 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2055 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2056 doc
: /* Extract a value from a property list, comparing with `equal'.
2057 PLIST is a property list, which is a list of the form
2058 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2059 corresponding to the given PROP, or nil if PROP is not
2060 one of the properties on the list. */)
2068 CONSP (tail
) && CONSP (XCDR (tail
));
2069 tail
= XCDR (XCDR (tail
)))
2071 if (! NILP (Fequal (prop
, XCAR (tail
))))
2072 return XCAR (XCDR (tail
));
2077 CHECK_LIST_END (tail
, prop
);
2082 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2083 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2084 PLIST is a property list, which is a list of the form
2085 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2086 If PROP is already a property on the list, its value is set to VAL,
2087 otherwise the new PROP VAL pair is added. The new plist is returned;
2088 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2089 The PLIST is modified by side effects. */)
2092 register Lisp_Object prop
;
2095 register Lisp_Object tail
, prev
;
2096 Lisp_Object newcell
;
2098 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2099 tail
= XCDR (XCDR (tail
)))
2101 if (! NILP (Fequal (prop
, XCAR (tail
))))
2103 Fsetcar (XCDR (tail
), val
);
2110 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2114 Fsetcdr (XCDR (prev
), newcell
);
2118 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2119 doc
: /* Return t if the two args are the same Lisp object.
2120 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2122 Lisp_Object obj1
, obj2
;
2125 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2127 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2130 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2131 doc
: /* Return t if two Lisp objects have similar structure and contents.
2132 They must have the same data type.
2133 Conses are compared by comparing the cars and the cdrs.
2134 Vectors and strings are compared element by element.
2135 Numbers are compared by value, but integers cannot equal floats.
2136 (Use `=' if you want integers and floats to be able to be equal.)
2137 Symbols must match exactly. */)
2139 register Lisp_Object o1
, o2
;
2141 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2144 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2145 doc
: /* Return t if two Lisp objects have similar structure and contents.
2146 This is like `equal' except that it compares the text properties
2147 of strings. (`equal' ignores text properties.) */)
2149 register Lisp_Object o1
, o2
;
2151 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2154 /* DEPTH is current depth of recursion. Signal an error if it
2156 PROPS, if non-nil, means compare string text properties too. */
2159 internal_equal (o1
, o2
, depth
, props
)
2160 register Lisp_Object o1
, o2
;
2164 error ("Stack overflow in equal");
2170 if (XTYPE (o1
) != XTYPE (o2
))
2179 d1
= extract_float (o1
);
2180 d2
= extract_float (o2
);
2181 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2182 though they are not =. */
2183 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2187 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2194 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2198 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2200 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2203 o1
= XOVERLAY (o1
)->plist
;
2204 o2
= XOVERLAY (o2
)->plist
;
2209 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2210 && (XMARKER (o1
)->buffer
== 0
2211 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2215 case Lisp_Vectorlike
:
2218 EMACS_INT size
= XVECTOR (o1
)->size
;
2219 /* Pseudovectors have the type encoded in the size field, so this test
2220 actually checks that the objects have the same type as well as the
2222 if (XVECTOR (o2
)->size
!= size
)
2224 /* Boolvectors are compared much like strings. */
2225 if (BOOL_VECTOR_P (o1
))
2228 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2229 / BOOL_VECTOR_BITS_PER_CHAR
);
2231 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2233 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2238 if (WINDOW_CONFIGURATIONP (o1
))
2239 return compare_window_configurations (o1
, o2
, 0);
2241 /* Aside from them, only true vectors, char-tables, and compiled
2242 functions are sensible to compare, so eliminate the others now. */
2243 if (size
& PSEUDOVECTOR_FLAG
)
2245 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2247 size
&= PSEUDOVECTOR_SIZE_MASK
;
2249 for (i
= 0; i
< size
; i
++)
2252 v1
= XVECTOR (o1
)->contents
[i
];
2253 v2
= XVECTOR (o2
)->contents
[i
];
2254 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2262 if (SCHARS (o1
) != SCHARS (o2
))
2264 if (SBYTES (o1
) != SBYTES (o2
))
2266 if (bcmp (SDATA (o1
), SDATA (o2
),
2269 if (props
&& !compare_string_intervals (o1
, o2
))
2275 case Lisp_Type_Limit
:
2282 extern Lisp_Object
Fmake_char_internal ();
2284 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2285 doc
: /* Store each element of ARRAY with ITEM.
2286 ARRAY is a vector, string, char-table, or bool-vector. */)
2288 Lisp_Object array
, item
;
2290 register int size
, index
, charval
;
2291 if (VECTORP (array
))
2293 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2294 size
= XVECTOR (array
)->size
;
2295 for (index
= 0; index
< size
; index
++)
2298 else if (CHAR_TABLE_P (array
))
2300 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2301 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2302 for (index
= 0; index
< size
; index
++)
2304 XCHAR_TABLE (array
)->defalt
= Qnil
;
2306 else if (STRINGP (array
))
2308 register unsigned char *p
= SDATA (array
);
2309 CHECK_NUMBER (item
);
2310 charval
= XINT (item
);
2311 size
= SCHARS (array
);
2312 if (STRING_MULTIBYTE (array
))
2314 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2315 int len
= CHAR_STRING (charval
, str
);
2316 int size_byte
= SBYTES (array
);
2317 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2320 if (size
!= size_byte
)
2323 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2324 if (len
!= this_len
)
2325 error ("Attempt to change byte length of a string");
2328 for (i
= 0; i
< size_byte
; i
++)
2329 *p
++ = str
[i
% len
];
2332 for (index
= 0; index
< size
; index
++)
2335 else if (BOOL_VECTOR_P (array
))
2337 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2339 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2340 / BOOL_VECTOR_BITS_PER_CHAR
);
2342 charval
= (! NILP (item
) ? -1 : 0);
2343 for (index
= 0; index
< size_in_chars
- 1; index
++)
2345 if (index
< size_in_chars
)
2347 /* Mask out bits beyond the vector size. */
2348 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2349 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2354 wrong_type_argument (Qarrayp
, array
);
2358 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2360 doc
: /* Clear the contents of STRING.
2361 This makes STRING unibyte and may change its length. */)
2366 CHECK_STRING (string
);
2367 len
= SBYTES (string
);
2368 bzero (SDATA (string
), len
);
2369 STRING_SET_CHARS (string
, len
);
2370 STRING_SET_UNIBYTE (string
);
2374 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2376 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2378 Lisp_Object char_table
;
2380 CHECK_CHAR_TABLE (char_table
);
2382 return XCHAR_TABLE (char_table
)->purpose
;
2385 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2387 doc
: /* Return the parent char-table of CHAR-TABLE.
2388 The value is either nil or another char-table.
2389 If CHAR-TABLE holds nil for a given character,
2390 then the actual applicable value is inherited from the parent char-table
2391 \(or from its parents, if necessary). */)
2393 Lisp_Object char_table
;
2395 CHECK_CHAR_TABLE (char_table
);
2397 return XCHAR_TABLE (char_table
)->parent
;
2400 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2402 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2403 Return PARENT. PARENT must be either nil or another char-table. */)
2404 (char_table
, parent
)
2405 Lisp_Object char_table
, parent
;
2409 CHECK_CHAR_TABLE (char_table
);
2413 CHECK_CHAR_TABLE (parent
);
2415 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2416 if (EQ (temp
, char_table
))
2417 error ("Attempt to make a chartable be its own parent");
2420 XCHAR_TABLE (char_table
)->parent
= parent
;
2425 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2427 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2429 Lisp_Object char_table
, n
;
2431 CHECK_CHAR_TABLE (char_table
);
2434 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2435 args_out_of_range (char_table
, n
);
2437 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2440 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2441 Sset_char_table_extra_slot
,
2443 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2444 (char_table
, n
, value
)
2445 Lisp_Object char_table
, n
, value
;
2447 CHECK_CHAR_TABLE (char_table
);
2450 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2451 args_out_of_range (char_table
, n
);
2453 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2457 char_table_range (table
, from
, to
, defalt
)
2464 if (! NILP (XCHAR_TABLE (table
)->defalt
))
2465 defalt
= XCHAR_TABLE (table
)->defalt
;
2466 val
= XCHAR_TABLE (table
)->contents
[from
];
2467 if (SUB_CHAR_TABLE_P (val
))
2468 val
= char_table_range (val
, 32, 127, defalt
);
2469 else if (NILP (val
))
2471 for (from
++; from
<= to
; from
++)
2473 Lisp_Object this_val
;
2475 this_val
= XCHAR_TABLE (table
)->contents
[from
];
2476 if (SUB_CHAR_TABLE_P (this_val
))
2477 this_val
= char_table_range (this_val
, 32, 127, defalt
);
2478 else if (NILP (this_val
))
2480 if (! EQ (val
, this_val
))
2481 error ("Characters in the range have inconsistent values");
2487 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2489 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2490 RANGE should be nil (for the default value),
2491 a vector which identifies a character set or a row of a character set,
2492 a character set name, or a character code.
2493 If the characters in the specified range have different values,
2494 an error is signaled.
2496 Note that this function doesn't check the parent of CHAR-TABLE. */)
2498 Lisp_Object char_table
, range
;
2500 int charset_id
, c1
= 0, c2
= 0;
2502 Lisp_Object ch
, val
, current_default
;
2504 CHECK_CHAR_TABLE (char_table
);
2506 if (EQ (range
, Qnil
))
2507 return XCHAR_TABLE (char_table
)->defalt
;
2508 if (INTEGERP (range
))
2510 int c
= XINT (range
);
2511 if (! CHAR_VALID_P (c
, 0))
2512 error ("Invalid character code: %d", c
);
2514 SPLIT_CHAR (c
, charset_id
, c1
, c2
);
2516 else if (SYMBOLP (range
))
2518 Lisp_Object charset_info
;
2520 charset_info
= Fget (range
, Qcharset
);
2521 CHECK_VECTOR (charset_info
);
2522 charset_id
= XINT (XVECTOR (charset_info
)->contents
[0]);
2523 ch
= Fmake_char_internal (make_number (charset_id
),
2524 make_number (0), make_number (0));
2526 else if (VECTORP (range
))
2528 size
= ASIZE (range
);
2530 args_out_of_range (range
, make_number (0));
2531 CHECK_NUMBER (AREF (range
, 0));
2532 charset_id
= XINT (AREF (range
, 0));
2535 CHECK_NUMBER (AREF (range
, 1));
2536 c1
= XINT (AREF (range
, 1));
2539 CHECK_NUMBER (AREF (range
, 2));
2540 c2
= XINT (AREF (range
, 2));
2544 /* This checks if charset_id, c0, and c1 are all valid or not. */
2545 ch
= Fmake_char_internal (make_number (charset_id
),
2546 make_number (c1
), make_number (c2
));
2549 error ("Invalid RANGE argument to `char-table-range'");
2551 if (c1
> 0 && (CHARSET_DIMENSION (charset_id
) == 1 || c2
> 0))
2553 /* Fully specified character. */
2554 Lisp_Object parent
= XCHAR_TABLE (char_table
)->parent
;
2556 XCHAR_TABLE (char_table
)->parent
= Qnil
;
2557 val
= Faref (char_table
, ch
);
2558 XCHAR_TABLE (char_table
)->parent
= parent
;
2562 current_default
= XCHAR_TABLE (char_table
)->defalt
;
2563 if (charset_id
== CHARSET_ASCII
2564 || charset_id
== CHARSET_8_BIT_CONTROL
2565 || charset_id
== CHARSET_8_BIT_GRAPHIC
)
2567 int from
, to
, defalt
;
2569 if (charset_id
== CHARSET_ASCII
)
2570 from
= 0, to
= 127, defalt
= CHAR_TABLE_DEFAULT_SLOT_ASCII
;
2571 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2572 from
= 128, to
= 159, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
;
2574 from
= 160, to
= 255, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
;
2575 if (! NILP (XCHAR_TABLE (char_table
)->contents
[defalt
]))
2576 current_default
= XCHAR_TABLE (char_table
)->contents
[defalt
];
2577 return char_table_range (char_table
, from
, to
, current_default
);
2580 val
= XCHAR_TABLE (char_table
)->contents
[128 + charset_id
];
2581 if (! SUB_CHAR_TABLE_P (val
))
2582 return (NILP (val
) ? current_default
: val
);
2583 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2584 current_default
= XCHAR_TABLE (val
)->defalt
;
2586 return char_table_range (val
, 32, 127, current_default
);
2587 val
= XCHAR_TABLE (val
)->contents
[c1
];
2588 if (! SUB_CHAR_TABLE_P (val
))
2589 return (NILP (val
) ? current_default
: val
);
2590 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2591 current_default
= XCHAR_TABLE (val
)->defalt
;
2592 return char_table_range (val
, 32, 127, current_default
);
2595 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2597 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2598 RANGE should be t (for all characters), nil (for the default value),
2599 a character set, a vector which identifies a character set, a row of a
2600 character set, or a character code. Return VALUE. */)
2601 (char_table
, range
, value
)
2602 Lisp_Object char_table
, range
, value
;
2606 CHECK_CHAR_TABLE (char_table
);
2609 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2611 /* Don't set these special slots used for default values of
2612 ascii, eight-bit-control, and eight-bit-graphic. */
2613 if (i
!= CHAR_TABLE_DEFAULT_SLOT_ASCII
2614 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2615 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
)
2616 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2618 else if (EQ (range
, Qnil
))
2619 XCHAR_TABLE (char_table
)->defalt
= value
;
2620 else if (SYMBOLP (range
))
2622 Lisp_Object charset_info
;
2625 charset_info
= Fget (range
, Qcharset
);
2626 if (! VECTORP (charset_info
)
2627 || ! NATNUMP (AREF (charset_info
, 0))
2628 || (charset_id
= XINT (AREF (charset_info
, 0)),
2629 ! CHARSET_DEFINED_P (charset_id
)))
2630 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2632 if (charset_id
== CHARSET_ASCII
)
2633 for (i
= 0; i
< 128; i
++)
2634 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2635 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2636 for (i
= 128; i
< 160; i
++)
2637 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2638 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2639 for (i
= 160; i
< 256; i
++)
2640 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2642 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2644 else if (INTEGERP (range
))
2645 Faset (char_table
, range
, value
);
2646 else if (VECTORP (range
))
2648 int size
= XVECTOR (range
)->size
;
2649 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2650 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2651 size
<= 1 ? Qnil
: val
[1],
2652 size
<= 2 ? Qnil
: val
[2]);
2653 Faset (char_table
, ch
, value
);
2656 error ("Invalid RANGE argument to `set-char-table-range'");
2661 DEFUN ("set-char-table-default", Fset_char_table_default
,
2662 Sset_char_table_default
, 3, 3, 0,
2663 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2664 The generic character specifies the group of characters.
2665 If CH is a normal character, set the default value for a group of
2666 characters to which CH belongs.
2667 See also the documentation of `make-char'. */)
2668 (char_table
, ch
, value
)
2669 Lisp_Object char_table
, ch
, value
;
2671 int c
, charset
, code1
, code2
;
2674 CHECK_CHAR_TABLE (char_table
);
2678 SPLIT_CHAR (c
, charset
, code1
, code2
);
2680 /* Since we may want to set the default value for a character set
2681 not yet defined, we check only if the character set is in the
2682 valid range or not, instead of it is already defined or not. */
2683 if (! CHARSET_VALID_P (charset
))
2684 invalid_character (c
);
2686 if (SINGLE_BYTE_CHAR_P (c
))
2688 /* We use special slots for the default values of single byte
2691 = (c
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2692 : c
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2693 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2695 return (XCHAR_TABLE (char_table
)->contents
[default_slot
] = value
);
2698 /* Even if C is not a generic char, we had better behave as if a
2699 generic char is specified. */
2700 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2702 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2703 if (! SUB_CHAR_TABLE_P (temp
))
2705 temp
= make_sub_char_table (temp
);
2706 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = temp
;
2710 XCHAR_TABLE (temp
)->defalt
= value
;
2714 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2715 if (SUB_CHAR_TABLE_P (temp
))
2716 XCHAR_TABLE (temp
)->defalt
= value
;
2718 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2722 /* Look up the element in TABLE at index CH,
2723 and return it as an integer.
2724 If the element is nil, return CH itself.
2725 (Actually we do that for any non-integer.) */
2728 char_table_translate (table
, ch
)
2733 value
= Faref (table
, make_number (ch
));
2734 if (! INTEGERP (value
))
2736 return XINT (value
);
2740 optimize_sub_char_table (table
, chars
)
2748 from
= 33, to
= 127;
2750 from
= 32, to
= 128;
2752 if (!SUB_CHAR_TABLE_P (*table
))
2754 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2755 for (; from
< to
; from
++)
2756 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2761 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2762 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2770 CHECK_CHAR_TABLE (table
);
2772 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2774 elt
= XCHAR_TABLE (table
)->contents
[i
];
2775 if (!SUB_CHAR_TABLE_P (elt
))
2777 dim
= CHARSET_DIMENSION (i
- 128);
2779 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2780 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2781 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2787 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2788 character or group of characters that share a value.
2789 DEPTH is the current depth in the originally specified
2790 chartable, and INDICES contains the vector indices
2791 for the levels our callers have descended.
2793 ARG is passed to C_FUNCTION when that is called. */
2796 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2797 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2798 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2802 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2804 GCPRO4 (arg
, table
, subtable
, function
);
2808 /* At first, handle ASCII and 8-bit European characters. */
2809 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2811 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2813 elt
= XCHAR_TABLE (subtable
)->defalt
;
2815 elt
= Faref (subtable
, make_number (i
));
2817 (*c_function
) (arg
, make_number (i
), elt
);
2819 call2 (function
, make_number (i
), elt
);
2821 #if 0 /* If the char table has entries for higher characters,
2822 we should report them. */
2823 if (NILP (current_buffer
->enable_multibyte_characters
))
2829 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2833 int charset
= XFASTINT (indices
[0]) - 128;
2836 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2837 if (CHARSET_CHARS (charset
) == 94)
2846 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2847 XSETFASTINT (indices
[depth
], i
);
2848 charset
= XFASTINT (indices
[0]) - 128;
2850 && (!CHARSET_DEFINED_P (charset
)
2851 || charset
== CHARSET_8_BIT_CONTROL
2852 || charset
== CHARSET_8_BIT_GRAPHIC
))
2855 if (SUB_CHAR_TABLE_P (elt
))
2858 error ("Too deep char table");
2859 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2865 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2866 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2867 c
= MAKE_CHAR (charset
, c1
, c2
);
2870 elt
= XCHAR_TABLE (subtable
)->defalt
;
2872 elt
= Faref (table
, make_number (c
));
2875 (*c_function
) (arg
, make_number (c
), elt
);
2877 call2 (function
, make_number (c
), elt
);
2883 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2885 void_call2 (a
, b
, c
)
2886 Lisp_Object a
, b
, c
;
2891 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2893 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2894 FUNCTION is called with two arguments--a key and a value.
2895 The key is always a possible IDX argument to `aref'. */)
2896 (function
, char_table
)
2897 Lisp_Object function
, char_table
;
2899 /* The depth of char table is at most 3. */
2900 Lisp_Object indices
[3];
2902 CHECK_CHAR_TABLE (char_table
);
2904 /* When Lisp_Object is represented as a union, `call2' cannot directly
2905 be passed to map_char_table because it returns a Lisp_Object rather
2906 than returning nothing.
2907 Casting leads to crashes on some architectures. -stef */
2908 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2912 /* Return a value for character C in char-table TABLE. Store the
2913 actual index for that value in *IDX. Ignore the default value of
2917 char_table_ref_and_index (table
, c
, idx
)
2921 int charset
, c1
, c2
;
2924 if (SINGLE_BYTE_CHAR_P (c
))
2927 return XCHAR_TABLE (table
)->contents
[c
];
2929 SPLIT_CHAR (c
, charset
, c1
, c2
);
2930 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2931 *idx
= MAKE_CHAR (charset
, 0, 0);
2932 if (!SUB_CHAR_TABLE_P (elt
))
2934 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2935 return XCHAR_TABLE (elt
)->defalt
;
2936 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2937 *idx
= MAKE_CHAR (charset
, c1
, 0);
2938 if (!SUB_CHAR_TABLE_P (elt
))
2940 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2941 return XCHAR_TABLE (elt
)->defalt
;
2943 return XCHAR_TABLE (elt
)->contents
[c2
];
2953 Lisp_Object args
[2];
2956 return Fnconc (2, args
);
2958 return Fnconc (2, &s1
);
2959 #endif /* NO_ARG_ARRAY */
2962 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2963 doc
: /* Concatenate any number of lists by altering them.
2964 Only the last argument is not altered, and need not be a list.
2965 usage: (nconc &rest LISTS) */)
2970 register int argnum
;
2971 register Lisp_Object tail
, tem
, val
;
2975 for (argnum
= 0; argnum
< nargs
; argnum
++)
2978 if (NILP (tem
)) continue;
2983 if (argnum
+ 1 == nargs
) break;
2985 CHECK_LIST_CONS (tem
, tem
);
2994 tem
= args
[argnum
+ 1];
2995 Fsetcdr (tail
, tem
);
2997 args
[argnum
+ 1] = tail
;
3003 /* This is the guts of all mapping functions.
3004 Apply FN to each element of SEQ, one by one,
3005 storing the results into elements of VALS, a C vector of Lisp_Objects.
3006 LENI is the length of VALS, which should also be the length of SEQ. */
3009 mapcar1 (leni
, vals
, fn
, seq
)
3012 Lisp_Object fn
, seq
;
3014 register Lisp_Object tail
;
3017 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3021 /* Don't let vals contain any garbage when GC happens. */
3022 for (i
= 0; i
< leni
; i
++)
3025 GCPRO3 (dummy
, fn
, seq
);
3027 gcpro1
.nvars
= leni
;
3031 /* We need not explicitly protect `tail' because it is used only on lists, and
3032 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
3036 for (i
= 0; i
< leni
; i
++)
3038 dummy
= XVECTOR (seq
)->contents
[i
];
3039 dummy
= call1 (fn
, dummy
);
3044 else if (BOOL_VECTOR_P (seq
))
3046 for (i
= 0; i
< leni
; i
++)
3049 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
3050 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
3055 dummy
= call1 (fn
, dummy
);
3060 else if (STRINGP (seq
))
3064 for (i
= 0, i_byte
= 0; i
< leni
;)
3069 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3070 XSETFASTINT (dummy
, c
);
3071 dummy
= call1 (fn
, dummy
);
3073 vals
[i_before
] = dummy
;
3076 else /* Must be a list, since Flength did not get an error */
3079 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
3081 dummy
= call1 (fn
, XCAR (tail
));
3091 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3092 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3093 In between each pair of results, stick in SEPARATOR. Thus, " " as
3094 SEPARATOR results in spaces between the values returned by FUNCTION.
3095 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3096 (function
, sequence
, separator
)
3097 Lisp_Object function
, sequence
, separator
;
3102 register Lisp_Object
*args
;
3104 struct gcpro gcpro1
;
3108 len
= Flength (sequence
);
3110 nargs
= leni
+ leni
- 1;
3111 if (nargs
< 0) return build_string ("");
3113 SAFE_ALLOCA_LISP (args
, nargs
);
3116 mapcar1 (leni
, args
, function
, sequence
);
3119 for (i
= leni
- 1; i
> 0; i
--)
3120 args
[i
+ i
] = args
[i
];
3122 for (i
= 1; i
< nargs
; i
+= 2)
3123 args
[i
] = separator
;
3125 ret
= Fconcat (nargs
, args
);
3131 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3132 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3133 The result is a list just as long as SEQUENCE.
3134 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3135 (function
, sequence
)
3136 Lisp_Object function
, sequence
;
3138 register Lisp_Object len
;
3140 register Lisp_Object
*args
;
3144 len
= Flength (sequence
);
3145 leni
= XFASTINT (len
);
3147 SAFE_ALLOCA_LISP (args
, leni
);
3149 mapcar1 (leni
, args
, function
, sequence
);
3151 ret
= Flist (leni
, args
);
3157 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3158 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3159 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3160 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3161 (function
, sequence
)
3162 Lisp_Object function
, sequence
;
3166 leni
= XFASTINT (Flength (sequence
));
3167 mapcar1 (leni
, 0, function
, sequence
);
3172 /* Anything that calls this function must protect from GC! */
3174 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3175 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3176 Takes one argument, which is the string to display to ask the question.
3177 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3178 No confirmation of the answer is requested; a single character is enough.
3179 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3180 the bindings in `query-replace-map'; see the documentation of that variable
3181 for more information. In this case, the useful bindings are `act', `skip',
3182 `recenter', and `quit'.\)
3184 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3185 is nil and `use-dialog-box' is non-nil. */)
3189 register Lisp_Object obj
, key
, def
, map
;
3190 register int answer
;
3191 Lisp_Object xprompt
;
3192 Lisp_Object args
[2];
3193 struct gcpro gcpro1
, gcpro2
;
3194 int count
= SPECPDL_INDEX ();
3196 specbind (Qcursor_in_echo_area
, Qt
);
3198 map
= Fsymbol_value (intern ("query-replace-map"));
3200 CHECK_STRING (prompt
);
3202 GCPRO2 (prompt
, xprompt
);
3204 #ifdef HAVE_X_WINDOWS
3205 if (display_hourglass_p
)
3206 cancel_hourglass ();
3213 if (FRAME_WINDOW_P (SELECTED_FRAME ())
3214 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3218 Lisp_Object pane
, menu
;
3219 redisplay_preserve_echo_area (3);
3220 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3221 Fcons (Fcons (build_string ("No"), Qnil
),
3223 menu
= Fcons (prompt
, pane
);
3224 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3225 answer
= !NILP (obj
);
3228 #endif /* HAVE_MENUS */
3229 cursor_in_echo_area
= 1;
3230 choose_minibuf_frame ();
3233 Lisp_Object pargs
[3];
3235 /* Colorize prompt according to `minibuffer-prompt' face. */
3236 pargs
[0] = build_string ("%s(y or n) ");
3237 pargs
[1] = intern ("face");
3238 pargs
[2] = intern ("minibuffer-prompt");
3239 args
[0] = Fpropertize (3, pargs
);
3244 if (minibuffer_auto_raise
)
3246 Lisp_Object mini_frame
;
3248 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3250 Fraise_frame (mini_frame
);
3253 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
3254 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
3255 cursor_in_echo_area
= 0;
3256 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3259 key
= Fmake_vector (make_number (1), obj
);
3260 def
= Flookup_key (map
, key
, Qt
);
3262 if (EQ (def
, intern ("skip")))
3267 else if (EQ (def
, intern ("act")))
3272 else if (EQ (def
, intern ("recenter")))
3278 else if (EQ (def
, intern ("quit")))
3280 /* We want to exit this command for exit-prefix,
3281 and this is the only way to do it. */
3282 else if (EQ (def
, intern ("exit-prefix")))
3287 /* If we don't clear this, then the next call to read_char will
3288 return quit_char again, and we'll enter an infinite loop. */
3293 if (EQ (xprompt
, prompt
))
3295 args
[0] = build_string ("Please answer y or n. ");
3297 xprompt
= Fconcat (2, args
);
3302 if (! noninteractive
)
3304 cursor_in_echo_area
= -1;
3305 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3309 unbind_to (count
, Qnil
);
3310 return answer
? Qt
: Qnil
;
3313 /* This is how C code calls `yes-or-no-p' and allows the user
3316 Anything that calls this function must protect from GC! */
3319 do_yes_or_no_p (prompt
)
3322 return call1 (intern ("yes-or-no-p"), prompt
);
3325 /* Anything that calls this function must protect from GC! */
3327 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3328 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3329 Takes one argument, which is the string to display to ask the question.
3330 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3331 The user must confirm the answer with RET,
3332 and can edit it until it has been confirmed.
3334 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3335 is nil, and `use-dialog-box' is non-nil. */)
3339 register Lisp_Object ans
;
3340 Lisp_Object args
[2];
3341 struct gcpro gcpro1
;
3343 CHECK_STRING (prompt
);
3346 if (FRAME_WINDOW_P (SELECTED_FRAME ())
3347 && (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3351 Lisp_Object pane
, menu
, obj
;
3352 redisplay_preserve_echo_area (4);
3353 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3354 Fcons (Fcons (build_string ("No"), Qnil
),
3357 menu
= Fcons (prompt
, pane
);
3358 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3362 #endif /* HAVE_MENUS */
3365 args
[1] = build_string ("(yes or no) ");
3366 prompt
= Fconcat (2, args
);
3372 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3373 Qyes_or_no_p_history
, Qnil
,
3375 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3380 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3388 message ("Please answer yes or no.");
3389 Fsleep_for (make_number (2), Qnil
);
3393 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3394 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3396 Each of the three load averages is multiplied by 100, then converted
3399 When USE-FLOATS is non-nil, floats will be used instead of integers.
3400 These floats are not multiplied by 100.
3402 If the 5-minute or 15-minute load averages are not available, return a
3403 shortened list, containing only those averages which are available.
3405 An error is thrown if the load average can't be obtained. In some
3406 cases making it work would require Emacs being installed setuid or
3407 setgid so that it can read kernel information, and that usually isn't
3410 Lisp_Object use_floats
;
3413 int loads
= getloadavg (load_ave
, 3);
3414 Lisp_Object ret
= Qnil
;
3417 error ("load-average not implemented for this operating system");
3421 Lisp_Object load
= (NILP (use_floats
) ?
3422 make_number ((int) (100.0 * load_ave
[loads
]))
3423 : make_float (load_ave
[loads
]));
3424 ret
= Fcons (load
, ret
);
3430 Lisp_Object Vfeatures
, Qsubfeatures
;
3431 extern Lisp_Object Vafter_load_alist
;
3433 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3434 doc
: /* Returns t if FEATURE is present in this Emacs.
3436 Use this to conditionalize execution of lisp code based on the
3437 presence or absence of emacs or environment extensions.
3438 Use `provide' to declare that a feature is available. This function
3439 looks at the value of the variable `features'. The optional argument
3440 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3441 (feature
, subfeature
)
3442 Lisp_Object feature
, subfeature
;
3444 register Lisp_Object tem
;
3445 CHECK_SYMBOL (feature
);
3446 tem
= Fmemq (feature
, Vfeatures
);
3447 if (!NILP (tem
) && !NILP (subfeature
))
3448 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3449 return (NILP (tem
)) ? Qnil
: Qt
;
3452 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3453 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3454 The optional argument SUBFEATURES should be a list of symbols listing
3455 particular subfeatures supported in this version of FEATURE. */)
3456 (feature
, subfeatures
)
3457 Lisp_Object feature
, subfeatures
;
3459 register Lisp_Object tem
;
3460 CHECK_SYMBOL (feature
);
3461 CHECK_LIST (subfeatures
);
3462 if (!NILP (Vautoload_queue
))
3463 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
3465 tem
= Fmemq (feature
, Vfeatures
);
3467 Vfeatures
= Fcons (feature
, Vfeatures
);
3468 if (!NILP (subfeatures
))
3469 Fput (feature
, Qsubfeatures
, subfeatures
);
3470 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3472 /* Run any load-hooks for this file. */
3473 tem
= Fassq (feature
, Vafter_load_alist
);
3475 Fprogn (XCDR (tem
));
3480 /* `require' and its subroutines. */
3482 /* List of features currently being require'd, innermost first. */
3484 Lisp_Object require_nesting_list
;
3487 require_unwind (old_value
)
3488 Lisp_Object old_value
;
3490 return require_nesting_list
= old_value
;
3493 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3494 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3495 If FEATURE is not a member of the list `features', then the feature
3496 is not loaded; so load the file FILENAME.
3497 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3498 and `load' will try to load this name appended with the suffix `.elc' or
3499 `.el', in that order. The name without appended suffix will not be used.
3500 If the optional third argument NOERROR is non-nil,
3501 then return nil if the file is not found instead of signaling an error.
3502 Normally the return value is FEATURE.
3503 The normal messages at start and end of loading FILENAME are suppressed. */)
3504 (feature
, filename
, noerror
)
3505 Lisp_Object feature
, filename
, noerror
;
3507 register Lisp_Object tem
;
3508 struct gcpro gcpro1
, gcpro2
;
3509 int from_file
= load_in_progress
;
3511 CHECK_SYMBOL (feature
);
3513 /* Record the presence of `require' in this file
3514 even if the feature specified is already loaded.
3515 But not more than once in any file,
3516 and not when we aren't loading or reading from a file. */
3518 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
3519 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
3524 tem
= Fcons (Qrequire
, feature
);
3525 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3526 LOADHIST_ATTACH (tem
);
3528 tem
= Fmemq (feature
, Vfeatures
);
3532 int count
= SPECPDL_INDEX ();
3535 /* This is to make sure that loadup.el gives a clear picture
3536 of what files are preloaded and when. */
3537 if (! NILP (Vpurify_flag
))
3538 error ("(require %s) while preparing to dump",
3539 SDATA (SYMBOL_NAME (feature
)));
3541 /* A certain amount of recursive `require' is legitimate,
3542 but if we require the same feature recursively 3 times,
3544 tem
= require_nesting_list
;
3545 while (! NILP (tem
))
3547 if (! NILP (Fequal (feature
, XCAR (tem
))))
3552 error ("Recursive `require' for feature `%s'",
3553 SDATA (SYMBOL_NAME (feature
)));
3555 /* Update the list for any nested `require's that occur. */
3556 record_unwind_protect (require_unwind
, require_nesting_list
);
3557 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3559 /* Value saved here is to be restored into Vautoload_queue */
3560 record_unwind_protect (un_autoload
, Vautoload_queue
);
3561 Vautoload_queue
= Qt
;
3563 /* Load the file. */
3564 GCPRO2 (feature
, filename
);
3565 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3566 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3569 /* If load failed entirely, return nil. */
3571 return unbind_to (count
, Qnil
);
3573 tem
= Fmemq (feature
, Vfeatures
);
3575 error ("Required feature `%s' was not provided",
3576 SDATA (SYMBOL_NAME (feature
)));
3578 /* Once loading finishes, don't undo it. */
3579 Vautoload_queue
= Qt
;
3580 feature
= unbind_to (count
, feature
);
3586 /* Primitives for work of the "widget" library.
3587 In an ideal world, this section would not have been necessary.
3588 However, lisp function calls being as slow as they are, it turns
3589 out that some functions in the widget library (wid-edit.el) are the
3590 bottleneck of Widget operation. Here is their translation to C,
3591 for the sole reason of efficiency. */
3593 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3594 doc
: /* Return non-nil if PLIST has the property PROP.
3595 PLIST is a property list, which is a list of the form
3596 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3597 Unlike `plist-get', this allows you to distinguish between a missing
3598 property and a property with the value nil.
3599 The value is actually the tail of PLIST whose car is PROP. */)
3601 Lisp_Object plist
, prop
;
3603 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3606 plist
= XCDR (plist
);
3607 plist
= CDR (plist
);
3612 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3613 doc
: /* In WIDGET, set PROPERTY to VALUE.
3614 The value can later be retrieved with `widget-get'. */)
3615 (widget
, property
, value
)
3616 Lisp_Object widget
, property
, value
;
3618 CHECK_CONS (widget
);
3619 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3623 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3624 doc
: /* In WIDGET, get the value of PROPERTY.
3625 The value could either be specified when the widget was created, or
3626 later with `widget-put'. */)
3628 Lisp_Object widget
, property
;
3636 CHECK_CONS (widget
);
3637 tmp
= Fplist_member (XCDR (widget
), property
);
3643 tmp
= XCAR (widget
);
3646 widget
= Fget (tmp
, Qwidget_type
);
3650 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3651 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3652 ARGS are passed as extra arguments to the function.
3653 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3658 /* This function can GC. */
3659 Lisp_Object newargs
[3];
3660 struct gcpro gcpro1
, gcpro2
;
3663 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3664 newargs
[1] = args
[0];
3665 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3666 GCPRO2 (newargs
[0], newargs
[2]);
3667 result
= Fapply (3, newargs
);
3672 #ifdef HAVE_LANGINFO_CODESET
3673 #include <langinfo.h>
3676 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3677 doc
: /* Access locale data ITEM for the current C locale, if available.
3678 ITEM should be one of the following:
3680 `codeset', returning the character set as a string (locale item CODESET);
3682 `days', returning a 7-element vector of day names (locale items DAY_n);
3684 `months', returning a 12-element vector of month names (locale items MON_n);
3686 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3687 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3689 If the system can't provide such information through a call to
3690 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3692 See also Info node `(libc)Locales'.
3694 The data read from the system are decoded using `locale-coding-system'. */)
3699 #ifdef HAVE_LANGINFO_CODESET
3701 if (EQ (item
, Qcodeset
))
3703 str
= nl_langinfo (CODESET
);
3704 return build_string (str
);
3707 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3709 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3710 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3712 synchronize_system_time_locale ();
3713 for (i
= 0; i
< 7; i
++)
3715 str
= nl_langinfo (days
[i
]);
3716 val
= make_unibyte_string (str
, strlen (str
));
3717 /* Fixme: Is this coding system necessarily right, even if
3718 it is consistent with CODESET? If not, what to do? */
3719 Faset (v
, make_number (i
),
3720 code_convert_string_norecord (val
, Vlocale_coding_system
,
3727 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3729 struct Lisp_Vector
*p
= allocate_vector (12);
3730 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3731 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3733 synchronize_system_time_locale ();
3734 for (i
= 0; i
< 12; i
++)
3736 str
= nl_langinfo (months
[i
]);
3737 val
= make_unibyte_string (str
, strlen (str
));
3739 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3741 XSETVECTOR (val
, p
);
3745 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3746 but is in the locale files. This could be used by ps-print. */
3748 else if (EQ (item
, Qpaper
))
3750 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3751 make_number (nl_langinfo (PAPER_HEIGHT
)));
3753 #endif /* PAPER_WIDTH */
3754 #endif /* HAVE_LANGINFO_CODESET*/
3758 /* base64 encode/decode functions (RFC 2045).
3759 Based on code from GNU recode. */
3761 #define MIME_LINE_LENGTH 76
3763 #define IS_ASCII(Character) \
3765 #define IS_BASE64(Character) \
3766 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3767 #define IS_BASE64_IGNORABLE(Character) \
3768 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3769 || (Character) == '\f' || (Character) == '\r')
3771 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3772 character or return retval if there are no characters left to
3774 #define READ_QUADRUPLET_BYTE(retval) \
3779 if (nchars_return) \
3780 *nchars_return = nchars; \
3785 while (IS_BASE64_IGNORABLE (c))
3787 /* Table of characters coding the 64 values. */
3788 static char base64_value_to_char
[64] =
3790 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3791 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3792 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3793 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3794 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3795 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3796 '8', '9', '+', '/' /* 60-63 */
3799 /* Table of base64 values for first 128 characters. */
3800 static short base64_char_to_value
[128] =
3802 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3803 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3804 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3805 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3806 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3807 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3808 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3809 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3810 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3811 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3812 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3813 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3814 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3817 /* The following diagram shows the logical steps by which three octets
3818 get transformed into four base64 characters.
3820 .--------. .--------. .--------.
3821 |aaaaaabb| |bbbbcccc| |ccdddddd|
3822 `--------' `--------' `--------'
3824 .--------+--------+--------+--------.
3825 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3826 `--------+--------+--------+--------'
3828 .--------+--------+--------+--------.
3829 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3830 `--------+--------+--------+--------'
3832 The octets are divided into 6 bit chunks, which are then encoded into
3833 base64 characters. */
3836 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3837 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3839 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3841 doc
: /* Base64-encode the region between BEG and END.
3842 Return the length of the encoded text.
3843 Optional third argument NO-LINE-BREAK means do not break long lines
3844 into shorter lines. */)
3845 (beg
, end
, no_line_break
)
3846 Lisp_Object beg
, end
, no_line_break
;
3849 int allength
, length
;
3850 int ibeg
, iend
, encoded_length
;
3854 validate_region (&beg
, &end
);
3856 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3857 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3858 move_gap_both (XFASTINT (beg
), ibeg
);
3860 /* We need to allocate enough room for encoding the text.
3861 We need 33 1/3% more space, plus a newline every 76
3862 characters, and then we round up. */
3863 length
= iend
- ibeg
;
3864 allength
= length
+ length
/3 + 1;
3865 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3867 SAFE_ALLOCA (encoded
, char *, allength
);
3868 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3869 NILP (no_line_break
),
3870 !NILP (current_buffer
->enable_multibyte_characters
));
3871 if (encoded_length
> allength
)
3874 if (encoded_length
< 0)
3876 /* The encoding wasn't possible. */
3878 error ("Multibyte character in data for base64 encoding");
3881 /* Now we have encoded the region, so we insert the new contents
3882 and delete the old. (Insert first in order to preserve markers.) */
3883 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3884 insert (encoded
, encoded_length
);
3886 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3888 /* If point was outside of the region, restore it exactly; else just
3889 move to the beginning of the region. */
3890 if (old_pos
>= XFASTINT (end
))
3891 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3892 else if (old_pos
> XFASTINT (beg
))
3893 old_pos
= XFASTINT (beg
);
3896 /* We return the length of the encoded text. */
3897 return make_number (encoded_length
);
3900 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3902 doc
: /* Base64-encode STRING and return the result.
3903 Optional second argument NO-LINE-BREAK means do not break long lines
3904 into shorter lines. */)
3905 (string
, no_line_break
)
3906 Lisp_Object string
, no_line_break
;
3908 int allength
, length
, encoded_length
;
3910 Lisp_Object encoded_string
;
3913 CHECK_STRING (string
);
3915 /* We need to allocate enough room for encoding the text.
3916 We need 33 1/3% more space, plus a newline every 76
3917 characters, and then we round up. */
3918 length
= SBYTES (string
);
3919 allength
= length
+ length
/3 + 1;
3920 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3922 /* We need to allocate enough room for decoding the text. */
3923 SAFE_ALLOCA (encoded
, char *, allength
);
3925 encoded_length
= base64_encode_1 (SDATA (string
),
3926 encoded
, length
, NILP (no_line_break
),
3927 STRING_MULTIBYTE (string
));
3928 if (encoded_length
> allength
)
3931 if (encoded_length
< 0)
3933 /* The encoding wasn't possible. */
3935 error ("Multibyte character in data for base64 encoding");
3938 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3941 return encoded_string
;
3945 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3952 int counter
= 0, i
= 0;
3962 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3970 /* Wrap line every 76 characters. */
3974 if (counter
< MIME_LINE_LENGTH
/ 4)
3983 /* Process first byte of a triplet. */
3985 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3986 value
= (0x03 & c
) << 4;
3988 /* Process second byte of a triplet. */
3992 *e
++ = base64_value_to_char
[value
];
4000 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4008 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
4009 value
= (0x0f & c
) << 2;
4011 /* Process third byte of a triplet. */
4015 *e
++ = base64_value_to_char
[value
];
4022 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4030 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
4031 *e
++ = base64_value_to_char
[0x3f & c
];
4038 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
4040 doc
: /* Base64-decode the region between BEG and END.
4041 Return the length of the decoded text.
4042 If the region can't be decoded, signal an error and don't modify the buffer. */)
4044 Lisp_Object beg
, end
;
4046 int ibeg
, iend
, length
, allength
;
4051 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
4054 validate_region (&beg
, &end
);
4056 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
4057 iend
= CHAR_TO_BYTE (XFASTINT (end
));
4059 length
= iend
- ibeg
;
4061 /* We need to allocate enough room for decoding the text. If we are
4062 working on a multibyte buffer, each decoded code may occupy at
4064 allength
= multibyte
? length
* 2 : length
;
4065 SAFE_ALLOCA (decoded
, char *, allength
);
4067 move_gap_both (XFASTINT (beg
), ibeg
);
4068 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
4069 multibyte
, &inserted_chars
);
4070 if (decoded_length
> allength
)
4073 if (decoded_length
< 0)
4075 /* The decoding wasn't possible. */
4077 error ("Invalid base64 data");
4080 /* Now we have decoded the region, so we insert the new contents
4081 and delete the old. (Insert first in order to preserve markers.) */
4082 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4083 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4086 /* Delete the original text. */
4087 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4088 iend
+ decoded_length
, 1);
4090 /* If point was outside of the region, restore it exactly; else just
4091 move to the beginning of the region. */
4092 if (old_pos
>= XFASTINT (end
))
4093 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4094 else if (old_pos
> XFASTINT (beg
))
4095 old_pos
= XFASTINT (beg
);
4096 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4098 return make_number (inserted_chars
);
4101 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4103 doc
: /* Base64-decode STRING and return the result. */)
4108 int length
, decoded_length
;
4109 Lisp_Object decoded_string
;
4112 CHECK_STRING (string
);
4114 length
= SBYTES (string
);
4115 /* We need to allocate enough room for decoding the text. */
4116 SAFE_ALLOCA (decoded
, char *, length
);
4118 /* The decoded result should be unibyte. */
4119 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4121 if (decoded_length
> length
)
4123 else if (decoded_length
>= 0)
4124 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4126 decoded_string
= Qnil
;
4129 if (!STRINGP (decoded_string
))
4130 error ("Invalid base64 data");
4132 return decoded_string
;
4135 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4136 MULTIBYTE is nonzero, the decoded result should be in multibyte
4137 form. If NCHARS_RETRUN is not NULL, store the number of produced
4138 characters in *NCHARS_RETURN. */
4141 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4151 unsigned long value
;
4156 /* Process first byte of a quadruplet. */
4158 READ_QUADRUPLET_BYTE (e
-to
);
4162 value
= base64_char_to_value
[c
] << 18;
4164 /* Process second byte of a quadruplet. */
4166 READ_QUADRUPLET_BYTE (-1);
4170 value
|= base64_char_to_value
[c
] << 12;
4172 c
= (unsigned char) (value
>> 16);
4174 e
+= CHAR_STRING (c
, e
);
4179 /* Process third byte of a quadruplet. */
4181 READ_QUADRUPLET_BYTE (-1);
4185 READ_QUADRUPLET_BYTE (-1);
4194 value
|= base64_char_to_value
[c
] << 6;
4196 c
= (unsigned char) (0xff & value
>> 8);
4198 e
+= CHAR_STRING (c
, e
);
4203 /* Process fourth byte of a quadruplet. */
4205 READ_QUADRUPLET_BYTE (-1);
4212 value
|= base64_char_to_value
[c
];
4214 c
= (unsigned char) (0xff & value
);
4216 e
+= CHAR_STRING (c
, e
);
4225 /***********************************************************************
4227 ***** Hash Tables *****
4229 ***********************************************************************/
4231 /* Implemented by gerd@gnu.org. This hash table implementation was
4232 inspired by CMUCL hash tables. */
4236 1. For small tables, association lists are probably faster than
4237 hash tables because they have lower overhead.
4239 For uses of hash tables where the O(1) behavior of table
4240 operations is not a requirement, it might therefore be a good idea
4241 not to hash. Instead, we could just do a linear search in the
4242 key_and_value vector of the hash table. This could be done
4243 if a `:linear-search t' argument is given to make-hash-table. */
4246 /* The list of all weak hash tables. Don't staticpro this one. */
4248 Lisp_Object Vweak_hash_tables
;
4250 /* Various symbols. */
4252 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4253 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4254 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4256 /* Function prototypes. */
4258 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4259 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4260 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4261 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4262 Lisp_Object
, unsigned));
4263 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4264 Lisp_Object
, unsigned));
4265 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4266 unsigned, Lisp_Object
, unsigned));
4267 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4268 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4269 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4270 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4272 static unsigned sxhash_string
P_ ((unsigned char *, int));
4273 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4274 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4275 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4276 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4280 /***********************************************************************
4282 ***********************************************************************/
4284 /* If OBJ is a Lisp hash table, return a pointer to its struct
4285 Lisp_Hash_Table. Otherwise, signal an error. */
4287 static struct Lisp_Hash_Table
*
4288 check_hash_table (obj
)
4291 CHECK_HASH_TABLE (obj
);
4292 return XHASH_TABLE (obj
);
4296 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4300 next_almost_prime (n
)
4313 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4314 which USED[I] is non-zero. If found at index I in ARGS, set
4315 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4316 -1. This function is used to extract a keyword/argument pair from
4317 a DEFUN parameter list. */
4320 get_key_arg (key
, nargs
, args
, used
)
4328 for (i
= 0; i
< nargs
- 1; ++i
)
4329 if (!used
[i
] && EQ (args
[i
], key
))
4344 /* Return a Lisp vector which has the same contents as VEC but has
4345 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4346 vector that are not copied from VEC are set to INIT. */
4349 larger_vector (vec
, new_size
, init
)
4354 struct Lisp_Vector
*v
;
4357 xassert (VECTORP (vec
));
4358 old_size
= XVECTOR (vec
)->size
;
4359 xassert (new_size
>= old_size
);
4361 v
= allocate_vector (new_size
);
4362 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4363 old_size
* sizeof *v
->contents
);
4364 for (i
= old_size
; i
< new_size
; ++i
)
4365 v
->contents
[i
] = init
;
4366 XSETVECTOR (vec
, v
);
4371 /***********************************************************************
4373 ***********************************************************************/
4375 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4376 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4377 KEY2 are the same. */
4380 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4381 struct Lisp_Hash_Table
*h
;
4382 Lisp_Object key1
, key2
;
4383 unsigned hash1
, hash2
;
4385 return (FLOATP (key1
)
4387 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4391 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4392 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4393 KEY2 are the same. */
4396 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4397 struct Lisp_Hash_Table
*h
;
4398 Lisp_Object key1
, key2
;
4399 unsigned hash1
, hash2
;
4401 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4405 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4406 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4407 if KEY1 and KEY2 are the same. */
4410 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4411 struct Lisp_Hash_Table
*h
;
4412 Lisp_Object key1
, key2
;
4413 unsigned hash1
, hash2
;
4417 Lisp_Object args
[3];
4419 args
[0] = h
->user_cmp_function
;
4422 return !NILP (Ffuncall (3, args
));
4429 /* Value is a hash code for KEY for use in hash table H which uses
4430 `eq' to compare keys. The hash code returned is guaranteed to fit
4431 in a Lisp integer. */
4435 struct Lisp_Hash_Table
*h
;
4438 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4439 xassert ((hash
& ~INTMASK
) == 0);
4444 /* Value is a hash code for KEY for use in hash table H which uses
4445 `eql' to compare keys. The hash code returned is guaranteed to fit
4446 in a Lisp integer. */
4450 struct Lisp_Hash_Table
*h
;
4455 hash
= sxhash (key
, 0);
4457 hash
= XUINT (key
) ^ XGCTYPE (key
);
4458 xassert ((hash
& ~INTMASK
) == 0);
4463 /* Value is a hash code for KEY for use in hash table H which uses
4464 `equal' to compare keys. The hash code returned is guaranteed to fit
4465 in a Lisp integer. */
4468 hashfn_equal (h
, key
)
4469 struct Lisp_Hash_Table
*h
;
4472 unsigned hash
= sxhash (key
, 0);
4473 xassert ((hash
& ~INTMASK
) == 0);
4478 /* Value is a hash code for KEY for use in hash table H which uses as
4479 user-defined function to compare keys. The hash code returned is
4480 guaranteed to fit in a Lisp integer. */
4483 hashfn_user_defined (h
, key
)
4484 struct Lisp_Hash_Table
*h
;
4487 Lisp_Object args
[2], hash
;
4489 args
[0] = h
->user_hash_function
;
4491 hash
= Ffuncall (2, args
);
4492 if (!INTEGERP (hash
))
4493 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
4494 return XUINT (hash
);
4498 /* Create and initialize a new hash table.
4500 TEST specifies the test the hash table will use to compare keys.
4501 It must be either one of the predefined tests `eq', `eql' or
4502 `equal' or a symbol denoting a user-defined test named TEST with
4503 test and hash functions USER_TEST and USER_HASH.
4505 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4507 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4508 new size when it becomes full is computed by adding REHASH_SIZE to
4509 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4510 table's new size is computed by multiplying its old size with
4513 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4514 be resized when the ratio of (number of entries in the table) /
4515 (table size) is >= REHASH_THRESHOLD.
4517 WEAK specifies the weakness of the table. If non-nil, it must be
4518 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4521 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4522 user_test
, user_hash
)
4523 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4524 Lisp_Object user_test
, user_hash
;
4526 struct Lisp_Hash_Table
*h
;
4528 int index_size
, i
, sz
;
4530 /* Preconditions. */
4531 xassert (SYMBOLP (test
));
4532 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4533 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4534 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4535 xassert (FLOATP (rehash_threshold
)
4536 && XFLOATINT (rehash_threshold
) > 0
4537 && XFLOATINT (rehash_threshold
) <= 1.0);
4539 if (XFASTINT (size
) == 0)
4540 size
= make_number (1);
4542 /* Allocate a table and initialize it. */
4543 h
= allocate_hash_table ();
4545 /* Initialize hash table slots. */
4546 sz
= XFASTINT (size
);
4549 if (EQ (test
, Qeql
))
4551 h
->cmpfn
= cmpfn_eql
;
4552 h
->hashfn
= hashfn_eql
;
4554 else if (EQ (test
, Qeq
))
4557 h
->hashfn
= hashfn_eq
;
4559 else if (EQ (test
, Qequal
))
4561 h
->cmpfn
= cmpfn_equal
;
4562 h
->hashfn
= hashfn_equal
;
4566 h
->user_cmp_function
= user_test
;
4567 h
->user_hash_function
= user_hash
;
4568 h
->cmpfn
= cmpfn_user_defined
;
4569 h
->hashfn
= hashfn_user_defined
;
4573 h
->rehash_threshold
= rehash_threshold
;
4574 h
->rehash_size
= rehash_size
;
4575 h
->count
= make_number (0);
4576 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4577 h
->hash
= Fmake_vector (size
, Qnil
);
4578 h
->next
= Fmake_vector (size
, Qnil
);
4579 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4580 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4581 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4583 /* Set up the free list. */
4584 for (i
= 0; i
< sz
- 1; ++i
)
4585 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4586 h
->next_free
= make_number (0);
4588 XSET_HASH_TABLE (table
, h
);
4589 xassert (HASH_TABLE_P (table
));
4590 xassert (XHASH_TABLE (table
) == h
);
4592 /* Maybe add this hash table to the list of all weak hash tables. */
4594 h
->next_weak
= Qnil
;
4597 h
->next_weak
= Vweak_hash_tables
;
4598 Vweak_hash_tables
= table
;
4605 /* Return a copy of hash table H1. Keys and values are not copied,
4606 only the table itself is. */
4609 copy_hash_table (h1
)
4610 struct Lisp_Hash_Table
*h1
;
4613 struct Lisp_Hash_Table
*h2
;
4614 struct Lisp_Vector
*next
;
4616 h2
= allocate_hash_table ();
4617 next
= h2
->vec_next
;
4618 bcopy (h1
, h2
, sizeof *h2
);
4619 h2
->vec_next
= next
;
4620 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4621 h2
->hash
= Fcopy_sequence (h1
->hash
);
4622 h2
->next
= Fcopy_sequence (h1
->next
);
4623 h2
->index
= Fcopy_sequence (h1
->index
);
4624 XSET_HASH_TABLE (table
, h2
);
4626 /* Maybe add this hash table to the list of all weak hash tables. */
4627 if (!NILP (h2
->weak
))
4629 h2
->next_weak
= Vweak_hash_tables
;
4630 Vweak_hash_tables
= table
;
4637 /* Resize hash table H if it's too full. If H cannot be resized
4638 because it's already too large, throw an error. */
4641 maybe_resize_hash_table (h
)
4642 struct Lisp_Hash_Table
*h
;
4644 if (NILP (h
->next_free
))
4646 int old_size
= HASH_TABLE_SIZE (h
);
4647 int i
, new_size
, index_size
;
4649 if (INTEGERP (h
->rehash_size
))
4650 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4652 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4653 new_size
= max (old_size
+ 1, new_size
);
4654 index_size
= next_almost_prime ((int)
4656 / XFLOATINT (h
->rehash_threshold
)));
4657 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4658 error ("Hash table too large to resize");
4660 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4661 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4662 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4663 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4665 /* Update the free list. Do it so that new entries are added at
4666 the end of the free list. This makes some operations like
4668 for (i
= old_size
; i
< new_size
- 1; ++i
)
4669 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4671 if (!NILP (h
->next_free
))
4673 Lisp_Object last
, next
;
4675 last
= h
->next_free
;
4676 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4680 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4683 XSETFASTINT (h
->next_free
, old_size
);
4686 for (i
= 0; i
< old_size
; ++i
)
4687 if (!NILP (HASH_HASH (h
, i
)))
4689 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4690 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4691 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4692 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4698 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4699 the hash code of KEY. Value is the index of the entry in H
4700 matching KEY, or -1 if not found. */
4703 hash_lookup (h
, key
, hash
)
4704 struct Lisp_Hash_Table
*h
;
4709 int start_of_bucket
;
4712 hash_code
= h
->hashfn (h
, key
);
4716 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4717 idx
= HASH_INDEX (h
, start_of_bucket
);
4719 /* We need not gcpro idx since it's either an integer or nil. */
4722 int i
= XFASTINT (idx
);
4723 if (EQ (key
, HASH_KEY (h
, i
))
4725 && h
->cmpfn (h
, key
, hash_code
,
4726 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4728 idx
= HASH_NEXT (h
, i
);
4731 return NILP (idx
) ? -1 : XFASTINT (idx
);
4735 /* Put an entry into hash table H that associates KEY with VALUE.
4736 HASH is a previously computed hash code of KEY.
4737 Value is the index of the entry in H matching KEY. */
4740 hash_put (h
, key
, value
, hash
)
4741 struct Lisp_Hash_Table
*h
;
4742 Lisp_Object key
, value
;
4745 int start_of_bucket
, i
;
4747 xassert ((hash
& ~INTMASK
) == 0);
4749 /* Increment count after resizing because resizing may fail. */
4750 maybe_resize_hash_table (h
);
4751 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4753 /* Store key/value in the key_and_value vector. */
4754 i
= XFASTINT (h
->next_free
);
4755 h
->next_free
= HASH_NEXT (h
, i
);
4756 HASH_KEY (h
, i
) = key
;
4757 HASH_VALUE (h
, i
) = value
;
4759 /* Remember its hash code. */
4760 HASH_HASH (h
, i
) = make_number (hash
);
4762 /* Add new entry to its collision chain. */
4763 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4764 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4765 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4770 /* Remove the entry matching KEY from hash table H, if there is one. */
4773 hash_remove (h
, key
)
4774 struct Lisp_Hash_Table
*h
;
4778 int start_of_bucket
;
4779 Lisp_Object idx
, prev
;
4781 hash_code
= h
->hashfn (h
, key
);
4782 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4783 idx
= HASH_INDEX (h
, start_of_bucket
);
4786 /* We need not gcpro idx, prev since they're either integers or nil. */
4789 int i
= XFASTINT (idx
);
4791 if (EQ (key
, HASH_KEY (h
, i
))
4793 && h
->cmpfn (h
, key
, hash_code
,
4794 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4796 /* Take entry out of collision chain. */
4798 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4800 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4802 /* Clear slots in key_and_value and add the slots to
4804 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4805 HASH_NEXT (h
, i
) = h
->next_free
;
4806 h
->next_free
= make_number (i
);
4807 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4808 xassert (XINT (h
->count
) >= 0);
4814 idx
= HASH_NEXT (h
, i
);
4820 /* Clear hash table H. */
4824 struct Lisp_Hash_Table
*h
;
4826 if (XFASTINT (h
->count
) > 0)
4828 int i
, size
= HASH_TABLE_SIZE (h
);
4830 for (i
= 0; i
< size
; ++i
)
4832 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4833 HASH_KEY (h
, i
) = Qnil
;
4834 HASH_VALUE (h
, i
) = Qnil
;
4835 HASH_HASH (h
, i
) = Qnil
;
4838 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4839 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4841 h
->next_free
= make_number (0);
4842 h
->count
= make_number (0);
4848 /************************************************************************
4850 ************************************************************************/
4852 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4853 entries from the table that don't survive the current GC.
4854 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4855 non-zero if anything was marked. */
4858 sweep_weak_table (h
, remove_entries_p
)
4859 struct Lisp_Hash_Table
*h
;
4860 int remove_entries_p
;
4862 int bucket
, n
, marked
;
4864 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4867 for (bucket
= 0; bucket
< n
; ++bucket
)
4869 Lisp_Object idx
, next
, prev
;
4871 /* Follow collision chain, removing entries that
4872 don't survive this garbage collection. */
4874 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4876 int i
= XFASTINT (idx
);
4877 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4878 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4881 if (EQ (h
->weak
, Qkey
))
4882 remove_p
= !key_known_to_survive_p
;
4883 else if (EQ (h
->weak
, Qvalue
))
4884 remove_p
= !value_known_to_survive_p
;
4885 else if (EQ (h
->weak
, Qkey_or_value
))
4886 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4887 else if (EQ (h
->weak
, Qkey_and_value
))
4888 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4892 next
= HASH_NEXT (h
, i
);
4894 if (remove_entries_p
)
4898 /* Take out of collision chain. */
4900 HASH_INDEX (h
, bucket
) = next
;
4902 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4904 /* Add to free list. */
4905 HASH_NEXT (h
, i
) = h
->next_free
;
4908 /* Clear key, value, and hash. */
4909 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4910 HASH_HASH (h
, i
) = Qnil
;
4912 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4923 /* Make sure key and value survive. */
4924 if (!key_known_to_survive_p
)
4926 mark_object (HASH_KEY (h
, i
));
4930 if (!value_known_to_survive_p
)
4932 mark_object (HASH_VALUE (h
, i
));
4943 /* Remove elements from weak hash tables that don't survive the
4944 current garbage collection. Remove weak tables that don't survive
4945 from Vweak_hash_tables. Called from gc_sweep. */
4948 sweep_weak_hash_tables ()
4950 Lisp_Object table
, used
, next
;
4951 struct Lisp_Hash_Table
*h
;
4954 /* Mark all keys and values that are in use. Keep on marking until
4955 there is no more change. This is necessary for cases like
4956 value-weak table A containing an entry X -> Y, where Y is used in a
4957 key-weak table B, Z -> Y. If B comes after A in the list of weak
4958 tables, X -> Y might be removed from A, although when looking at B
4959 one finds that it shouldn't. */
4963 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4965 h
= XHASH_TABLE (table
);
4966 if (h
->size
& ARRAY_MARK_FLAG
)
4967 marked
|= sweep_weak_table (h
, 0);
4972 /* Remove tables and entries that aren't used. */
4973 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4975 h
= XHASH_TABLE (table
);
4976 next
= h
->next_weak
;
4978 if (h
->size
& ARRAY_MARK_FLAG
)
4980 /* TABLE is marked as used. Sweep its contents. */
4981 if (XFASTINT (h
->count
) > 0)
4982 sweep_weak_table (h
, 1);
4984 /* Add table to the list of used weak hash tables. */
4985 h
->next_weak
= used
;
4990 Vweak_hash_tables
= used
;
4995 /***********************************************************************
4996 Hash Code Computation
4997 ***********************************************************************/
4999 /* Maximum depth up to which to dive into Lisp structures. */
5001 #define SXHASH_MAX_DEPTH 3
5003 /* Maximum length up to which to take list and vector elements into
5006 #define SXHASH_MAX_LEN 7
5008 /* Combine two integers X and Y for hashing. */
5010 #define SXHASH_COMBINE(X, Y) \
5011 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
5015 /* Return a hash for string PTR which has length LEN. The hash
5016 code returned is guaranteed to fit in a Lisp integer. */
5019 sxhash_string (ptr
, len
)
5023 unsigned char *p
= ptr
;
5024 unsigned char *end
= p
+ len
;
5033 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
5036 return hash
& INTMASK
;
5040 /* Return a hash for list LIST. DEPTH is the current depth in the
5041 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
5044 sxhash_list (list
, depth
)
5051 if (depth
< SXHASH_MAX_DEPTH
)
5053 CONSP (list
) && i
< SXHASH_MAX_LEN
;
5054 list
= XCDR (list
), ++i
)
5056 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
5057 hash
= SXHASH_COMBINE (hash
, hash2
);
5062 unsigned hash2
= sxhash (list
, depth
+ 1);
5063 hash
= SXHASH_COMBINE (hash
, hash2
);
5070 /* Return a hash for vector VECTOR. DEPTH is the current depth in
5071 the Lisp structure. */
5074 sxhash_vector (vec
, depth
)
5078 unsigned hash
= XVECTOR (vec
)->size
;
5081 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5082 for (i
= 0; i
< n
; ++i
)
5084 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5085 hash
= SXHASH_COMBINE (hash
, hash2
);
5092 /* Return a hash for bool-vector VECTOR. */
5095 sxhash_bool_vector (vec
)
5098 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5101 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5102 for (i
= 0; i
< n
; ++i
)
5103 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5109 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5110 structure. Value is an unsigned integer clipped to INTMASK. */
5119 if (depth
> SXHASH_MAX_DEPTH
)
5122 switch (XTYPE (obj
))
5133 obj
= SYMBOL_NAME (obj
);
5137 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5140 /* This can be everything from a vector to an overlay. */
5141 case Lisp_Vectorlike
:
5143 /* According to the CL HyperSpec, two arrays are equal only if
5144 they are `eq', except for strings and bit-vectors. In
5145 Emacs, this works differently. We have to compare element
5147 hash
= sxhash_vector (obj
, depth
);
5148 else if (BOOL_VECTOR_P (obj
))
5149 hash
= sxhash_bool_vector (obj
);
5151 /* Others are `equal' if they are `eq', so let's take their
5157 hash
= sxhash_list (obj
, depth
);
5162 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5163 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5164 for (hash
= 0; p
< e
; ++p
)
5165 hash
= SXHASH_COMBINE (hash
, *p
);
5173 return hash
& INTMASK
;
5178 /***********************************************************************
5180 ***********************************************************************/
5183 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5184 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5188 unsigned hash
= sxhash (obj
, 0);;
5189 return make_number (hash
);
5193 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5194 doc
: /* Create and return a new hash table.
5196 Arguments are specified as keyword/argument pairs. The following
5197 arguments are defined:
5199 :test TEST -- TEST must be a symbol that specifies how to compare
5200 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5201 `equal'. User-supplied test and hash functions can be specified via
5202 `define-hash-table-test'.
5204 :size SIZE -- A hint as to how many elements will be put in the table.
5207 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5208 fills up. If REHASH-SIZE is an integer, add that many space. If it
5209 is a float, it must be > 1.0, and the new size is computed by
5210 multiplying the old size with that factor. Default is 1.5.
5212 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5213 Resize the hash table when ratio of the number of entries in the
5214 table. Default is 0.8.
5216 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5217 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5218 returned is a weak table. Key/value pairs are removed from a weak
5219 hash table when there are no non-weak references pointing to their
5220 key, value, one of key or value, or both key and value, depending on
5221 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5224 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5229 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5230 Lisp_Object user_test
, user_hash
;
5234 /* The vector `used' is used to keep track of arguments that
5235 have been consumed. */
5236 used
= (char *) alloca (nargs
* sizeof *used
);
5237 bzero (used
, nargs
* sizeof *used
);
5239 /* See if there's a `:test TEST' among the arguments. */
5240 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5241 test
= i
< 0 ? Qeql
: args
[i
];
5242 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5244 /* See if it is a user-defined test. */
5247 prop
= Fget (test
, Qhash_table_test
);
5248 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5249 signal_error ("Invalid hash table test", test
);
5250 user_test
= XCAR (prop
);
5251 user_hash
= XCAR (XCDR (prop
));
5254 user_test
= user_hash
= Qnil
;
5256 /* See if there's a `:size SIZE' argument. */
5257 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5258 size
= i
< 0 ? Qnil
: args
[i
];
5260 size
= make_number (DEFAULT_HASH_SIZE
);
5261 else if (!INTEGERP (size
) || XINT (size
) < 0)
5262 signal_error ("Invalid hash table size", size
);
5264 /* Look for `:rehash-size SIZE'. */
5265 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5266 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5267 if (!NUMBERP (rehash_size
)
5268 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5269 || XFLOATINT (rehash_size
) <= 1.0)
5270 signal_error ("Invalid hash table rehash size", rehash_size
);
5272 /* Look for `:rehash-threshold THRESHOLD'. */
5273 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5274 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5275 if (!FLOATP (rehash_threshold
)
5276 || XFLOATINT (rehash_threshold
) <= 0.0
5277 || XFLOATINT (rehash_threshold
) > 1.0)
5278 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
5280 /* Look for `:weakness WEAK'. */
5281 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5282 weak
= i
< 0 ? Qnil
: args
[i
];
5284 weak
= Qkey_and_value
;
5287 && !EQ (weak
, Qvalue
)
5288 && !EQ (weak
, Qkey_or_value
)
5289 && !EQ (weak
, Qkey_and_value
))
5290 signal_error ("Invalid hash table weakness", weak
);
5292 /* Now, all args should have been used up, or there's a problem. */
5293 for (i
= 0; i
< nargs
; ++i
)
5295 signal_error ("Invalid argument list", args
[i
]);
5297 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5298 user_test
, user_hash
);
5302 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5303 doc
: /* Return a copy of hash table TABLE. */)
5307 return copy_hash_table (check_hash_table (table
));
5311 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5312 doc
: /* Return the number of elements in TABLE. */)
5316 return check_hash_table (table
)->count
;
5320 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5321 Shash_table_rehash_size
, 1, 1, 0,
5322 doc
: /* Return the current rehash size of TABLE. */)
5326 return check_hash_table (table
)->rehash_size
;
5330 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5331 Shash_table_rehash_threshold
, 1, 1, 0,
5332 doc
: /* Return the current rehash threshold of TABLE. */)
5336 return check_hash_table (table
)->rehash_threshold
;
5340 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5341 doc
: /* Return the size of TABLE.
5342 The size can be used as an argument to `make-hash-table' to create
5343 a hash table than can hold as many elements of TABLE holds
5344 without need for resizing. */)
5348 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5349 return make_number (HASH_TABLE_SIZE (h
));
5353 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5354 doc
: /* Return the test TABLE uses. */)
5358 return check_hash_table (table
)->test
;
5362 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5364 doc
: /* Return the weakness of TABLE. */)
5368 return check_hash_table (table
)->weak
;
5372 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5373 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5377 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5381 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5382 doc
: /* Clear hash table TABLE. */)
5386 hash_clear (check_hash_table (table
));
5391 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5392 doc
: /* Look up KEY in TABLE and return its associated value.
5393 If KEY is not found, return DFLT which defaults to nil. */)
5395 Lisp_Object key
, table
, dflt
;
5397 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5398 int i
= hash_lookup (h
, key
, NULL
);
5399 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5403 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5404 doc
: /* Associate KEY with VALUE in hash table TABLE.
5405 If KEY is already present in table, replace its current value with
5408 Lisp_Object key
, value
, table
;
5410 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5414 i
= hash_lookup (h
, key
, &hash
);
5416 HASH_VALUE (h
, i
) = value
;
5418 hash_put (h
, key
, value
, hash
);
5424 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5425 doc
: /* Remove KEY from TABLE. */)
5427 Lisp_Object key
, table
;
5429 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5430 hash_remove (h
, key
);
5435 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5436 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5437 FUNCTION is called with two arguments, KEY and VALUE. */)
5439 Lisp_Object function
, table
;
5441 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5442 Lisp_Object args
[3];
5445 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5446 if (!NILP (HASH_HASH (h
, i
)))
5449 args
[1] = HASH_KEY (h
, i
);
5450 args
[2] = HASH_VALUE (h
, i
);
5458 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5459 Sdefine_hash_table_test
, 3, 3, 0,
5460 doc
: /* Define a new hash table test with name NAME, a symbol.
5462 In hash tables created with NAME specified as test, use TEST to
5463 compare keys, and HASH for computing hash codes of keys.
5465 TEST must be a function taking two arguments and returning non-nil if
5466 both arguments are the same. HASH must be a function taking one
5467 argument and return an integer that is the hash code of the argument.
5468 Hash code computation should use the whole value range of integers,
5469 including negative integers. */)
5471 Lisp_Object name
, test
, hash
;
5473 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5478 /************************************************************************
5480 ************************************************************************/
5485 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5486 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5488 A message digest is a cryptographic checksum of a document, and the
5489 algorithm to calculate it is defined in RFC 1321.
5491 The two optional arguments START and END are character positions
5492 specifying for which part of OBJECT the message digest should be
5493 computed. If nil or omitted, the digest is computed for the whole
5496 The MD5 message digest is computed from the result of encoding the
5497 text in a coding system, not directly from the internal Emacs form of
5498 the text. The optional fourth argument CODING-SYSTEM specifies which
5499 coding system to encode the text with. It should be the same coding
5500 system that you used or will use when actually writing the text into a
5503 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5504 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5505 system would be chosen by default for writing this text into a file.
5507 If OBJECT is a string, the most preferred coding system (see the
5508 command `prefer-coding-system') is used.
5510 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5511 guesswork fails. Normally, an error is signaled in such case. */)
5512 (object
, start
, end
, coding_system
, noerror
)
5513 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5515 unsigned char digest
[16];
5516 unsigned char value
[33];
5520 int start_char
= 0, end_char
= 0;
5521 int start_byte
= 0, end_byte
= 0;
5523 register struct buffer
*bp
;
5526 if (STRINGP (object
))
5528 if (NILP (coding_system
))
5530 /* Decide the coding-system to encode the data with. */
5532 if (STRING_MULTIBYTE (object
))
5533 /* use default, we can't guess correct value */
5534 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5536 coding_system
= Qraw_text
;
5539 if (NILP (Fcoding_system_p (coding_system
)))
5541 /* Invalid coding system. */
5543 if (!NILP (noerror
))
5544 coding_system
= Qraw_text
;
5546 xsignal1 (Qcoding_system_error
, coding_system
);
5549 if (STRING_MULTIBYTE (object
))
5550 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5552 size
= SCHARS (object
);
5553 size_byte
= SBYTES (object
);
5557 CHECK_NUMBER (start
);
5559 start_char
= XINT (start
);
5564 start_byte
= string_char_to_byte (object
, start_char
);
5570 end_byte
= size_byte
;
5576 end_char
= XINT (end
);
5581 end_byte
= string_char_to_byte (object
, end_char
);
5584 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5585 args_out_of_range_3 (object
, make_number (start_char
),
5586 make_number (end_char
));
5590 struct buffer
*prev
= current_buffer
;
5592 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5594 CHECK_BUFFER (object
);
5596 bp
= XBUFFER (object
);
5597 if (bp
!= current_buffer
)
5598 set_buffer_internal (bp
);
5604 CHECK_NUMBER_COERCE_MARKER (start
);
5612 CHECK_NUMBER_COERCE_MARKER (end
);
5617 temp
= b
, b
= e
, e
= temp
;
5619 if (!(BEGV
<= b
&& e
<= ZV
))
5620 args_out_of_range (start
, end
);
5622 if (NILP (coding_system
))
5624 /* Decide the coding-system to encode the data with.
5625 See fileio.c:Fwrite-region */
5627 if (!NILP (Vcoding_system_for_write
))
5628 coding_system
= Vcoding_system_for_write
;
5631 int force_raw_text
= 0;
5633 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5634 if (NILP (coding_system
)
5635 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5637 coding_system
= Qnil
;
5638 if (NILP (current_buffer
->enable_multibyte_characters
))
5642 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5644 /* Check file-coding-system-alist. */
5645 Lisp_Object args
[4], val
;
5647 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5648 args
[3] = Fbuffer_file_name(object
);
5649 val
= Ffind_operation_coding_system (4, args
);
5650 if (CONSP (val
) && !NILP (XCDR (val
)))
5651 coding_system
= XCDR (val
);
5654 if (NILP (coding_system
)
5655 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5657 /* If we still have not decided a coding system, use the
5658 default value of buffer-file-coding-system. */
5659 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5663 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5664 /* Confirm that VAL can surely encode the current region. */
5665 coding_system
= call4 (Vselect_safe_coding_system_function
,
5666 make_number (b
), make_number (e
),
5667 coding_system
, Qnil
);
5670 coding_system
= Qraw_text
;
5673 if (NILP (Fcoding_system_p (coding_system
)))
5675 /* Invalid coding system. */
5677 if (!NILP (noerror
))
5678 coding_system
= Qraw_text
;
5680 xsignal1 (Qcoding_system_error
, coding_system
);
5684 object
= make_buffer_string (b
, e
, 0);
5685 if (prev
!= current_buffer
)
5686 set_buffer_internal (prev
);
5687 /* Discard the unwind protect for recovering the current
5691 if (STRING_MULTIBYTE (object
))
5692 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5695 md5_buffer (SDATA (object
) + start_byte
,
5696 SBYTES (object
) - (size_byte
- end_byte
),
5699 for (i
= 0; i
< 16; i
++)
5700 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5703 return make_string (value
, 32);
5710 /* Hash table stuff. */
5711 Qhash_table_p
= intern ("hash-table-p");
5712 staticpro (&Qhash_table_p
);
5713 Qeq
= intern ("eq");
5715 Qeql
= intern ("eql");
5717 Qequal
= intern ("equal");
5718 staticpro (&Qequal
);
5719 QCtest
= intern (":test");
5720 staticpro (&QCtest
);
5721 QCsize
= intern (":size");
5722 staticpro (&QCsize
);
5723 QCrehash_size
= intern (":rehash-size");
5724 staticpro (&QCrehash_size
);
5725 QCrehash_threshold
= intern (":rehash-threshold");
5726 staticpro (&QCrehash_threshold
);
5727 QCweakness
= intern (":weakness");
5728 staticpro (&QCweakness
);
5729 Qkey
= intern ("key");
5731 Qvalue
= intern ("value");
5732 staticpro (&Qvalue
);
5733 Qhash_table_test
= intern ("hash-table-test");
5734 staticpro (&Qhash_table_test
);
5735 Qkey_or_value
= intern ("key-or-value");
5736 staticpro (&Qkey_or_value
);
5737 Qkey_and_value
= intern ("key-and-value");
5738 staticpro (&Qkey_and_value
);
5741 defsubr (&Smake_hash_table
);
5742 defsubr (&Scopy_hash_table
);
5743 defsubr (&Shash_table_count
);
5744 defsubr (&Shash_table_rehash_size
);
5745 defsubr (&Shash_table_rehash_threshold
);
5746 defsubr (&Shash_table_size
);
5747 defsubr (&Shash_table_test
);
5748 defsubr (&Shash_table_weakness
);
5749 defsubr (&Shash_table_p
);
5750 defsubr (&Sclrhash
);
5751 defsubr (&Sgethash
);
5752 defsubr (&Sputhash
);
5753 defsubr (&Sremhash
);
5754 defsubr (&Smaphash
);
5755 defsubr (&Sdefine_hash_table_test
);
5757 Qstring_lessp
= intern ("string-lessp");
5758 staticpro (&Qstring_lessp
);
5759 Qprovide
= intern ("provide");
5760 staticpro (&Qprovide
);
5761 Qrequire
= intern ("require");
5762 staticpro (&Qrequire
);
5763 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5764 staticpro (&Qyes_or_no_p_history
);
5765 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5766 staticpro (&Qcursor_in_echo_area
);
5767 Qwidget_type
= intern ("widget-type");
5768 staticpro (&Qwidget_type
);
5770 staticpro (&string_char_byte_cache_string
);
5771 string_char_byte_cache_string
= Qnil
;
5773 require_nesting_list
= Qnil
;
5774 staticpro (&require_nesting_list
);
5776 Fset (Qyes_or_no_p_history
, Qnil
);
5778 DEFVAR_LISP ("features", &Vfeatures
,
5779 doc
: /* A list of symbols which are the features of the executing emacs.
5780 Used by `featurep' and `require', and altered by `provide'. */);
5781 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5782 Qsubfeatures
= intern ("subfeatures");
5783 staticpro (&Qsubfeatures
);
5785 #ifdef HAVE_LANGINFO_CODESET
5786 Qcodeset
= intern ("codeset");
5787 staticpro (&Qcodeset
);
5788 Qdays
= intern ("days");
5790 Qmonths
= intern ("months");
5791 staticpro (&Qmonths
);
5792 Qpaper
= intern ("paper");
5793 staticpro (&Qpaper
);
5794 #endif /* HAVE_LANGINFO_CODESET */
5796 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5797 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5798 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5799 invoked by mouse clicks and mouse menu items. */);
5802 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5803 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5804 This applies to commands from menus and tool bar buttons. The value of
5805 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5806 used if both `use-dialog-box' and this variable are non-nil. */);
5807 use_file_dialog
= 1;
5809 defsubr (&Sidentity
);
5812 defsubr (&Ssafe_length
);
5813 defsubr (&Sstring_bytes
);
5814 defsubr (&Sstring_equal
);
5815 defsubr (&Scompare_strings
);
5816 defsubr (&Sstring_lessp
);
5819 defsubr (&Svconcat
);
5820 defsubr (&Scopy_sequence
);
5821 defsubr (&Sstring_make_multibyte
);
5822 defsubr (&Sstring_make_unibyte
);
5823 defsubr (&Sstring_as_multibyte
);
5824 defsubr (&Sstring_as_unibyte
);
5825 defsubr (&Sstring_to_multibyte
);
5826 defsubr (&Scopy_alist
);
5827 defsubr (&Ssubstring
);
5828 defsubr (&Ssubstring_no_properties
);
5840 defsubr (&Snreverse
);
5841 defsubr (&Sreverse
);
5843 defsubr (&Splist_get
);
5845 defsubr (&Splist_put
);
5847 defsubr (&Slax_plist_get
);
5848 defsubr (&Slax_plist_put
);
5851 defsubr (&Sequal_including_properties
);
5852 defsubr (&Sfillarray
);
5853 defsubr (&Sclear_string
);
5854 defsubr (&Schar_table_subtype
);
5855 defsubr (&Schar_table_parent
);
5856 defsubr (&Sset_char_table_parent
);
5857 defsubr (&Schar_table_extra_slot
);
5858 defsubr (&Sset_char_table_extra_slot
);
5859 defsubr (&Schar_table_range
);
5860 defsubr (&Sset_char_table_range
);
5861 defsubr (&Sset_char_table_default
);
5862 defsubr (&Soptimize_char_table
);
5863 defsubr (&Smap_char_table
);
5867 defsubr (&Smapconcat
);
5868 defsubr (&Sy_or_n_p
);
5869 defsubr (&Syes_or_no_p
);
5870 defsubr (&Sload_average
);
5871 defsubr (&Sfeaturep
);
5872 defsubr (&Srequire
);
5873 defsubr (&Sprovide
);
5874 defsubr (&Splist_member
);
5875 defsubr (&Swidget_put
);
5876 defsubr (&Swidget_get
);
5877 defsubr (&Swidget_apply
);
5878 defsubr (&Sbase64_encode_region
);
5879 defsubr (&Sbase64_decode_region
);
5880 defsubr (&Sbase64_encode_string
);
5881 defsubr (&Sbase64_decode_string
);
5883 defsubr (&Slocale_info
);
5890 Vweak_hash_tables
= Qnil
;
5893 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5894 (do not change this comment) */