1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* On Mac OS, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 /* Nonzero enables use of a file dialog for file name
63 questions asked by mouse commands. */
66 extern int minibuffer_auto_raise
;
67 extern Lisp_Object minibuf_window
;
68 extern Lisp_Object Vlocale_coding_system
;
69 extern Lisp_Object Vloads_in_progress
;
71 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
72 Lisp_Object Qyes_or_no_p_history
;
73 Lisp_Object Qcursor_in_echo_area
;
74 Lisp_Object Qwidget_type
;
75 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
77 extern Lisp_Object Qinput_method_function
;
79 static int internal_equal ();
81 extern long get_random ();
82 extern void seed_random ();
88 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
89 doc
: /* Return the argument unchanged. */)
96 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
97 doc
: /* Return a pseudo-random number.
98 All integers representable in Lisp are equally likely.
99 On most systems, this is 29 bits' worth.
100 With positive integer argument N, return random number in interval [0,N).
101 With argument t, set the random number seed from the current time and pid. */)
106 Lisp_Object lispy_val
;
107 unsigned long denominator
;
110 seed_random (getpid () + time (NULL
));
111 if (NATNUMP (n
) && XFASTINT (n
) != 0)
113 /* Try to take our random number from the higher bits of VAL,
114 not the lower, since (says Gentzel) the low bits of `random'
115 are less random than the higher ones. We do this by using the
116 quotient rather than the remainder. At the high end of the RNG
117 it's possible to get a quotient larger than n; discarding
118 these values eliminates the bias that would otherwise appear
119 when using a large n. */
120 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
122 val
= get_random () / denominator
;
123 while (val
>= XFASTINT (n
));
127 XSETINT (lispy_val
, val
);
131 /* Random data-structure functions */
133 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
134 doc
: /* Return the length of vector, list or string SEQUENCE.
135 A byte-code function object is also allowed.
136 If the string contains multibyte characters, this is not necessarily
137 the number of bytes in the string; it is the number of characters.
138 To get the number of bytes, use `string-bytes'. */)
140 register Lisp_Object sequence
;
142 register Lisp_Object val
;
146 if (STRINGP (sequence
))
147 XSETFASTINT (val
, SCHARS (sequence
));
148 else if (VECTORP (sequence
))
149 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
150 else if (SUB_CHAR_TABLE_P (sequence
))
151 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
152 else if (CHAR_TABLE_P (sequence
))
153 XSETFASTINT (val
, MAX_CHAR
);
154 else if (BOOL_VECTOR_P (sequence
))
155 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
156 else if (COMPILEDP (sequence
))
157 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
158 else if (CONSP (sequence
))
161 while (CONSP (sequence
))
163 sequence
= XCDR (sequence
);
166 if (!CONSP (sequence
))
169 sequence
= XCDR (sequence
);
174 if (!NILP (sequence
))
175 wrong_type_argument (Qlistp
, sequence
);
177 val
= make_number (i
);
179 else if (NILP (sequence
))
180 XSETFASTINT (val
, 0);
183 sequence
= wrong_type_argument (Qsequencep
, sequence
);
189 /* This does not check for quits. That is safe
190 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 (XCHAR_TABLE (arg
)->defalt
);
469 /* Copy all the contents. */
470 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
471 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
472 /* Recursively copy any sub char-tables in the ordinary slots. */
473 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
474 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
475 XCHAR_TABLE (copy
)->contents
[i
]
476 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
482 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
483 doc
: /* Return a copy of a list, vector, string or char-table.
484 The elements of a list or vector are not copied; they are shared
485 with the original. */)
489 if (NILP (arg
)) return arg
;
491 if (CHAR_TABLE_P (arg
))
496 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
497 /* Copy all the slots, including the extra ones. */
498 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
499 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
500 * sizeof (Lisp_Object
)));
502 /* Recursively copy any sub char tables in the ordinary slots
503 for multibyte characters. */
504 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
505 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
506 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
507 XCHAR_TABLE (copy
)->contents
[i
]
508 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
513 if (BOOL_VECTOR_P (arg
))
517 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
518 / BOOL_VECTOR_BITS_PER_CHAR
);
520 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
521 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
526 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
527 arg
= wrong_type_argument (Qsequencep
, arg
);
528 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
531 /* This structure holds information of an argument of `concat' that is
532 a string and has text properties to be copied. */
535 int argnum
; /* refer to ARGS (arguments of `concat') */
536 int from
; /* refer to ARGS[argnum] (argument string) */
537 int to
; /* refer to VAL (the target string) */
541 concat (nargs
, args
, target_type
, last_special
)
544 enum Lisp_Type target_type
;
548 register Lisp_Object tail
;
549 register Lisp_Object
this;
551 int toindex_byte
= 0;
552 register int result_len
;
553 register int result_len_byte
;
555 Lisp_Object last_tail
;
558 /* When we make a multibyte string, we can't copy text properties
559 while concatinating each string because the length of resulting
560 string can't be decided until we finish the whole concatination.
561 So, we record strings that have text properties to be copied
562 here, and copy the text properties after the concatination. */
563 struct textprop_rec
*textprops
= NULL
;
564 /* Number of elments in textprops. */
565 int num_textprops
= 0;
570 /* In append, the last arg isn't treated like the others */
571 if (last_special
&& nargs
> 0)
574 last_tail
= args
[nargs
];
579 /* Canonicalize each argument. */
580 for (argnum
= 0; argnum
< nargs
; argnum
++)
583 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
584 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
586 args
[argnum
] = 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 wrong_type_argument (Qintegerp
, ch
);
616 this_len_byte
= CHAR_BYTES (XINT (ch
));
617 result_len_byte
+= this_len_byte
;
618 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
621 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
622 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
623 else if (CONSP (this))
624 for (; CONSP (this); this = XCDR (this))
628 wrong_type_argument (Qintegerp
, ch
);
629 this_len_byte
= CHAR_BYTES (XINT (ch
));
630 result_len_byte
+= this_len_byte
;
631 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
634 else if (STRINGP (this))
636 if (STRING_MULTIBYTE (this))
639 result_len_byte
+= SBYTES (this);
642 result_len_byte
+= count_size_as_multibyte (SDATA (this),
650 if (! some_multibyte
)
651 result_len_byte
= result_len
;
653 /* Create the output object. */
654 if (target_type
== Lisp_Cons
)
655 val
= Fmake_list (make_number (result_len
), Qnil
);
656 else if (target_type
== Lisp_Vectorlike
)
657 val
= Fmake_vector (make_number (result_len
), Qnil
);
658 else if (some_multibyte
)
659 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
661 val
= make_uninit_string (result_len
);
663 /* In `append', if all but last arg are nil, return last arg. */
664 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
667 /* Copy the contents of the args into the result. */
669 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
671 toindex
= 0, toindex_byte
= 0;
675 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
677 for (argnum
= 0; argnum
< nargs
; argnum
++)
681 register unsigned int thisindex
= 0;
682 register unsigned int thisindex_byte
= 0;
686 thislen
= Flength (this), thisleni
= XINT (thislen
);
688 /* Between strings of the same kind, copy fast. */
689 if (STRINGP (this) && STRINGP (val
)
690 && STRING_MULTIBYTE (this) == some_multibyte
)
692 int thislen_byte
= SBYTES (this);
694 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
696 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
698 textprops
[num_textprops
].argnum
= argnum
;
699 textprops
[num_textprops
].from
= 0;
700 textprops
[num_textprops
++].to
= toindex
;
702 toindex_byte
+= thislen_byte
;
704 STRING_SET_CHARS (val
, SCHARS (val
));
706 /* Copy a single-byte string to a multibyte string. */
707 else if (STRINGP (this) && STRINGP (val
))
709 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
711 textprops
[num_textprops
].argnum
= argnum
;
712 textprops
[num_textprops
].from
= 0;
713 textprops
[num_textprops
++].to
= toindex
;
715 toindex_byte
+= copy_text (SDATA (this),
716 SDATA (val
) + toindex_byte
,
717 SCHARS (this), 0, 1);
721 /* Copy element by element. */
724 register Lisp_Object elt
;
726 /* Fetch next element of `this' arg into `elt', or break if
727 `this' is exhausted. */
728 if (NILP (this)) break;
730 elt
= XCAR (this), this = XCDR (this);
731 else if (thisindex
>= thisleni
)
733 else if (STRINGP (this))
736 if (STRING_MULTIBYTE (this))
738 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
741 XSETFASTINT (elt
, c
);
745 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
747 && (XINT (elt
) >= 0240
748 || (XINT (elt
) >= 0200
749 && ! NILP (Vnonascii_translation_table
)))
750 && XINT (elt
) < 0400)
752 c
= unibyte_char_to_multibyte (XINT (elt
));
757 else if (BOOL_VECTOR_P (this))
760 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
761 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
768 elt
= XVECTOR (this)->contents
[thisindex
++];
770 /* Store this element into the result. */
777 else if (VECTORP (val
))
778 XVECTOR (val
)->contents
[toindex
++] = elt
;
782 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
786 += CHAR_STRING (XINT (elt
),
787 SDATA (val
) + toindex_byte
);
789 SSET (val
, toindex_byte
++, XINT (elt
));
793 /* If we have any multibyte characters,
794 we already decided to make a multibyte string. */
797 /* P exists as a variable
798 to avoid a bug on the Masscomp C compiler. */
799 unsigned char *p
= SDATA (val
) + toindex_byte
;
801 toindex_byte
+= CHAR_STRING (c
, p
);
808 XSETCDR (prev
, last_tail
);
810 if (num_textprops
> 0)
813 int last_to_end
= -1;
815 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
817 this = args
[textprops
[argnum
].argnum
];
818 props
= text_property_list (this,
820 make_number (SCHARS (this)),
822 /* If successive arguments have properites, be sure that the
823 value of `composition' property be the copy. */
824 if (last_to_end
== textprops
[argnum
].to
)
825 make_composition_value_copy (props
);
826 add_text_properties_from_list (val
, props
,
827 make_number (textprops
[argnum
].to
));
828 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
836 static Lisp_Object string_char_byte_cache_string
;
837 static int string_char_byte_cache_charpos
;
838 static int string_char_byte_cache_bytepos
;
841 clear_string_char_byte_cache ()
843 string_char_byte_cache_string
= Qnil
;
846 /* Return the character index corresponding to CHAR_INDEX in STRING. */
849 string_char_to_byte (string
, char_index
)
854 int best_below
, best_below_byte
;
855 int best_above
, best_above_byte
;
857 best_below
= best_below_byte
= 0;
858 best_above
= SCHARS (string
);
859 best_above_byte
= SBYTES (string
);
860 if (best_above
== best_above_byte
)
863 if (EQ (string
, string_char_byte_cache_string
))
865 if (string_char_byte_cache_charpos
< char_index
)
867 best_below
= string_char_byte_cache_charpos
;
868 best_below_byte
= string_char_byte_cache_bytepos
;
872 best_above
= string_char_byte_cache_charpos
;
873 best_above_byte
= string_char_byte_cache_bytepos
;
877 if (char_index
- best_below
< best_above
- char_index
)
879 while (best_below
< char_index
)
882 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
883 best_below
, best_below_byte
);
886 i_byte
= best_below_byte
;
890 while (best_above
> char_index
)
892 unsigned char *pend
= SDATA (string
) + best_above_byte
;
893 unsigned char *pbeg
= pend
- best_above_byte
;
894 unsigned char *p
= pend
- 1;
897 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
898 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
899 if (bytes
== pend
- p
)
900 best_above_byte
-= bytes
;
901 else if (bytes
> pend
- p
)
902 best_above_byte
-= (pend
- p
);
908 i_byte
= best_above_byte
;
911 string_char_byte_cache_bytepos
= i_byte
;
912 string_char_byte_cache_charpos
= i
;
913 string_char_byte_cache_string
= string
;
918 /* Return the character index corresponding to BYTE_INDEX in STRING. */
921 string_byte_to_char (string
, byte_index
)
926 int best_below
, best_below_byte
;
927 int best_above
, best_above_byte
;
929 best_below
= best_below_byte
= 0;
930 best_above
= SCHARS (string
);
931 best_above_byte
= SBYTES (string
);
932 if (best_above
== best_above_byte
)
935 if (EQ (string
, string_char_byte_cache_string
))
937 if (string_char_byte_cache_bytepos
< byte_index
)
939 best_below
= string_char_byte_cache_charpos
;
940 best_below_byte
= string_char_byte_cache_bytepos
;
944 best_above
= string_char_byte_cache_charpos
;
945 best_above_byte
= string_char_byte_cache_bytepos
;
949 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
951 while (best_below_byte
< byte_index
)
954 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
955 best_below
, best_below_byte
);
958 i_byte
= best_below_byte
;
962 while (best_above_byte
> byte_index
)
964 unsigned char *pend
= SDATA (string
) + best_above_byte
;
965 unsigned char *pbeg
= pend
- best_above_byte
;
966 unsigned char *p
= pend
- 1;
969 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
970 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
971 if (bytes
== pend
- p
)
972 best_above_byte
-= bytes
;
973 else if (bytes
> pend
- p
)
974 best_above_byte
-= (pend
- p
);
980 i_byte
= best_above_byte
;
983 string_char_byte_cache_bytepos
= i_byte
;
984 string_char_byte_cache_charpos
= i
;
985 string_char_byte_cache_string
= string
;
990 /* Convert STRING to a multibyte string.
991 Single-byte characters 0240 through 0377 are converted
992 by adding nonascii_insert_offset to each. */
995 string_make_multibyte (string
)
1003 if (STRING_MULTIBYTE (string
))
1006 nbytes
= count_size_as_multibyte (SDATA (string
),
1008 /* If all the chars are ASCII, they won't need any more bytes
1009 once converted. In that case, we can return STRING itself. */
1010 if (nbytes
== SBYTES (string
))
1013 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1014 copy_text (SDATA (string
), buf
, SBYTES (string
),
1017 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1024 /* Convert STRING to a multibyte string without changing each
1025 character codes. Thus, characters 0200 trough 0237 are converted
1026 to eight-bit-control characters, and characters 0240 through 0377
1027 are converted eight-bit-graphic characters. */
1030 string_to_multibyte (string
)
1038 if (STRING_MULTIBYTE (string
))
1041 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1042 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1043 any more bytes once converted. */
1044 if (nbytes
== SBYTES (string
))
1045 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1047 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1048 bcopy (SDATA (string
), buf
, SBYTES (string
));
1049 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1051 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1058 /* Convert STRING to a single-byte string. */
1061 string_make_unibyte (string
)
1069 if (! STRING_MULTIBYTE (string
))
1072 nchars
= SCHARS (string
);
1074 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1075 copy_text (SDATA (string
), buf
, SBYTES (string
),
1078 ret
= make_unibyte_string (buf
, nchars
);
1084 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1086 doc
: /* Return the multibyte equivalent of STRING.
1087 If STRING is unibyte and contains non-ASCII characters, the function
1088 `unibyte-char-to-multibyte' is used to convert each unibyte character
1089 to a multibyte character. In this case, the returned string is a
1090 newly created string with no text properties. If STRING is multibyte
1091 or entirely ASCII, it is returned unchanged. In particular, when
1092 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1093 \(When the characters are all ASCII, Emacs primitives will treat the
1094 string the same way whether it is unibyte or multibyte.) */)
1098 CHECK_STRING (string
);
1100 return string_make_multibyte (string
);
1103 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1105 doc
: /* Return the unibyte equivalent of STRING.
1106 Multibyte character codes are converted to unibyte according to
1107 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1108 If the lookup in the translation table fails, this function takes just
1109 the low 8 bits of each character. */)
1113 CHECK_STRING (string
);
1115 return string_make_unibyte (string
);
1118 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1120 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1121 If STRING is unibyte, the result is STRING itself.
1122 Otherwise it is a newly created string, with no text properties.
1123 If STRING is multibyte and contains a character of charset
1124 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1125 corresponding single byte. */)
1129 CHECK_STRING (string
);
1131 if (STRING_MULTIBYTE (string
))
1133 int bytes
= SBYTES (string
);
1134 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1136 bcopy (SDATA (string
), str
, bytes
);
1137 bytes
= str_as_unibyte (str
, bytes
);
1138 string
= make_unibyte_string (str
, bytes
);
1144 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1146 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1147 If STRING is multibyte, the result is STRING itself.
1148 Otherwise it is a newly created string, with no text properties.
1149 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1150 part of a multibyte form), it is converted to the corresponding
1151 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.
1152 Beware, this often doesn't really do what you think it does.
1153 It is similar to (decode-coding-string STRING 'emacs-mule-unix).
1154 If you're not sure, whether to use `string-as-multibyte' or
1155 `string-to-multibyte', use `string-to-multibyte'. Beware:
1156 (aref (string-as-multibyte "\201") 0) -> 129 (aka ?\201)
1157 (aref (string-as-multibyte "\300") 0) -> 192 (aka ?\300)
1158 (aref (string-as-multibyte "\300\201") 0) -> 192 (aka ?\300)
1159 (aref (string-as-multibyte "\300\201") 1) -> 129 (aka ?\201)
1161 (aref (string-as-multibyte "\201\300") 0) -> 2240
1162 (aref (string-as-multibyte "\201\300") 1) -> <error> */)
1166 CHECK_STRING (string
);
1168 if (! STRING_MULTIBYTE (string
))
1170 Lisp_Object new_string
;
1173 parse_str_as_multibyte (SDATA (string
),
1176 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1177 bcopy (SDATA (string
), SDATA (new_string
),
1179 if (nbytes
!= SBYTES (string
))
1180 str_as_multibyte (SDATA (new_string
), nbytes
,
1181 SBYTES (string
), NULL
);
1182 string
= new_string
;
1183 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1188 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1190 doc
: /* Return a multibyte string with the same individual chars as STRING.
1191 If STRING is multibyte, the result is STRING itself.
1192 Otherwise it is a newly created string, with no text properties.
1193 Characters 0200 through 0237 are converted to eight-bit-control
1194 characters of the same character code. Characters 0240 through 0377
1195 are converted to eight-bit-graphic characters of the same character
1197 This is similar to (decode-coding-string STRING 'binary) */)
1201 CHECK_STRING (string
);
1203 return string_to_multibyte (string
);
1207 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1208 doc
: /* Return a copy of ALIST.
1209 This is an alist which represents the same mapping from objects to objects,
1210 but does not share the alist structure with ALIST.
1211 The objects mapped (cars and cdrs of elements of the alist)
1212 are shared, however.
1213 Elements of ALIST that are not conses are also shared. */)
1217 register Lisp_Object tem
;
1222 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1223 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1225 register Lisp_Object car
;
1229 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1234 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1235 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1236 TO may be nil or omitted; then the substring runs to the end of STRING.
1237 FROM and TO start at 0. If either is negative, it counts from the end.
1239 This function allows vectors as well as strings. */)
1242 register Lisp_Object from
, to
;
1247 int from_char
, to_char
;
1248 int from_byte
= 0, to_byte
= 0;
1250 if (! (STRINGP (string
) || VECTORP (string
)))
1251 wrong_type_argument (Qarrayp
, string
);
1253 CHECK_NUMBER (from
);
1255 if (STRINGP (string
))
1257 size
= SCHARS (string
);
1258 size_byte
= SBYTES (string
);
1261 size
= XVECTOR (string
)->size
;
1266 to_byte
= size_byte
;
1272 to_char
= XINT (to
);
1276 if (STRINGP (string
))
1277 to_byte
= string_char_to_byte (string
, to_char
);
1280 from_char
= XINT (from
);
1283 if (STRINGP (string
))
1284 from_byte
= string_char_to_byte (string
, from_char
);
1286 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1287 args_out_of_range_3 (string
, make_number (from_char
),
1288 make_number (to_char
));
1290 if (STRINGP (string
))
1292 res
= make_specified_string (SDATA (string
) + from_byte
,
1293 to_char
- from_char
, to_byte
- from_byte
,
1294 STRING_MULTIBYTE (string
));
1295 copy_text_properties (make_number (from_char
), make_number (to_char
),
1296 string
, make_number (0), res
, Qnil
);
1299 res
= Fvector (to_char
- from_char
,
1300 XVECTOR (string
)->contents
+ from_char
);
1306 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1307 doc
: /* Return a substring of STRING, without text properties.
1308 It starts at index FROM and ending before TO.
1309 TO may be nil or omitted; then the substring runs to the end of STRING.
1310 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1311 If FROM or TO is negative, it counts from the end.
1313 With one argument, just copy STRING without its properties. */)
1316 register Lisp_Object from
, to
;
1318 int size
, size_byte
;
1319 int from_char
, to_char
;
1320 int from_byte
, to_byte
;
1322 CHECK_STRING (string
);
1324 size
= SCHARS (string
);
1325 size_byte
= SBYTES (string
);
1328 from_char
= from_byte
= 0;
1331 CHECK_NUMBER (from
);
1332 from_char
= XINT (from
);
1336 from_byte
= string_char_to_byte (string
, from_char
);
1342 to_byte
= size_byte
;
1348 to_char
= XINT (to
);
1352 to_byte
= string_char_to_byte (string
, to_char
);
1355 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1356 args_out_of_range_3 (string
, make_number (from_char
),
1357 make_number (to_char
));
1359 return make_specified_string (SDATA (string
) + from_byte
,
1360 to_char
- from_char
, to_byte
- from_byte
,
1361 STRING_MULTIBYTE (string
));
1364 /* Extract a substring of STRING, giving start and end positions
1365 both in characters and in bytes. */
1368 substring_both (string
, from
, from_byte
, to
, to_byte
)
1370 int from
, from_byte
, to
, to_byte
;
1376 if (! (STRINGP (string
) || VECTORP (string
)))
1377 wrong_type_argument (Qarrayp
, string
);
1379 if (STRINGP (string
))
1381 size
= SCHARS (string
);
1382 size_byte
= SBYTES (string
);
1385 size
= XVECTOR (string
)->size
;
1387 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1388 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1390 if (STRINGP (string
))
1392 res
= make_specified_string (SDATA (string
) + from_byte
,
1393 to
- from
, to_byte
- from_byte
,
1394 STRING_MULTIBYTE (string
));
1395 copy_text_properties (make_number (from
), make_number (to
),
1396 string
, make_number (0), res
, Qnil
);
1399 res
= Fvector (to
- from
,
1400 XVECTOR (string
)->contents
+ from
);
1405 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1406 doc
: /* Take cdr N times on LIST, returns the result. */)
1409 register Lisp_Object list
;
1411 register int i
, num
;
1414 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1418 wrong_type_argument (Qlistp
, list
);
1424 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1425 doc
: /* Return the Nth element of LIST.
1426 N counts from zero. If LIST is not that long, nil is returned. */)
1428 Lisp_Object n
, list
;
1430 return Fcar (Fnthcdr (n
, list
));
1433 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1434 doc
: /* Return element of SEQUENCE at index N. */)
1436 register Lisp_Object sequence
, n
;
1441 if (CONSP (sequence
) || NILP (sequence
))
1442 return Fcar (Fnthcdr (n
, sequence
));
1443 else if (STRINGP (sequence
) || VECTORP (sequence
)
1444 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1445 return Faref (sequence
, n
);
1447 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1451 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1452 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1453 The value is actually the tail of LIST whose car is ELT. */)
1455 register Lisp_Object elt
;
1458 register Lisp_Object tail
;
1459 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1461 register Lisp_Object tem
;
1463 wrong_type_argument (Qlistp
, list
);
1465 if (! NILP (Fequal (elt
, tem
)))
1472 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1473 doc
: /* Return non-nil if ELT is an element of LIST.
1474 Comparison done with EQ. The value is actually the tail of LIST
1475 whose car is ELT. */)
1477 Lisp_Object elt
, list
;
1481 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1485 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1489 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1496 if (!CONSP (list
) && !NILP (list
))
1497 list
= wrong_type_argument (Qlistp
, list
);
1502 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1503 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1504 The value is actually the first element of LIST whose car is KEY.
1505 Elements of LIST that are not conses are ignored. */)
1507 Lisp_Object key
, list
;
1514 || (CONSP (XCAR (list
))
1515 && EQ (XCAR (XCAR (list
)), key
)))
1520 || (CONSP (XCAR (list
))
1521 && EQ (XCAR (XCAR (list
)), key
)))
1526 || (CONSP (XCAR (list
))
1527 && EQ (XCAR (XCAR (list
)), key
)))
1535 result
= XCAR (list
);
1536 else if (NILP (list
))
1539 result
= wrong_type_argument (Qlistp
, list
);
1544 /* Like Fassq but never report an error and do not allow quits.
1545 Use only on lists known never to be circular. */
1548 assq_no_quit (key
, list
)
1549 Lisp_Object key
, list
;
1552 && (!CONSP (XCAR (list
))
1553 || !EQ (XCAR (XCAR (list
)), key
)))
1556 return CONSP (list
) ? XCAR (list
) : Qnil
;
1559 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1560 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1561 The value is actually the first element of LIST whose car equals KEY. */)
1563 Lisp_Object key
, list
;
1565 Lisp_Object result
, car
;
1570 || (CONSP (XCAR (list
))
1571 && (car
= XCAR (XCAR (list
)),
1572 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1577 || (CONSP (XCAR (list
))
1578 && (car
= XCAR (XCAR (list
)),
1579 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1584 || (CONSP (XCAR (list
))
1585 && (car
= XCAR (XCAR (list
)),
1586 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1594 result
= XCAR (list
);
1595 else if (NILP (list
))
1598 result
= wrong_type_argument (Qlistp
, list
);
1603 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1604 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1605 The value is actually the first element of LIST whose cdr is KEY. */)
1607 register Lisp_Object key
;
1615 || (CONSP (XCAR (list
))
1616 && EQ (XCDR (XCAR (list
)), key
)))
1621 || (CONSP (XCAR (list
))
1622 && EQ (XCDR (XCAR (list
)), key
)))
1627 || (CONSP (XCAR (list
))
1628 && EQ (XCDR (XCAR (list
)), key
)))
1637 else if (CONSP (list
))
1638 result
= XCAR (list
);
1640 result
= wrong_type_argument (Qlistp
, list
);
1645 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1646 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1647 The value is actually the first element of LIST whose cdr equals KEY. */)
1649 Lisp_Object key
, list
;
1651 Lisp_Object result
, cdr
;
1656 || (CONSP (XCAR (list
))
1657 && (cdr
= XCDR (XCAR (list
)),
1658 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1663 || (CONSP (XCAR (list
))
1664 && (cdr
= XCDR (XCAR (list
)),
1665 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1670 || (CONSP (XCAR (list
))
1671 && (cdr
= XCDR (XCAR (list
)),
1672 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1680 result
= XCAR (list
);
1681 else if (NILP (list
))
1684 result
= wrong_type_argument (Qlistp
, list
);
1689 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1690 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1691 The modified LIST is returned. Comparison is done with `eq'.
1692 If the first member of LIST is ELT, there is no way to remove it by side effect;
1693 therefore, write `(setq foo (delq element foo))'
1694 to be sure of changing the value of `foo'. */)
1696 register Lisp_Object elt
;
1699 register Lisp_Object tail
, prev
;
1700 register Lisp_Object tem
;
1704 while (!NILP (tail
))
1707 wrong_type_argument (Qlistp
, list
);
1714 Fsetcdr (prev
, XCDR (tail
));
1724 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1725 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1726 SEQ must be a list, a vector, or a string.
1727 The modified SEQ is returned. Comparison is done with `equal'.
1728 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1729 is not a side effect; it is simply using a different sequence.
1730 Therefore, write `(setq foo (delete element foo))'
1731 to be sure of changing the value of `foo'. */)
1733 Lisp_Object elt
, seq
;
1739 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1740 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1743 if (n
!= ASIZE (seq
))
1745 struct Lisp_Vector
*p
= allocate_vector (n
);
1747 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1748 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1749 p
->contents
[n
++] = AREF (seq
, i
);
1751 XSETVECTOR (seq
, p
);
1754 else if (STRINGP (seq
))
1756 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1759 for (i
= nchars
= nbytes
= ibyte
= 0;
1761 ++i
, ibyte
+= cbytes
)
1763 if (STRING_MULTIBYTE (seq
))
1765 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1766 SBYTES (seq
) - ibyte
);
1767 cbytes
= CHAR_BYTES (c
);
1775 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1782 if (nchars
!= SCHARS (seq
))
1786 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1787 if (!STRING_MULTIBYTE (seq
))
1788 STRING_SET_UNIBYTE (tem
);
1790 for (i
= nchars
= nbytes
= ibyte
= 0;
1792 ++i
, ibyte
+= cbytes
)
1794 if (STRING_MULTIBYTE (seq
))
1796 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1797 SBYTES (seq
) - ibyte
);
1798 cbytes
= CHAR_BYTES (c
);
1806 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1808 unsigned char *from
= SDATA (seq
) + ibyte
;
1809 unsigned char *to
= SDATA (tem
) + nbytes
;
1815 for (n
= cbytes
; n
--; )
1825 Lisp_Object tail
, prev
;
1827 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1830 wrong_type_argument (Qlistp
, seq
);
1832 if (!NILP (Fequal (elt
, XCAR (tail
))))
1837 Fsetcdr (prev
, XCDR (tail
));
1848 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1849 doc
: /* Reverse LIST by modifying cdr pointers.
1850 Return the reversed list. */)
1854 register Lisp_Object prev
, tail
, next
;
1856 if (NILP (list
)) return list
;
1859 while (!NILP (tail
))
1863 wrong_type_argument (Qlistp
, list
);
1865 Fsetcdr (tail
, prev
);
1872 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1873 doc
: /* Reverse LIST, copying. Return the reversed list.
1874 See also the function `nreverse', which is used more often. */)
1880 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1883 new = Fcons (XCAR (list
), new);
1886 wrong_type_argument (Qconsp
, list
);
1890 Lisp_Object
merge ();
1892 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1893 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1894 Returns the sorted list. LIST is modified by side effects.
1895 PREDICATE is called with two elements of LIST, and should return t
1896 if the first element is "less" than the second. */)
1898 Lisp_Object list
, predicate
;
1900 Lisp_Object front
, back
;
1901 register Lisp_Object len
, tem
;
1902 struct gcpro gcpro1
, gcpro2
;
1903 register int length
;
1906 len
= Flength (list
);
1907 length
= XINT (len
);
1911 XSETINT (len
, (length
/ 2) - 1);
1912 tem
= Fnthcdr (len
, list
);
1914 Fsetcdr (tem
, Qnil
);
1916 GCPRO2 (front
, back
);
1917 front
= Fsort (front
, predicate
);
1918 back
= Fsort (back
, predicate
);
1920 return merge (front
, back
, predicate
);
1924 merge (org_l1
, org_l2
, pred
)
1925 Lisp_Object org_l1
, org_l2
;
1929 register Lisp_Object tail
;
1931 register Lisp_Object l1
, l2
;
1932 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1939 /* It is sufficient to protect org_l1 and org_l2.
1940 When l1 and l2 are updated, we copy the new values
1941 back into the org_ vars. */
1942 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1962 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1978 Fsetcdr (tail
, tem
);
1984 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1985 doc
: /* Extract a value from a property list.
1986 PLIST is a property list, which is a list of the form
1987 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1988 corresponding to the given PROP, or nil if PROP is not
1989 one of the properties on the list. */)
1997 CONSP (tail
) && CONSP (XCDR (tail
));
1998 tail
= XCDR (XCDR (tail
)))
2000 if (EQ (prop
, XCAR (tail
)))
2001 return XCAR (XCDR (tail
));
2003 /* This function can be called asynchronously
2004 (setup_coding_system). Don't QUIT in that case. */
2005 if (!interrupt_input_blocked
)
2010 wrong_type_argument (Qlistp
, prop
);
2015 DEFUN ("safe-plist-get", Fsafe_plist_get
, Ssafe_plist_get
, 2, 2, 0,
2016 doc
: /* Extract a value from a property list.
2017 PLIST is a property list, which is a list of the form
2018 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2019 corresponding to the given PROP, or nil if PROP is not
2020 one of the properties on the list.
2021 This function never signals an error. */)
2026 Lisp_Object tail
, halftail
;
2028 /* halftail is used to detect circular lists. */
2029 tail
= halftail
= plist
;
2030 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2032 if (EQ (prop
, XCAR (tail
)))
2033 return XCAR (XCDR (tail
));
2035 tail
= XCDR (XCDR (tail
));
2036 halftail
= XCDR (halftail
);
2037 if (EQ (tail
, halftail
))
2044 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2045 doc
: /* Return the value of SYMBOL's PROPNAME property.
2046 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2048 Lisp_Object symbol
, propname
;
2050 CHECK_SYMBOL (symbol
);
2051 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2054 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2055 doc
: /* Change value in PLIST of PROP to VAL.
2056 PLIST is a property list, which is a list of the form
2057 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2058 If PROP is already a property on the list, its value is set to VAL,
2059 otherwise the new PROP VAL pair is added. The new plist is returned;
2060 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2061 The PLIST is modified by side effects. */)
2064 register Lisp_Object prop
;
2067 register Lisp_Object tail
, prev
;
2068 Lisp_Object newcell
;
2070 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2071 tail
= XCDR (XCDR (tail
)))
2073 if (EQ (prop
, XCAR (tail
)))
2075 Fsetcar (XCDR (tail
), val
);
2082 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2086 Fsetcdr (XCDR (prev
), newcell
);
2090 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2091 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2092 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2093 (symbol
, propname
, value
)
2094 Lisp_Object symbol
, propname
, value
;
2096 CHECK_SYMBOL (symbol
);
2097 XSYMBOL (symbol
)->plist
2098 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2102 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2103 doc
: /* Extract a value from a property list, comparing with `equal'.
2104 PLIST is a property list, which is a list of the form
2105 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2106 corresponding to the given PROP, or nil if PROP is not
2107 one of the properties on the list. */)
2115 CONSP (tail
) && CONSP (XCDR (tail
));
2116 tail
= XCDR (XCDR (tail
)))
2118 if (! NILP (Fequal (prop
, XCAR (tail
))))
2119 return XCAR (XCDR (tail
));
2125 wrong_type_argument (Qlistp
, prop
);
2130 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2131 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2132 PLIST is a property list, which is a list of the form
2133 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2134 If PROP is already a property on the list, its value is set to VAL,
2135 otherwise the new PROP VAL pair is added. The new plist is returned;
2136 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2137 The PLIST is modified by side effects. */)
2140 register Lisp_Object prop
;
2143 register Lisp_Object tail
, prev
;
2144 Lisp_Object newcell
;
2146 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2147 tail
= XCDR (XCDR (tail
)))
2149 if (! NILP (Fequal (prop
, XCAR (tail
))))
2151 Fsetcar (XCDR (tail
), val
);
2158 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2162 Fsetcdr (XCDR (prev
), newcell
);
2166 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2167 doc
: /* Return t if the two args are the same Lisp object.
2168 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2170 Lisp_Object obj1
, obj2
;
2173 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2175 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2178 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2179 doc
: /* Return t if two Lisp objects have similar structure and contents.
2180 They must have the same data type.
2181 Conses are compared by comparing the cars and the cdrs.
2182 Vectors and strings are compared element by element.
2183 Numbers are compared by value, but integers cannot equal floats.
2184 (Use `=' if you want integers and floats to be able to be equal.)
2185 Symbols must match exactly. */)
2187 register Lisp_Object o1
, o2
;
2189 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2192 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2193 doc
: /* Return t if two Lisp objects have similar structure and contents.
2194 This is like `equal' except that it compares the text properties
2195 of strings. (`equal' ignores text properties.) */)
2197 register Lisp_Object o1
, o2
;
2199 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2202 /* DEPTH is current depth of recursion. Signal an error if it
2204 PROPS, if non-nil, means compare string text properties too. */
2207 internal_equal (o1
, o2
, depth
, props
)
2208 register Lisp_Object o1
, o2
;
2212 error ("Stack overflow in equal");
2218 if (XTYPE (o1
) != XTYPE (o2
))
2227 d1
= extract_float (o1
);
2228 d2
= extract_float (o2
);
2229 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2230 though they are not =. */
2231 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2235 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2242 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2246 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2248 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2251 o1
= XOVERLAY (o1
)->plist
;
2252 o2
= XOVERLAY (o2
)->plist
;
2257 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2258 && (XMARKER (o1
)->buffer
== 0
2259 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2263 case Lisp_Vectorlike
:
2266 EMACS_INT size
= XVECTOR (o1
)->size
;
2267 /* Pseudovectors have the type encoded in the size field, so this test
2268 actually checks that the objects have the same type as well as the
2270 if (XVECTOR (o2
)->size
!= size
)
2272 /* Boolvectors are compared much like strings. */
2273 if (BOOL_VECTOR_P (o1
))
2276 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2277 / BOOL_VECTOR_BITS_PER_CHAR
);
2279 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2281 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2286 if (WINDOW_CONFIGURATIONP (o1
))
2287 return compare_window_configurations (o1
, o2
, 0);
2289 /* Aside from them, only true vectors, char-tables, and compiled
2290 functions are sensible to compare, so eliminate the others now. */
2291 if (size
& PSEUDOVECTOR_FLAG
)
2293 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2295 size
&= PSEUDOVECTOR_SIZE_MASK
;
2297 for (i
= 0; i
< size
; i
++)
2300 v1
= XVECTOR (o1
)->contents
[i
];
2301 v2
= XVECTOR (o2
)->contents
[i
];
2302 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2310 if (SCHARS (o1
) != SCHARS (o2
))
2312 if (SBYTES (o1
) != SBYTES (o2
))
2314 if (bcmp (SDATA (o1
), SDATA (o2
),
2317 if (props
&& !compare_string_intervals (o1
, o2
))
2323 case Lisp_Type_Limit
:
2330 extern Lisp_Object
Fmake_char_internal ();
2332 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2333 doc
: /* Store each element of ARRAY with ITEM.
2334 ARRAY is a vector, string, char-table, or bool-vector. */)
2336 Lisp_Object array
, item
;
2338 register int size
, index
, charval
;
2340 if (VECTORP (array
))
2342 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2343 size
= XVECTOR (array
)->size
;
2344 for (index
= 0; index
< size
; index
++)
2347 else if (CHAR_TABLE_P (array
))
2349 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2350 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2351 for (index
= 0; index
< size
; index
++)
2353 XCHAR_TABLE (array
)->defalt
= Qnil
;
2355 else if (STRINGP (array
))
2357 register unsigned char *p
= SDATA (array
);
2358 CHECK_NUMBER (item
);
2359 charval
= XINT (item
);
2360 size
= SCHARS (array
);
2361 if (STRING_MULTIBYTE (array
))
2363 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2364 int len
= CHAR_STRING (charval
, str
);
2365 int size_byte
= SBYTES (array
);
2366 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2369 if (size
!= size_byte
)
2372 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2373 if (len
!= this_len
)
2374 error ("Attempt to change byte length of a string");
2377 for (i
= 0; i
< size_byte
; i
++)
2378 *p
++ = str
[i
% len
];
2381 for (index
= 0; index
< size
; index
++)
2384 else if (BOOL_VECTOR_P (array
))
2386 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2388 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2389 / BOOL_VECTOR_BITS_PER_CHAR
);
2391 charval
= (! NILP (item
) ? -1 : 0);
2392 for (index
= 0; index
< size_in_chars
- 1; index
++)
2394 if (index
< size_in_chars
)
2396 /* Mask out bits beyond the vector size. */
2397 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2398 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2404 array
= wrong_type_argument (Qarrayp
, array
);
2410 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2412 doc
: /* Clear the contents of STRING.
2413 This makes STRING unibyte and may change its length. */)
2418 CHECK_STRING (string
);
2419 len
= SBYTES (string
);
2420 bzero (SDATA (string
), len
);
2421 STRING_SET_CHARS (string
, len
);
2422 STRING_SET_UNIBYTE (string
);
2426 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2428 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2430 Lisp_Object char_table
;
2432 CHECK_CHAR_TABLE (char_table
);
2434 return XCHAR_TABLE (char_table
)->purpose
;
2437 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2439 doc
: /* Return the parent char-table of CHAR-TABLE.
2440 The value is either nil or another char-table.
2441 If CHAR-TABLE holds nil for a given character,
2442 then the actual applicable value is inherited from the parent char-table
2443 \(or from its parents, if necessary). */)
2445 Lisp_Object char_table
;
2447 CHECK_CHAR_TABLE (char_table
);
2449 return XCHAR_TABLE (char_table
)->parent
;
2452 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2454 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2455 Return PARENT. PARENT must be either nil or another char-table. */)
2456 (char_table
, parent
)
2457 Lisp_Object char_table
, parent
;
2461 CHECK_CHAR_TABLE (char_table
);
2465 CHECK_CHAR_TABLE (parent
);
2467 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2468 if (EQ (temp
, char_table
))
2469 error ("Attempt to make a chartable be its own parent");
2472 XCHAR_TABLE (char_table
)->parent
= parent
;
2477 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2479 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2481 Lisp_Object char_table
, n
;
2483 CHECK_CHAR_TABLE (char_table
);
2486 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2487 args_out_of_range (char_table
, n
);
2489 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2492 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2493 Sset_char_table_extra_slot
,
2495 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2496 (char_table
, n
, value
)
2497 Lisp_Object char_table
, n
, value
;
2499 CHECK_CHAR_TABLE (char_table
);
2502 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2503 args_out_of_range (char_table
, n
);
2505 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2508 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2510 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2511 RANGE should be nil (for the default value)
2512 a vector which identifies a character set or a row of a character set,
2513 a character set name, or a character code. */)
2515 Lisp_Object char_table
, range
;
2517 CHECK_CHAR_TABLE (char_table
);
2519 if (EQ (range
, Qnil
))
2520 return XCHAR_TABLE (char_table
)->defalt
;
2521 else if (INTEGERP (range
))
2522 return Faref (char_table
, range
);
2523 else if (SYMBOLP (range
))
2525 Lisp_Object charset_info
;
2527 charset_info
= Fget (range
, Qcharset
);
2528 CHECK_VECTOR (charset_info
);
2530 return Faref (char_table
,
2531 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2534 else if (VECTORP (range
))
2536 if (XVECTOR (range
)->size
== 1)
2537 return Faref (char_table
,
2538 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2541 int size
= XVECTOR (range
)->size
;
2542 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2543 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2544 size
<= 1 ? Qnil
: val
[1],
2545 size
<= 2 ? Qnil
: val
[2]);
2546 return Faref (char_table
, ch
);
2550 error ("Invalid RANGE argument to `char-table-range'");
2554 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2556 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2557 RANGE should be t (for all characters), nil (for the default value),
2558 a character set, a vector which identifies a character set, a row of a
2559 character set, or a character code. Return VALUE. */)
2560 (char_table
, range
, value
)
2561 Lisp_Object char_table
, range
, value
;
2565 CHECK_CHAR_TABLE (char_table
);
2568 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2569 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2570 else if (EQ (range
, Qnil
))
2571 XCHAR_TABLE (char_table
)->defalt
= value
;
2572 else if (SYMBOLP (range
))
2574 Lisp_Object charset_info
;
2577 charset_info
= Fget (range
, Qcharset
);
2578 if (! VECTORP (charset_info
)
2579 || ! NATNUMP (AREF (charset_info
, 0))
2580 || (charset_id
= XINT (AREF (charset_info
, 0)),
2581 ! CHARSET_DEFINED_P (charset_id
)))
2582 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2584 if (charset_id
== CHARSET_ASCII
)
2585 for (i
= 0; i
< 128; i
++)
2586 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2587 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2588 for (i
= 128; i
< 160; i
++)
2589 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2590 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2591 for (i
= 160; i
< 256; i
++)
2592 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2594 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2596 else if (INTEGERP (range
))
2597 Faset (char_table
, range
, value
);
2598 else if (VECTORP (range
))
2600 if (XVECTOR (range
)->size
== 1)
2601 return Faset (char_table
,
2602 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2606 int size
= XVECTOR (range
)->size
;
2607 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2608 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2609 size
<= 1 ? Qnil
: val
[1],
2610 size
<= 2 ? Qnil
: val
[2]);
2611 return Faset (char_table
, ch
, value
);
2615 error ("Invalid RANGE argument to `set-char-table-range'");
2620 DEFUN ("set-char-table-default", Fset_char_table_default
,
2621 Sset_char_table_default
, 3, 3, 0,
2622 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2623 The generic character specifies the group of characters.
2624 See also the documentation of `make-char'. */)
2625 (char_table
, ch
, value
)
2626 Lisp_Object char_table
, ch
, value
;
2628 int c
, charset
, code1
, code2
;
2631 CHECK_CHAR_TABLE (char_table
);
2635 SPLIT_CHAR (c
, charset
, code1
, code2
);
2637 /* Since we may want to set the default value for a character set
2638 not yet defined, we check only if the character set is in the
2639 valid range or not, instead of it is already defined or not. */
2640 if (! CHARSET_VALID_P (charset
))
2641 invalid_character (c
);
2643 if (charset
== CHARSET_ASCII
)
2644 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2646 /* Even if C is not a generic char, we had better behave as if a
2647 generic char is specified. */
2648 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2650 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2653 if (SUB_CHAR_TABLE_P (temp
))
2654 XCHAR_TABLE (temp
)->defalt
= value
;
2656 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2659 if (SUB_CHAR_TABLE_P (temp
))
2662 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2663 = make_sub_char_table (temp
));
2664 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2665 if (SUB_CHAR_TABLE_P (temp
))
2666 XCHAR_TABLE (temp
)->defalt
= value
;
2668 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2672 /* Look up the element in TABLE at index CH,
2673 and return it as an integer.
2674 If the element is nil, return CH itself.
2675 (Actually we do that for any non-integer.) */
2678 char_table_translate (table
, ch
)
2683 value
= Faref (table
, make_number (ch
));
2684 if (! INTEGERP (value
))
2686 return XINT (value
);
2690 optimize_sub_char_table (table
, chars
)
2698 from
= 33, to
= 127;
2700 from
= 32, to
= 128;
2702 if (!SUB_CHAR_TABLE_P (*table
))
2704 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2705 for (; from
< to
; from
++)
2706 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2711 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2712 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2720 CHECK_CHAR_TABLE (table
);
2722 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2724 elt
= XCHAR_TABLE (table
)->contents
[i
];
2725 if (!SUB_CHAR_TABLE_P (elt
))
2727 dim
= CHARSET_DIMENSION (i
- 128);
2729 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2730 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2731 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2737 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2738 character or group of characters that share a value.
2739 DEPTH is the current depth in the originally specified
2740 chartable, and INDICES contains the vector indices
2741 for the levels our callers have descended.
2743 ARG is passed to C_FUNCTION when that is called. */
2746 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2747 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2748 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2752 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2754 GCPRO4 (arg
, table
, subtable
, function
);
2758 /* At first, handle ASCII and 8-bit European characters. */
2759 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2761 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2763 elt
= XCHAR_TABLE (subtable
)->defalt
;
2765 elt
= Faref (subtable
, make_number (i
));
2767 (*c_function
) (arg
, make_number (i
), elt
);
2769 call2 (function
, make_number (i
), elt
);
2771 #if 0 /* If the char table has entries for higher characters,
2772 we should report them. */
2773 if (NILP (current_buffer
->enable_multibyte_characters
))
2779 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2783 int charset
= XFASTINT (indices
[0]) - 128;
2786 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2787 if (CHARSET_CHARS (charset
) == 94)
2796 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2797 XSETFASTINT (indices
[depth
], i
);
2798 charset
= XFASTINT (indices
[0]) - 128;
2800 && (!CHARSET_DEFINED_P (charset
)
2801 || charset
== CHARSET_8_BIT_CONTROL
2802 || charset
== CHARSET_8_BIT_GRAPHIC
))
2805 if (SUB_CHAR_TABLE_P (elt
))
2808 error ("Too deep char table");
2809 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2815 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2816 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2817 c
= MAKE_CHAR (charset
, c1
, c2
);
2820 elt
= XCHAR_TABLE (subtable
)->defalt
;
2822 elt
= Faref (table
, make_number (c
));
2825 (*c_function
) (arg
, make_number (c
), elt
);
2827 call2 (function
, make_number (c
), elt
);
2833 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2835 void_call2 (a
, b
, c
)
2836 Lisp_Object a
, b
, c
;
2841 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2843 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2844 FUNCTION is called with two arguments--a key and a value.
2845 The key is always a possible IDX argument to `aref'. */)
2846 (function
, char_table
)
2847 Lisp_Object function
, char_table
;
2849 /* The depth of char table is at most 3. */
2850 Lisp_Object indices
[3];
2852 CHECK_CHAR_TABLE (char_table
);
2854 /* When Lisp_Object is represented as a union, `call2' cannot directly
2855 be passed to map_char_table because it returns a Lisp_Object rather
2856 than returning nothing.
2857 Casting leads to crashes on some architectures. -stef */
2858 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2862 /* Return a value for character C in char-table TABLE. Store the
2863 actual index for that value in *IDX. Ignore the default value of
2867 char_table_ref_and_index (table
, c
, idx
)
2871 int charset
, c1
, c2
;
2874 if (SINGLE_BYTE_CHAR_P (c
))
2877 return XCHAR_TABLE (table
)->contents
[c
];
2879 SPLIT_CHAR (c
, charset
, c1
, c2
);
2880 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2881 *idx
= MAKE_CHAR (charset
, 0, 0);
2882 if (!SUB_CHAR_TABLE_P (elt
))
2884 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2885 return XCHAR_TABLE (elt
)->defalt
;
2886 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2887 *idx
= MAKE_CHAR (charset
, c1
, 0);
2888 if (!SUB_CHAR_TABLE_P (elt
))
2890 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2891 return XCHAR_TABLE (elt
)->defalt
;
2893 return XCHAR_TABLE (elt
)->contents
[c2
];
2903 Lisp_Object args
[2];
2906 return Fnconc (2, args
);
2908 return Fnconc (2, &s1
);
2909 #endif /* NO_ARG_ARRAY */
2912 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2913 doc
: /* Concatenate any number of lists by altering them.
2914 Only the last argument is not altered, and need not be a list.
2915 usage: (nconc &rest LISTS) */)
2920 register int argnum
;
2921 register Lisp_Object tail
, tem
, val
;
2925 for (argnum
= 0; argnum
< nargs
; argnum
++)
2928 if (NILP (tem
)) continue;
2933 if (argnum
+ 1 == nargs
) break;
2936 tem
= wrong_type_argument (Qlistp
, tem
);
2945 tem
= args
[argnum
+ 1];
2946 Fsetcdr (tail
, tem
);
2948 args
[argnum
+ 1] = tail
;
2954 /* This is the guts of all mapping functions.
2955 Apply FN to each element of SEQ, one by one,
2956 storing the results into elements of VALS, a C vector of Lisp_Objects.
2957 LENI is the length of VALS, which should also be the length of SEQ. */
2960 mapcar1 (leni
, vals
, fn
, seq
)
2963 Lisp_Object fn
, seq
;
2965 register Lisp_Object tail
;
2968 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2972 /* Don't let vals contain any garbage when GC happens. */
2973 for (i
= 0; i
< leni
; i
++)
2976 GCPRO3 (dummy
, fn
, seq
);
2978 gcpro1
.nvars
= leni
;
2982 /* We need not explicitly protect `tail' because it is used only on lists, and
2983 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2987 for (i
= 0; i
< leni
; i
++)
2989 dummy
= XVECTOR (seq
)->contents
[i
];
2990 dummy
= call1 (fn
, dummy
);
2995 else if (BOOL_VECTOR_P (seq
))
2997 for (i
= 0; i
< leni
; i
++)
3000 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
3001 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
3006 dummy
= call1 (fn
, dummy
);
3011 else if (STRINGP (seq
))
3015 for (i
= 0, i_byte
= 0; i
< leni
;)
3020 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3021 XSETFASTINT (dummy
, c
);
3022 dummy
= call1 (fn
, dummy
);
3024 vals
[i_before
] = dummy
;
3027 else /* Must be a list, since Flength did not get an error */
3030 for (i
= 0; i
< leni
; i
++)
3032 dummy
= call1 (fn
, Fcar (tail
));
3042 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3043 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3044 In between each pair of results, stick in SEPARATOR. Thus, " " as
3045 SEPARATOR results in spaces between the values returned by FUNCTION.
3046 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3047 (function
, sequence
, separator
)
3048 Lisp_Object function
, sequence
, separator
;
3053 register Lisp_Object
*args
;
3055 struct gcpro gcpro1
;
3059 len
= Flength (sequence
);
3061 nargs
= leni
+ leni
- 1;
3062 if (nargs
< 0) return build_string ("");
3064 SAFE_ALLOCA_LISP (args
, nargs
);
3067 mapcar1 (leni
, args
, function
, sequence
);
3070 for (i
= leni
- 1; i
>= 0; i
--)
3071 args
[i
+ i
] = args
[i
];
3073 for (i
= 1; i
< nargs
; i
+= 2)
3074 args
[i
] = separator
;
3076 ret
= Fconcat (nargs
, args
);
3082 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3083 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3084 The result is a list just as long as SEQUENCE.
3085 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3086 (function
, sequence
)
3087 Lisp_Object function
, sequence
;
3089 register Lisp_Object len
;
3091 register Lisp_Object
*args
;
3095 len
= Flength (sequence
);
3096 leni
= XFASTINT (len
);
3098 SAFE_ALLOCA_LISP (args
, leni
);
3100 mapcar1 (leni
, args
, function
, sequence
);
3102 ret
= Flist (leni
, args
);
3108 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3109 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3110 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3111 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3112 (function
, sequence
)
3113 Lisp_Object function
, sequence
;
3117 leni
= XFASTINT (Flength (sequence
));
3118 mapcar1 (leni
, 0, function
, sequence
);
3123 /* Anything that calls this function must protect from GC! */
3125 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3126 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3127 Takes one argument, which is the string to display to ask the question.
3128 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3129 No confirmation of the answer is requested; a single character is enough.
3130 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3131 the bindings in `query-replace-map'; see the documentation of that variable
3132 for more information. In this case, the useful bindings are `act', `skip',
3133 `recenter', and `quit'.\)
3135 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3136 is nil and `use-dialog-box' is non-nil. */)
3140 register Lisp_Object obj
, key
, def
, map
;
3141 register int answer
;
3142 Lisp_Object xprompt
;
3143 Lisp_Object args
[2];
3144 struct gcpro gcpro1
, gcpro2
;
3145 int count
= SPECPDL_INDEX ();
3147 specbind (Qcursor_in_echo_area
, Qt
);
3149 map
= Fsymbol_value (intern ("query-replace-map"));
3151 CHECK_STRING (prompt
);
3153 GCPRO2 (prompt
, xprompt
);
3155 #ifdef HAVE_X_WINDOWS
3156 if (display_hourglass_p
)
3157 cancel_hourglass ();
3164 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3168 Lisp_Object pane
, menu
;
3169 redisplay_preserve_echo_area (3);
3170 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3171 Fcons (Fcons (build_string ("No"), Qnil
),
3173 menu
= Fcons (prompt
, pane
);
3174 obj
= Fx_popup_dialog (Qt
, menu
);
3175 answer
= !NILP (obj
);
3178 #endif /* HAVE_MENUS */
3179 cursor_in_echo_area
= 1;
3180 choose_minibuf_frame ();
3183 Lisp_Object pargs
[3];
3185 /* Colorize prompt according to `minibuffer-prompt' face. */
3186 pargs
[0] = build_string ("%s(y or n) ");
3187 pargs
[1] = intern ("face");
3188 pargs
[2] = intern ("minibuffer-prompt");
3189 args
[0] = Fpropertize (3, pargs
);
3194 if (minibuffer_auto_raise
)
3196 Lisp_Object mini_frame
;
3198 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3200 Fraise_frame (mini_frame
);
3203 obj
= read_filtered_event (1, 0, 0, 0);
3204 cursor_in_echo_area
= 0;
3205 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3208 key
= Fmake_vector (make_number (1), obj
);
3209 def
= Flookup_key (map
, key
, Qt
);
3211 if (EQ (def
, intern ("skip")))
3216 else if (EQ (def
, intern ("act")))
3221 else if (EQ (def
, intern ("recenter")))
3227 else if (EQ (def
, intern ("quit")))
3229 /* We want to exit this command for exit-prefix,
3230 and this is the only way to do it. */
3231 else if (EQ (def
, intern ("exit-prefix")))
3236 /* If we don't clear this, then the next call to read_char will
3237 return quit_char again, and we'll enter an infinite loop. */
3242 if (EQ (xprompt
, prompt
))
3244 args
[0] = build_string ("Please answer y or n. ");
3246 xprompt
= Fconcat (2, args
);
3251 if (! noninteractive
)
3253 cursor_in_echo_area
= -1;
3254 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3258 unbind_to (count
, Qnil
);
3259 return answer
? Qt
: Qnil
;
3262 /* This is how C code calls `yes-or-no-p' and allows the user
3265 Anything that calls this function must protect from GC! */
3268 do_yes_or_no_p (prompt
)
3271 return call1 (intern ("yes-or-no-p"), prompt
);
3274 /* Anything that calls this function must protect from GC! */
3276 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3277 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3278 Takes one argument, which is the string to display to ask the question.
3279 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3280 The user must confirm the answer with RET,
3281 and can edit it until it has been confirmed.
3283 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3284 is nil, and `use-dialog-box' is non-nil. */)
3288 register Lisp_Object ans
;
3289 Lisp_Object args
[2];
3290 struct gcpro gcpro1
;
3292 CHECK_STRING (prompt
);
3295 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3299 Lisp_Object pane
, menu
, obj
;
3300 redisplay_preserve_echo_area (4);
3301 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3302 Fcons (Fcons (build_string ("No"), Qnil
),
3305 menu
= Fcons (prompt
, pane
);
3306 obj
= Fx_popup_dialog (Qt
, menu
);
3310 #endif /* HAVE_MENUS */
3313 args
[1] = build_string ("(yes or no) ");
3314 prompt
= Fconcat (2, args
);
3320 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3321 Qyes_or_no_p_history
, Qnil
,
3323 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3328 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3336 message ("Please answer yes or no.");
3337 Fsleep_for (make_number (2), Qnil
);
3341 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3342 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3344 Each of the three load averages is multiplied by 100, then converted
3347 When USE-FLOATS is non-nil, floats will be used instead of integers.
3348 These floats are not multiplied by 100.
3350 If the 5-minute or 15-minute load averages are not available, return a
3351 shortened list, containing only those averages which are available.
3353 An error is thrown if the load average can't be obtained. In some
3354 cases making it work would require Emacs being installed setuid or
3355 setgid so that it can read kernel information, and that usually isn't
3358 Lisp_Object use_floats
;
3361 int loads
= getloadavg (load_ave
, 3);
3362 Lisp_Object ret
= Qnil
;
3365 error ("load-average not implemented for this operating system");
3369 Lisp_Object load
= (NILP (use_floats
) ?
3370 make_number ((int) (100.0 * load_ave
[loads
]))
3371 : make_float (load_ave
[loads
]));
3372 ret
= Fcons (load
, ret
);
3378 Lisp_Object Vfeatures
, Qsubfeatures
;
3379 extern Lisp_Object Vafter_load_alist
;
3381 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3382 doc
: /* Returns t if FEATURE is present in this Emacs.
3384 Use this to conditionalize execution of lisp code based on the
3385 presence or absence of emacs or environment extensions.
3386 Use `provide' to declare that a feature is available. This function
3387 looks at the value of the variable `features'. The optional argument
3388 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3389 (feature
, subfeature
)
3390 Lisp_Object feature
, subfeature
;
3392 register Lisp_Object tem
;
3393 CHECK_SYMBOL (feature
);
3394 tem
= Fmemq (feature
, Vfeatures
);
3395 if (!NILP (tem
) && !NILP (subfeature
))
3396 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3397 return (NILP (tem
)) ? Qnil
: Qt
;
3400 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3401 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3402 The optional argument SUBFEATURES should be a list of symbols listing
3403 particular subfeatures supported in this version of FEATURE. */)
3404 (feature
, subfeatures
)
3405 Lisp_Object feature
, subfeatures
;
3407 register Lisp_Object tem
;
3408 CHECK_SYMBOL (feature
);
3409 CHECK_LIST (subfeatures
);
3410 if (!NILP (Vautoload_queue
))
3411 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3412 tem
= Fmemq (feature
, Vfeatures
);
3414 Vfeatures
= Fcons (feature
, Vfeatures
);
3415 if (!NILP (subfeatures
))
3416 Fput (feature
, Qsubfeatures
, subfeatures
);
3417 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3419 /* Run any load-hooks for this file. */
3420 tem
= Fassq (feature
, Vafter_load_alist
);
3422 Fprogn (XCDR (tem
));
3427 /* `require' and its subroutines. */
3429 /* List of features currently being require'd, innermost first. */
3431 Lisp_Object require_nesting_list
;
3434 require_unwind (old_value
)
3435 Lisp_Object old_value
;
3437 return require_nesting_list
= old_value
;
3440 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3441 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3442 If FEATURE is not a member of the list `features', then the feature
3443 is not loaded; so load the file FILENAME.
3444 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3445 and `load' will try to load this name appended with the suffix `.elc' or
3446 `.el', in that order. The name without appended suffix will not be used.
3447 If the optional third argument NOERROR is non-nil,
3448 then return nil if the file is not found instead of signaling an error.
3449 Normally the return value is FEATURE.
3450 The normal messages at start and end of loading FILENAME are suppressed. */)
3451 (feature
, filename
, noerror
)
3452 Lisp_Object feature
, filename
, noerror
;
3454 register Lisp_Object tem
;
3455 struct gcpro gcpro1
, gcpro2
;
3457 CHECK_SYMBOL (feature
);
3459 /* Record the presence of `require' in this file
3460 even if the feature specified is already loaded.
3461 But not more than once in any file,
3462 and not when we aren't loading a file. */
3463 if (! NILP (Vloads_in_progress
))
3465 tem
= Fcons (Qrequire
, feature
);
3466 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3467 LOADHIST_ATTACH (tem
);
3469 tem
= Fmemq (feature
, Vfeatures
);
3473 int count
= SPECPDL_INDEX ();
3476 /* This is to make sure that loadup.el gives a clear picture
3477 of what files are preloaded and when. */
3478 if (! NILP (Vpurify_flag
))
3479 error ("(require %s) while preparing to dump",
3480 SDATA (SYMBOL_NAME (feature
)));
3482 /* A certain amount of recursive `require' is legitimate,
3483 but if we require the same feature recursively 3 times,
3485 tem
= require_nesting_list
;
3486 while (! NILP (tem
))
3488 if (! NILP (Fequal (feature
, XCAR (tem
))))
3493 error ("Recursive `require' for feature `%s'",
3494 SDATA (SYMBOL_NAME (feature
)));
3496 /* Update the list for any nested `require's that occur. */
3497 record_unwind_protect (require_unwind
, require_nesting_list
);
3498 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3500 /* Value saved here is to be restored into Vautoload_queue */
3501 record_unwind_protect (un_autoload
, Vautoload_queue
);
3502 Vautoload_queue
= Qt
;
3504 /* Load the file. */
3505 GCPRO2 (feature
, filename
);
3506 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3507 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3510 /* If load failed entirely, return nil. */
3512 return unbind_to (count
, Qnil
);
3514 tem
= Fmemq (feature
, Vfeatures
);
3516 error ("Required feature `%s' was not provided",
3517 SDATA (SYMBOL_NAME (feature
)));
3519 /* Once loading finishes, don't undo it. */
3520 Vautoload_queue
= Qt
;
3521 feature
= unbind_to (count
, feature
);
3527 /* Primitives for work of the "widget" library.
3528 In an ideal world, this section would not have been necessary.
3529 However, lisp function calls being as slow as they are, it turns
3530 out that some functions in the widget library (wid-edit.el) are the
3531 bottleneck of Widget operation. Here is their translation to C,
3532 for the sole reason of efficiency. */
3534 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3535 doc
: /* Return non-nil if PLIST has the property PROP.
3536 PLIST is a property list, which is a list of the form
3537 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3538 Unlike `plist-get', this allows you to distinguish between a missing
3539 property and a property with the value nil.
3540 The value is actually the tail of PLIST whose car is PROP. */)
3542 Lisp_Object plist
, prop
;
3544 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3547 plist
= XCDR (plist
);
3548 plist
= CDR (plist
);
3553 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3554 doc
: /* In WIDGET, set PROPERTY to VALUE.
3555 The value can later be retrieved with `widget-get'. */)
3556 (widget
, property
, value
)
3557 Lisp_Object widget
, property
, value
;
3559 CHECK_CONS (widget
);
3560 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3564 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3565 doc
: /* In WIDGET, get the value of PROPERTY.
3566 The value could either be specified when the widget was created, or
3567 later with `widget-put'. */)
3569 Lisp_Object widget
, property
;
3577 CHECK_CONS (widget
);
3578 tmp
= Fplist_member (XCDR (widget
), property
);
3584 tmp
= XCAR (widget
);
3587 widget
= Fget (tmp
, Qwidget_type
);
3591 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3592 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3593 ARGS are passed as extra arguments to the function.
3594 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3599 /* This function can GC. */
3600 Lisp_Object newargs
[3];
3601 struct gcpro gcpro1
, gcpro2
;
3604 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3605 newargs
[1] = args
[0];
3606 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3607 GCPRO2 (newargs
[0], newargs
[2]);
3608 result
= Fapply (3, newargs
);
3613 #ifdef HAVE_LANGINFO_CODESET
3614 #include <langinfo.h>
3617 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3618 doc
: /* Access locale data ITEM for the current C locale, if available.
3619 ITEM should be one of the following:
3621 `codeset', returning the character set as a string (locale item CODESET);
3623 `days', returning a 7-element vector of day names (locale items DAY_n);
3625 `months', returning a 12-element vector of month names (locale items MON_n);
3627 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3628 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3630 If the system can't provide such information through a call to
3631 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3633 See also Info node `(libc)Locales'.
3635 The data read from the system are decoded using `locale-coding-system'. */)
3640 #ifdef HAVE_LANGINFO_CODESET
3642 if (EQ (item
, Qcodeset
))
3644 str
= nl_langinfo (CODESET
);
3645 return build_string (str
);
3648 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3650 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3651 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3653 synchronize_system_time_locale ();
3654 for (i
= 0; i
< 7; i
++)
3656 str
= nl_langinfo (days
[i
]);
3657 val
= make_unibyte_string (str
, strlen (str
));
3658 /* Fixme: Is this coding system necessarily right, even if
3659 it is consistent with CODESET? If not, what to do? */
3660 Faset (v
, make_number (i
),
3661 code_convert_string_norecord (val
, Vlocale_coding_system
,
3668 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3670 struct Lisp_Vector
*p
= allocate_vector (12);
3671 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3672 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3674 synchronize_system_time_locale ();
3675 for (i
= 0; i
< 12; i
++)
3677 str
= nl_langinfo (months
[i
]);
3678 val
= make_unibyte_string (str
, strlen (str
));
3680 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3682 XSETVECTOR (val
, p
);
3686 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3687 but is in the locale files. This could be used by ps-print. */
3689 else if (EQ (item
, Qpaper
))
3691 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3692 make_number (nl_langinfo (PAPER_HEIGHT
)));
3694 #endif /* PAPER_WIDTH */
3695 #endif /* HAVE_LANGINFO_CODESET*/
3699 /* base64 encode/decode functions (RFC 2045).
3700 Based on code from GNU recode. */
3702 #define MIME_LINE_LENGTH 76
3704 #define IS_ASCII(Character) \
3706 #define IS_BASE64(Character) \
3707 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3708 #define IS_BASE64_IGNORABLE(Character) \
3709 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3710 || (Character) == '\f' || (Character) == '\r')
3712 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3713 character or return retval if there are no characters left to
3715 #define READ_QUADRUPLET_BYTE(retval) \
3720 if (nchars_return) \
3721 *nchars_return = nchars; \
3726 while (IS_BASE64_IGNORABLE (c))
3728 /* Table of characters coding the 64 values. */
3729 static char base64_value_to_char
[64] =
3731 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3732 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3733 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3734 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3735 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3736 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3737 '8', '9', '+', '/' /* 60-63 */
3740 /* Table of base64 values for first 128 characters. */
3741 static short base64_char_to_value
[128] =
3743 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3744 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3745 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3746 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3747 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3748 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3749 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3750 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3751 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3752 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3753 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3754 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3755 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3758 /* The following diagram shows the logical steps by which three octets
3759 get transformed into four base64 characters.
3761 .--------. .--------. .--------.
3762 |aaaaaabb| |bbbbcccc| |ccdddddd|
3763 `--------' `--------' `--------'
3765 .--------+--------+--------+--------.
3766 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3767 `--------+--------+--------+--------'
3769 .--------+--------+--------+--------.
3770 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3771 `--------+--------+--------+--------'
3773 The octets are divided into 6 bit chunks, which are then encoded into
3774 base64 characters. */
3777 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3778 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3780 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3782 doc
: /* Base64-encode the region between BEG and END.
3783 Return the length of the encoded text.
3784 Optional third argument NO-LINE-BREAK means do not break long lines
3785 into shorter lines. */)
3786 (beg
, end
, no_line_break
)
3787 Lisp_Object beg
, end
, no_line_break
;
3790 int allength
, length
;
3791 int ibeg
, iend
, encoded_length
;
3795 validate_region (&beg
, &end
);
3797 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3798 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3799 move_gap_both (XFASTINT (beg
), ibeg
);
3801 /* We need to allocate enough room for encoding the text.
3802 We need 33 1/3% more space, plus a newline every 76
3803 characters, and then we round up. */
3804 length
= iend
- ibeg
;
3805 allength
= length
+ length
/3 + 1;
3806 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3808 SAFE_ALLOCA (encoded
, char *, allength
);
3809 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3810 NILP (no_line_break
),
3811 !NILP (current_buffer
->enable_multibyte_characters
));
3812 if (encoded_length
> allength
)
3815 if (encoded_length
< 0)
3817 /* The encoding wasn't possible. */
3819 error ("Multibyte character in data for base64 encoding");
3822 /* Now we have encoded the region, so we insert the new contents
3823 and delete the old. (Insert first in order to preserve markers.) */
3824 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3825 insert (encoded
, encoded_length
);
3827 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3829 /* If point was outside of the region, restore it exactly; else just
3830 move to the beginning of the region. */
3831 if (old_pos
>= XFASTINT (end
))
3832 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3833 else if (old_pos
> XFASTINT (beg
))
3834 old_pos
= XFASTINT (beg
);
3837 /* We return the length of the encoded text. */
3838 return make_number (encoded_length
);
3841 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3843 doc
: /* Base64-encode STRING and return the result.
3844 Optional second argument NO-LINE-BREAK means do not break long lines
3845 into shorter lines. */)
3846 (string
, no_line_break
)
3847 Lisp_Object string
, no_line_break
;
3849 int allength
, length
, encoded_length
;
3851 Lisp_Object encoded_string
;
3854 CHECK_STRING (string
);
3856 /* We need to allocate enough room for encoding the text.
3857 We need 33 1/3% more space, plus a newline every 76
3858 characters, and then we round up. */
3859 length
= SBYTES (string
);
3860 allength
= length
+ length
/3 + 1;
3861 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3863 /* We need to allocate enough room for decoding the text. */
3864 SAFE_ALLOCA (encoded
, char *, allength
);
3866 encoded_length
= base64_encode_1 (SDATA (string
),
3867 encoded
, length
, NILP (no_line_break
),
3868 STRING_MULTIBYTE (string
));
3869 if (encoded_length
> allength
)
3872 if (encoded_length
< 0)
3874 /* The encoding wasn't possible. */
3876 error ("Multibyte character in data for base64 encoding");
3879 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3882 return encoded_string
;
3886 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3893 int counter
= 0, i
= 0;
3903 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3911 /* Wrap line every 76 characters. */
3915 if (counter
< MIME_LINE_LENGTH
/ 4)
3924 /* Process first byte of a triplet. */
3926 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3927 value
= (0x03 & c
) << 4;
3929 /* Process second byte of a triplet. */
3933 *e
++ = base64_value_to_char
[value
];
3941 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3949 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3950 value
= (0x0f & c
) << 2;
3952 /* Process third byte of a triplet. */
3956 *e
++ = base64_value_to_char
[value
];
3963 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3971 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3972 *e
++ = base64_value_to_char
[0x3f & c
];
3979 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3981 doc
: /* Base64-decode the region between BEG and END.
3982 Return the length of the decoded text.
3983 If the region can't be decoded, signal an error and don't modify the buffer. */)
3985 Lisp_Object beg
, end
;
3987 int ibeg
, iend
, length
, allength
;
3992 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3995 validate_region (&beg
, &end
);
3997 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3998 iend
= CHAR_TO_BYTE (XFASTINT (end
));
4000 length
= iend
- ibeg
;
4002 /* We need to allocate enough room for decoding the text. If we are
4003 working on a multibyte buffer, each decoded code may occupy at
4005 allength
= multibyte
? length
* 2 : length
;
4006 SAFE_ALLOCA (decoded
, char *, allength
);
4008 move_gap_both (XFASTINT (beg
), ibeg
);
4009 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
4010 multibyte
, &inserted_chars
);
4011 if (decoded_length
> allength
)
4014 if (decoded_length
< 0)
4016 /* The decoding wasn't possible. */
4018 error ("Invalid base64 data");
4021 /* Now we have decoded the region, so we insert the new contents
4022 and delete the old. (Insert first in order to preserve markers.) */
4023 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4024 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4027 /* Delete the original text. */
4028 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4029 iend
+ decoded_length
, 1);
4031 /* If point was outside of the region, restore it exactly; else just
4032 move to the beginning of the region. */
4033 if (old_pos
>= XFASTINT (end
))
4034 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4035 else if (old_pos
> XFASTINT (beg
))
4036 old_pos
= XFASTINT (beg
);
4037 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4039 return make_number (inserted_chars
);
4042 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4044 doc
: /* Base64-decode STRING and return the result. */)
4049 int length
, decoded_length
;
4050 Lisp_Object decoded_string
;
4053 CHECK_STRING (string
);
4055 length
= SBYTES (string
);
4056 /* We need to allocate enough room for decoding the text. */
4057 SAFE_ALLOCA (decoded
, char *, length
);
4059 /* The decoded result should be unibyte. */
4060 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4062 if (decoded_length
> length
)
4064 else if (decoded_length
>= 0)
4065 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4067 decoded_string
= Qnil
;
4070 if (!STRINGP (decoded_string
))
4071 error ("Invalid base64 data");
4073 return decoded_string
;
4076 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4077 MULTIBYTE is nonzero, the decoded result should be in multibyte
4078 form. If NCHARS_RETRUN is not NULL, store the number of produced
4079 characters in *NCHARS_RETURN. */
4082 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4092 unsigned long value
;
4097 /* Process first byte of a quadruplet. */
4099 READ_QUADRUPLET_BYTE (e
-to
);
4103 value
= base64_char_to_value
[c
] << 18;
4105 /* Process second byte of a quadruplet. */
4107 READ_QUADRUPLET_BYTE (-1);
4111 value
|= base64_char_to_value
[c
] << 12;
4113 c
= (unsigned char) (value
>> 16);
4115 e
+= CHAR_STRING (c
, e
);
4120 /* Process third byte of a quadruplet. */
4122 READ_QUADRUPLET_BYTE (-1);
4126 READ_QUADRUPLET_BYTE (-1);
4135 value
|= base64_char_to_value
[c
] << 6;
4137 c
= (unsigned char) (0xff & value
>> 8);
4139 e
+= CHAR_STRING (c
, e
);
4144 /* Process fourth byte of a quadruplet. */
4146 READ_QUADRUPLET_BYTE (-1);
4153 value
|= base64_char_to_value
[c
];
4155 c
= (unsigned char) (0xff & value
);
4157 e
+= CHAR_STRING (c
, e
);
4166 /***********************************************************************
4168 ***** Hash Tables *****
4170 ***********************************************************************/
4172 /* Implemented by gerd@gnu.org. This hash table implementation was
4173 inspired by CMUCL hash tables. */
4177 1. For small tables, association lists are probably faster than
4178 hash tables because they have lower overhead.
4180 For uses of hash tables where the O(1) behavior of table
4181 operations is not a requirement, it might therefore be a good idea
4182 not to hash. Instead, we could just do a linear search in the
4183 key_and_value vector of the hash table. This could be done
4184 if a `:linear-search t' argument is given to make-hash-table. */
4187 /* The list of all weak hash tables. Don't staticpro this one. */
4189 Lisp_Object Vweak_hash_tables
;
4191 /* Various symbols. */
4193 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4194 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4195 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4197 /* Function prototypes. */
4199 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4200 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4201 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4202 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4203 Lisp_Object
, unsigned));
4204 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4205 Lisp_Object
, unsigned));
4206 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4207 unsigned, Lisp_Object
, unsigned));
4208 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4209 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4210 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4211 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4213 static unsigned sxhash_string
P_ ((unsigned char *, int));
4214 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4215 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4216 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4217 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4221 /***********************************************************************
4223 ***********************************************************************/
4225 /* If OBJ is a Lisp hash table, return a pointer to its struct
4226 Lisp_Hash_Table. Otherwise, signal an error. */
4228 static struct Lisp_Hash_Table
*
4229 check_hash_table (obj
)
4232 CHECK_HASH_TABLE (obj
);
4233 return XHASH_TABLE (obj
);
4237 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4241 next_almost_prime (n
)
4254 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4255 which USED[I] is non-zero. If found at index I in ARGS, set
4256 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4257 -1. This function is used to extract a keyword/argument pair from
4258 a DEFUN parameter list. */
4261 get_key_arg (key
, nargs
, args
, used
)
4269 for (i
= 0; i
< nargs
- 1; ++i
)
4270 if (!used
[i
] && EQ (args
[i
], key
))
4285 /* Return a Lisp vector which has the same contents as VEC but has
4286 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4287 vector that are not copied from VEC are set to INIT. */
4290 larger_vector (vec
, new_size
, init
)
4295 struct Lisp_Vector
*v
;
4298 xassert (VECTORP (vec
));
4299 old_size
= XVECTOR (vec
)->size
;
4300 xassert (new_size
>= old_size
);
4302 v
= allocate_vector (new_size
);
4303 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4304 old_size
* sizeof *v
->contents
);
4305 for (i
= old_size
; i
< new_size
; ++i
)
4306 v
->contents
[i
] = init
;
4307 XSETVECTOR (vec
, v
);
4312 /***********************************************************************
4314 ***********************************************************************/
4316 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4317 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4318 KEY2 are the same. */
4321 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4322 struct Lisp_Hash_Table
*h
;
4323 Lisp_Object key1
, key2
;
4324 unsigned hash1
, hash2
;
4326 return (FLOATP (key1
)
4328 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4332 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4333 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4334 KEY2 are the same. */
4337 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4338 struct Lisp_Hash_Table
*h
;
4339 Lisp_Object key1
, key2
;
4340 unsigned hash1
, hash2
;
4342 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4346 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4347 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4348 if KEY1 and KEY2 are the same. */
4351 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4352 struct Lisp_Hash_Table
*h
;
4353 Lisp_Object key1
, key2
;
4354 unsigned hash1
, hash2
;
4358 Lisp_Object args
[3];
4360 args
[0] = h
->user_cmp_function
;
4363 return !NILP (Ffuncall (3, args
));
4370 /* Value is a hash code for KEY for use in hash table H which uses
4371 `eq' to compare keys. The hash code returned is guaranteed to fit
4372 in a Lisp integer. */
4376 struct Lisp_Hash_Table
*h
;
4379 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4380 xassert ((hash
& ~INTMASK
) == 0);
4385 /* Value is a hash code for KEY for use in hash table H which uses
4386 `eql' to compare keys. The hash code returned is guaranteed to fit
4387 in a Lisp integer. */
4391 struct Lisp_Hash_Table
*h
;
4396 hash
= sxhash (key
, 0);
4398 hash
= XUINT (key
) ^ XGCTYPE (key
);
4399 xassert ((hash
& ~INTMASK
) == 0);
4404 /* Value is a hash code for KEY for use in hash table H which uses
4405 `equal' to compare keys. The hash code returned is guaranteed to fit
4406 in a Lisp integer. */
4409 hashfn_equal (h
, key
)
4410 struct Lisp_Hash_Table
*h
;
4413 unsigned hash
= sxhash (key
, 0);
4414 xassert ((hash
& ~INTMASK
) == 0);
4419 /* Value is a hash code for KEY for use in hash table H which uses as
4420 user-defined function to compare keys. The hash code returned is
4421 guaranteed to fit in a Lisp integer. */
4424 hashfn_user_defined (h
, key
)
4425 struct Lisp_Hash_Table
*h
;
4428 Lisp_Object args
[2], hash
;
4430 args
[0] = h
->user_hash_function
;
4432 hash
= Ffuncall (2, args
);
4433 if (!INTEGERP (hash
))
4435 list2 (build_string ("Invalid hash code returned from \
4436 user-supplied hash function"),
4438 return XUINT (hash
);
4442 /* Create and initialize a new hash table.
4444 TEST specifies the test the hash table will use to compare keys.
4445 It must be either one of the predefined tests `eq', `eql' or
4446 `equal' or a symbol denoting a user-defined test named TEST with
4447 test and hash functions USER_TEST and USER_HASH.
4449 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4451 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4452 new size when it becomes full is computed by adding REHASH_SIZE to
4453 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4454 table's new size is computed by multiplying its old size with
4457 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4458 be resized when the ratio of (number of entries in the table) /
4459 (table size) is >= REHASH_THRESHOLD.
4461 WEAK specifies the weakness of the table. If non-nil, it must be
4462 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4465 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4466 user_test
, user_hash
)
4467 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4468 Lisp_Object user_test
, user_hash
;
4470 struct Lisp_Hash_Table
*h
;
4472 int index_size
, i
, sz
;
4474 /* Preconditions. */
4475 xassert (SYMBOLP (test
));
4476 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4477 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4478 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4479 xassert (FLOATP (rehash_threshold
)
4480 && XFLOATINT (rehash_threshold
) > 0
4481 && XFLOATINT (rehash_threshold
) <= 1.0);
4483 if (XFASTINT (size
) == 0)
4484 size
= make_number (1);
4486 /* Allocate a table and initialize it. */
4487 h
= allocate_hash_table ();
4489 /* Initialize hash table slots. */
4490 sz
= XFASTINT (size
);
4493 if (EQ (test
, Qeql
))
4495 h
->cmpfn
= cmpfn_eql
;
4496 h
->hashfn
= hashfn_eql
;
4498 else if (EQ (test
, Qeq
))
4501 h
->hashfn
= hashfn_eq
;
4503 else if (EQ (test
, Qequal
))
4505 h
->cmpfn
= cmpfn_equal
;
4506 h
->hashfn
= hashfn_equal
;
4510 h
->user_cmp_function
= user_test
;
4511 h
->user_hash_function
= user_hash
;
4512 h
->cmpfn
= cmpfn_user_defined
;
4513 h
->hashfn
= hashfn_user_defined
;
4517 h
->rehash_threshold
= rehash_threshold
;
4518 h
->rehash_size
= rehash_size
;
4519 h
->count
= make_number (0);
4520 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4521 h
->hash
= Fmake_vector (size
, Qnil
);
4522 h
->next
= Fmake_vector (size
, Qnil
);
4523 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4524 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4525 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4527 /* Set up the free list. */
4528 for (i
= 0; i
< sz
- 1; ++i
)
4529 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4530 h
->next_free
= make_number (0);
4532 XSET_HASH_TABLE (table
, h
);
4533 xassert (HASH_TABLE_P (table
));
4534 xassert (XHASH_TABLE (table
) == h
);
4536 /* Maybe add this hash table to the list of all weak hash tables. */
4538 h
->next_weak
= Qnil
;
4541 h
->next_weak
= Vweak_hash_tables
;
4542 Vweak_hash_tables
= table
;
4549 /* Return a copy of hash table H1. Keys and values are not copied,
4550 only the table itself is. */
4553 copy_hash_table (h1
)
4554 struct Lisp_Hash_Table
*h1
;
4557 struct Lisp_Hash_Table
*h2
;
4558 struct Lisp_Vector
*next
;
4560 h2
= allocate_hash_table ();
4561 next
= h2
->vec_next
;
4562 bcopy (h1
, h2
, sizeof *h2
);
4563 h2
->vec_next
= next
;
4564 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4565 h2
->hash
= Fcopy_sequence (h1
->hash
);
4566 h2
->next
= Fcopy_sequence (h1
->next
);
4567 h2
->index
= Fcopy_sequence (h1
->index
);
4568 XSET_HASH_TABLE (table
, h2
);
4570 /* Maybe add this hash table to the list of all weak hash tables. */
4571 if (!NILP (h2
->weak
))
4573 h2
->next_weak
= Vweak_hash_tables
;
4574 Vweak_hash_tables
= table
;
4581 /* Resize hash table H if it's too full. If H cannot be resized
4582 because it's already too large, throw an error. */
4585 maybe_resize_hash_table (h
)
4586 struct Lisp_Hash_Table
*h
;
4588 if (NILP (h
->next_free
))
4590 int old_size
= HASH_TABLE_SIZE (h
);
4591 int i
, new_size
, index_size
;
4593 if (INTEGERP (h
->rehash_size
))
4594 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4596 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4597 new_size
= max (old_size
+ 1, new_size
);
4598 index_size
= next_almost_prime ((int)
4600 / XFLOATINT (h
->rehash_threshold
)));
4601 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4602 error ("Hash table too large to resize");
4604 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4605 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4606 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4607 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4609 /* Update the free list. Do it so that new entries are added at
4610 the end of the free list. This makes some operations like
4612 for (i
= old_size
; i
< new_size
- 1; ++i
)
4613 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4615 if (!NILP (h
->next_free
))
4617 Lisp_Object last
, next
;
4619 last
= h
->next_free
;
4620 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4624 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4627 XSETFASTINT (h
->next_free
, old_size
);
4630 for (i
= 0; i
< old_size
; ++i
)
4631 if (!NILP (HASH_HASH (h
, i
)))
4633 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4634 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4635 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4636 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4642 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4643 the hash code of KEY. Value is the index of the entry in H
4644 matching KEY, or -1 if not found. */
4647 hash_lookup (h
, key
, hash
)
4648 struct Lisp_Hash_Table
*h
;
4653 int start_of_bucket
;
4656 hash_code
= h
->hashfn (h
, key
);
4660 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4661 idx
= HASH_INDEX (h
, start_of_bucket
);
4663 /* We need not gcpro idx since it's either an integer or nil. */
4666 int i
= XFASTINT (idx
);
4667 if (EQ (key
, HASH_KEY (h
, i
))
4669 && h
->cmpfn (h
, key
, hash_code
,
4670 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4672 idx
= HASH_NEXT (h
, i
);
4675 return NILP (idx
) ? -1 : XFASTINT (idx
);
4679 /* Put an entry into hash table H that associates KEY with VALUE.
4680 HASH is a previously computed hash code of KEY.
4681 Value is the index of the entry in H matching KEY. */
4684 hash_put (h
, key
, value
, hash
)
4685 struct Lisp_Hash_Table
*h
;
4686 Lisp_Object key
, value
;
4689 int start_of_bucket
, i
;
4691 xassert ((hash
& ~INTMASK
) == 0);
4693 /* Increment count after resizing because resizing may fail. */
4694 maybe_resize_hash_table (h
);
4695 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4697 /* Store key/value in the key_and_value vector. */
4698 i
= XFASTINT (h
->next_free
);
4699 h
->next_free
= HASH_NEXT (h
, i
);
4700 HASH_KEY (h
, i
) = key
;
4701 HASH_VALUE (h
, i
) = value
;
4703 /* Remember its hash code. */
4704 HASH_HASH (h
, i
) = make_number (hash
);
4706 /* Add new entry to its collision chain. */
4707 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4708 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4709 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4714 /* Remove the entry matching KEY from hash table H, if there is one. */
4717 hash_remove (h
, key
)
4718 struct Lisp_Hash_Table
*h
;
4722 int start_of_bucket
;
4723 Lisp_Object idx
, prev
;
4725 hash_code
= h
->hashfn (h
, key
);
4726 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4727 idx
= HASH_INDEX (h
, start_of_bucket
);
4730 /* We need not gcpro idx, prev since they're either integers or nil. */
4733 int i
= XFASTINT (idx
);
4735 if (EQ (key
, HASH_KEY (h
, i
))
4737 && h
->cmpfn (h
, key
, hash_code
,
4738 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4740 /* Take entry out of collision chain. */
4742 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4744 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4746 /* Clear slots in key_and_value and add the slots to
4748 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4749 HASH_NEXT (h
, i
) = h
->next_free
;
4750 h
->next_free
= make_number (i
);
4751 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4752 xassert (XINT (h
->count
) >= 0);
4758 idx
= HASH_NEXT (h
, i
);
4764 /* Clear hash table H. */
4768 struct Lisp_Hash_Table
*h
;
4770 if (XFASTINT (h
->count
) > 0)
4772 int i
, size
= HASH_TABLE_SIZE (h
);
4774 for (i
= 0; i
< size
; ++i
)
4776 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4777 HASH_KEY (h
, i
) = Qnil
;
4778 HASH_VALUE (h
, i
) = Qnil
;
4779 HASH_HASH (h
, i
) = Qnil
;
4782 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4783 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4785 h
->next_free
= make_number (0);
4786 h
->count
= make_number (0);
4792 /************************************************************************
4794 ************************************************************************/
4796 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4797 entries from the table that don't survive the current GC.
4798 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4799 non-zero if anything was marked. */
4802 sweep_weak_table (h
, remove_entries_p
)
4803 struct Lisp_Hash_Table
*h
;
4804 int remove_entries_p
;
4806 int bucket
, n
, marked
;
4808 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4811 for (bucket
= 0; bucket
< n
; ++bucket
)
4813 Lisp_Object idx
, next
, prev
;
4815 /* Follow collision chain, removing entries that
4816 don't survive this garbage collection. */
4818 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4820 int i
= XFASTINT (idx
);
4821 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4822 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4825 if (EQ (h
->weak
, Qkey
))
4826 remove_p
= !key_known_to_survive_p
;
4827 else if (EQ (h
->weak
, Qvalue
))
4828 remove_p
= !value_known_to_survive_p
;
4829 else if (EQ (h
->weak
, Qkey_or_value
))
4830 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4831 else if (EQ (h
->weak
, Qkey_and_value
))
4832 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4836 next
= HASH_NEXT (h
, i
);
4838 if (remove_entries_p
)
4842 /* Take out of collision chain. */
4844 HASH_INDEX (h
, bucket
) = next
;
4846 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4848 /* Add to free list. */
4849 HASH_NEXT (h
, i
) = h
->next_free
;
4852 /* Clear key, value, and hash. */
4853 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4854 HASH_HASH (h
, i
) = Qnil
;
4856 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4867 /* Make sure key and value survive. */
4868 if (!key_known_to_survive_p
)
4870 mark_object (HASH_KEY (h
, i
));
4874 if (!value_known_to_survive_p
)
4876 mark_object (HASH_VALUE (h
, i
));
4887 /* Remove elements from weak hash tables that don't survive the
4888 current garbage collection. Remove weak tables that don't survive
4889 from Vweak_hash_tables. Called from gc_sweep. */
4892 sweep_weak_hash_tables ()
4894 Lisp_Object table
, used
, next
;
4895 struct Lisp_Hash_Table
*h
;
4898 /* Mark all keys and values that are in use. Keep on marking until
4899 there is no more change. This is necessary for cases like
4900 value-weak table A containing an entry X -> Y, where Y is used in a
4901 key-weak table B, Z -> Y. If B comes after A in the list of weak
4902 tables, X -> Y might be removed from A, although when looking at B
4903 one finds that it shouldn't. */
4907 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4909 h
= XHASH_TABLE (table
);
4910 if (h
->size
& ARRAY_MARK_FLAG
)
4911 marked
|= sweep_weak_table (h
, 0);
4916 /* Remove tables and entries that aren't used. */
4917 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4919 h
= XHASH_TABLE (table
);
4920 next
= h
->next_weak
;
4922 if (h
->size
& ARRAY_MARK_FLAG
)
4924 /* TABLE is marked as used. Sweep its contents. */
4925 if (XFASTINT (h
->count
) > 0)
4926 sweep_weak_table (h
, 1);
4928 /* Add table to the list of used weak hash tables. */
4929 h
->next_weak
= used
;
4934 Vweak_hash_tables
= used
;
4939 /***********************************************************************
4940 Hash Code Computation
4941 ***********************************************************************/
4943 /* Maximum depth up to which to dive into Lisp structures. */
4945 #define SXHASH_MAX_DEPTH 3
4947 /* Maximum length up to which to take list and vector elements into
4950 #define SXHASH_MAX_LEN 7
4952 /* Combine two integers X and Y for hashing. */
4954 #define SXHASH_COMBINE(X, Y) \
4955 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4959 /* Return a hash for string PTR which has length LEN. The hash
4960 code returned is guaranteed to fit in a Lisp integer. */
4963 sxhash_string (ptr
, len
)
4967 unsigned char *p
= ptr
;
4968 unsigned char *end
= p
+ len
;
4977 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4980 return hash
& INTMASK
;
4984 /* Return a hash for list LIST. DEPTH is the current depth in the
4985 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4988 sxhash_list (list
, depth
)
4995 if (depth
< SXHASH_MAX_DEPTH
)
4997 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4998 list
= XCDR (list
), ++i
)
5000 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
5001 hash
= SXHASH_COMBINE (hash
, hash2
);
5008 /* Return a hash for vector VECTOR. DEPTH is the current depth in
5009 the Lisp structure. */
5012 sxhash_vector (vec
, depth
)
5016 unsigned hash
= XVECTOR (vec
)->size
;
5019 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5020 for (i
= 0; i
< n
; ++i
)
5022 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5023 hash
= SXHASH_COMBINE (hash
, hash2
);
5030 /* Return a hash for bool-vector VECTOR. */
5033 sxhash_bool_vector (vec
)
5036 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5039 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5040 for (i
= 0; i
< n
; ++i
)
5041 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5047 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5048 structure. Value is an unsigned integer clipped to INTMASK. */
5057 if (depth
> SXHASH_MAX_DEPTH
)
5060 switch (XTYPE (obj
))
5071 obj
= SYMBOL_NAME (obj
);
5075 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5078 /* This can be everything from a vector to an overlay. */
5079 case Lisp_Vectorlike
:
5081 /* According to the CL HyperSpec, two arrays are equal only if
5082 they are `eq', except for strings and bit-vectors. In
5083 Emacs, this works differently. We have to compare element
5085 hash
= sxhash_vector (obj
, depth
);
5086 else if (BOOL_VECTOR_P (obj
))
5087 hash
= sxhash_bool_vector (obj
);
5089 /* Others are `equal' if they are `eq', so let's take their
5095 hash
= sxhash_list (obj
, depth
);
5100 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5101 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5102 for (hash
= 0; p
< e
; ++p
)
5103 hash
= SXHASH_COMBINE (hash
, *p
);
5111 return hash
& INTMASK
;
5116 /***********************************************************************
5118 ***********************************************************************/
5121 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5122 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5126 unsigned hash
= sxhash (obj
, 0);;
5127 return make_number (hash
);
5131 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5132 doc
: /* Create and return a new hash table.
5134 Arguments are specified as keyword/argument pairs. The following
5135 arguments are defined:
5137 :test TEST -- TEST must be a symbol that specifies how to compare
5138 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5139 `equal'. User-supplied test and hash functions can be specified via
5140 `define-hash-table-test'.
5142 :size SIZE -- A hint as to how many elements will be put in the table.
5145 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5146 fills up. If REHASH-SIZE is an integer, add that many space. If it
5147 is a float, it must be > 1.0, and the new size is computed by
5148 multiplying the old size with that factor. Default is 1.5.
5150 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5151 Resize the hash table when ratio of the number of entries in the
5152 table. Default is 0.8.
5154 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5155 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5156 returned is a weak table. Key/value pairs are removed from a weak
5157 hash table when there are no non-weak references pointing to their
5158 key, value, one of key or value, or both key and value, depending on
5159 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5162 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5167 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5168 Lisp_Object user_test
, user_hash
;
5172 /* The vector `used' is used to keep track of arguments that
5173 have been consumed. */
5174 used
= (char *) alloca (nargs
* sizeof *used
);
5175 bzero (used
, nargs
* sizeof *used
);
5177 /* See if there's a `:test TEST' among the arguments. */
5178 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5179 test
= i
< 0 ? Qeql
: args
[i
];
5180 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5182 /* See if it is a user-defined test. */
5185 prop
= Fget (test
, Qhash_table_test
);
5186 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5187 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5189 user_test
= XCAR (prop
);
5190 user_hash
= XCAR (XCDR (prop
));
5193 user_test
= user_hash
= Qnil
;
5195 /* See if there's a `:size SIZE' argument. */
5196 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5197 size
= i
< 0 ? Qnil
: args
[i
];
5199 size
= make_number (DEFAULT_HASH_SIZE
);
5200 else if (!INTEGERP (size
) || XINT (size
) < 0)
5202 list2 (build_string ("Invalid hash table size"),
5205 /* Look for `:rehash-size SIZE'. */
5206 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5207 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5208 if (!NUMBERP (rehash_size
)
5209 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5210 || XFLOATINT (rehash_size
) <= 1.0)
5212 list2 (build_string ("Invalid hash table rehash size"),
5215 /* Look for `:rehash-threshold THRESHOLD'. */
5216 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5217 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5218 if (!FLOATP (rehash_threshold
)
5219 || XFLOATINT (rehash_threshold
) <= 0.0
5220 || XFLOATINT (rehash_threshold
) > 1.0)
5222 list2 (build_string ("Invalid hash table rehash threshold"),
5225 /* Look for `:weakness WEAK'. */
5226 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5227 weak
= i
< 0 ? Qnil
: args
[i
];
5229 weak
= Qkey_and_value
;
5232 && !EQ (weak
, Qvalue
)
5233 && !EQ (weak
, Qkey_or_value
)
5234 && !EQ (weak
, Qkey_and_value
))
5235 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5238 /* Now, all args should have been used up, or there's a problem. */
5239 for (i
= 0; i
< nargs
; ++i
)
5242 list2 (build_string ("Invalid argument list"), args
[i
]));
5244 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5245 user_test
, user_hash
);
5249 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5250 doc
: /* Return a copy of hash table TABLE. */)
5254 return copy_hash_table (check_hash_table (table
));
5258 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5259 doc
: /* Return the number of elements in TABLE. */)
5263 return check_hash_table (table
)->count
;
5267 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5268 Shash_table_rehash_size
, 1, 1, 0,
5269 doc
: /* Return the current rehash size of TABLE. */)
5273 return check_hash_table (table
)->rehash_size
;
5277 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5278 Shash_table_rehash_threshold
, 1, 1, 0,
5279 doc
: /* Return the current rehash threshold of TABLE. */)
5283 return check_hash_table (table
)->rehash_threshold
;
5287 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5288 doc
: /* Return the size of TABLE.
5289 The size can be used as an argument to `make-hash-table' to create
5290 a hash table than can hold as many elements of TABLE holds
5291 without need for resizing. */)
5295 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5296 return make_number (HASH_TABLE_SIZE (h
));
5300 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5301 doc
: /* Return the test TABLE uses. */)
5305 return check_hash_table (table
)->test
;
5309 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5311 doc
: /* Return the weakness of TABLE. */)
5315 return check_hash_table (table
)->weak
;
5319 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5320 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5324 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5328 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5329 doc
: /* Clear hash table TABLE. */)
5333 hash_clear (check_hash_table (table
));
5338 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5339 doc
: /* Look up KEY in TABLE and return its associated value.
5340 If KEY is not found, return DFLT which defaults to nil. */)
5342 Lisp_Object key
, table
, dflt
;
5344 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5345 int i
= hash_lookup (h
, key
, NULL
);
5346 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5350 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5351 doc
: /* Associate KEY with VALUE in hash table TABLE.
5352 If KEY is already present in table, replace its current value with
5355 Lisp_Object key
, value
, table
;
5357 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5361 i
= hash_lookup (h
, key
, &hash
);
5363 HASH_VALUE (h
, i
) = value
;
5365 hash_put (h
, key
, value
, hash
);
5371 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5372 doc
: /* Remove KEY from TABLE. */)
5374 Lisp_Object key
, table
;
5376 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5377 hash_remove (h
, key
);
5382 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5383 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5384 FUNCTION is called with 2 arguments KEY and VALUE. */)
5386 Lisp_Object function
, table
;
5388 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5389 Lisp_Object args
[3];
5392 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5393 if (!NILP (HASH_HASH (h
, i
)))
5396 args
[1] = HASH_KEY (h
, i
);
5397 args
[2] = HASH_VALUE (h
, i
);
5405 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5406 Sdefine_hash_table_test
, 3, 3, 0,
5407 doc
: /* Define a new hash table test with name NAME, a symbol.
5409 In hash tables created with NAME specified as test, use TEST to
5410 compare keys, and HASH for computing hash codes of keys.
5412 TEST must be a function taking two arguments and returning non-nil if
5413 both arguments are the same. HASH must be a function taking one
5414 argument and return an integer that is the hash code of the argument.
5415 Hash code computation should use the whole value range of integers,
5416 including negative integers. */)
5418 Lisp_Object name
, test
, hash
;
5420 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5425 /************************************************************************
5427 ************************************************************************/
5432 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5433 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5435 A message digest is a cryptographic checksum of a document, and the
5436 algorithm to calculate it is defined in RFC 1321.
5438 The two optional arguments START and END are character positions
5439 specifying for which part of OBJECT the message digest should be
5440 computed. If nil or omitted, the digest is computed for the whole
5443 The MD5 message digest is computed from the result of encoding the
5444 text in a coding system, not directly from the internal Emacs form of
5445 the text. The optional fourth argument CODING-SYSTEM specifies which
5446 coding system to encode the text with. It should be the same coding
5447 system that you used or will use when actually writing the text into a
5450 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5451 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5452 system would be chosen by default for writing this text into a file.
5454 If OBJECT is a string, the most preferred coding system (see the
5455 command `prefer-coding-system') is used.
5457 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5458 guesswork fails. Normally, an error is signaled in such case. */)
5459 (object
, start
, end
, coding_system
, noerror
)
5460 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5462 unsigned char digest
[16];
5463 unsigned char value
[33];
5467 int start_char
= 0, end_char
= 0;
5468 int start_byte
= 0, end_byte
= 0;
5470 register struct buffer
*bp
;
5473 if (STRINGP (object
))
5475 if (NILP (coding_system
))
5477 /* Decide the coding-system to encode the data with. */
5479 if (STRING_MULTIBYTE (object
))
5480 /* use default, we can't guess correct value */
5481 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5483 coding_system
= Qraw_text
;
5486 if (NILP (Fcoding_system_p (coding_system
)))
5488 /* Invalid coding system. */
5490 if (!NILP (noerror
))
5491 coding_system
= Qraw_text
;
5494 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5497 if (STRING_MULTIBYTE (object
))
5498 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5500 size
= SCHARS (object
);
5501 size_byte
= SBYTES (object
);
5505 CHECK_NUMBER (start
);
5507 start_char
= XINT (start
);
5512 start_byte
= string_char_to_byte (object
, start_char
);
5518 end_byte
= size_byte
;
5524 end_char
= XINT (end
);
5529 end_byte
= string_char_to_byte (object
, end_char
);
5532 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5533 args_out_of_range_3 (object
, make_number (start_char
),
5534 make_number (end_char
));
5538 struct buffer
*prev
= current_buffer
;
5540 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5542 CHECK_BUFFER (object
);
5544 bp
= XBUFFER (object
);
5545 if (bp
!= current_buffer
)
5546 set_buffer_internal (bp
);
5552 CHECK_NUMBER_COERCE_MARKER (start
);
5560 CHECK_NUMBER_COERCE_MARKER (end
);
5565 temp
= b
, b
= e
, e
= temp
;
5567 if (!(BEGV
<= b
&& e
<= ZV
))
5568 args_out_of_range (start
, end
);
5570 if (NILP (coding_system
))
5572 /* Decide the coding-system to encode the data with.
5573 See fileio.c:Fwrite-region */
5575 if (!NILP (Vcoding_system_for_write
))
5576 coding_system
= Vcoding_system_for_write
;
5579 int force_raw_text
= 0;
5581 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5582 if (NILP (coding_system
)
5583 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5585 coding_system
= Qnil
;
5586 if (NILP (current_buffer
->enable_multibyte_characters
))
5590 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5592 /* Check file-coding-system-alist. */
5593 Lisp_Object args
[4], val
;
5595 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5596 args
[3] = Fbuffer_file_name(object
);
5597 val
= Ffind_operation_coding_system (4, args
);
5598 if (CONSP (val
) && !NILP (XCDR (val
)))
5599 coding_system
= XCDR (val
);
5602 if (NILP (coding_system
)
5603 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5605 /* If we still have not decided a coding system, use the
5606 default value of buffer-file-coding-system. */
5607 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5611 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5612 /* Confirm that VAL can surely encode the current region. */
5613 coding_system
= call4 (Vselect_safe_coding_system_function
,
5614 make_number (b
), make_number (e
),
5615 coding_system
, Qnil
);
5618 coding_system
= Qraw_text
;
5621 if (NILP (Fcoding_system_p (coding_system
)))
5623 /* Invalid coding system. */
5625 if (!NILP (noerror
))
5626 coding_system
= Qraw_text
;
5629 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5633 object
= make_buffer_string (b
, e
, 0);
5634 if (prev
!= current_buffer
)
5635 set_buffer_internal (prev
);
5636 /* Discard the unwind protect for recovering the current
5640 if (STRING_MULTIBYTE (object
))
5641 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5644 md5_buffer (SDATA (object
) + start_byte
,
5645 SBYTES (object
) - (size_byte
- end_byte
),
5648 for (i
= 0; i
< 16; i
++)
5649 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5652 return make_string (value
, 32);
5659 /* Hash table stuff. */
5660 Qhash_table_p
= intern ("hash-table-p");
5661 staticpro (&Qhash_table_p
);
5662 Qeq
= intern ("eq");
5664 Qeql
= intern ("eql");
5666 Qequal
= intern ("equal");
5667 staticpro (&Qequal
);
5668 QCtest
= intern (":test");
5669 staticpro (&QCtest
);
5670 QCsize
= intern (":size");
5671 staticpro (&QCsize
);
5672 QCrehash_size
= intern (":rehash-size");
5673 staticpro (&QCrehash_size
);
5674 QCrehash_threshold
= intern (":rehash-threshold");
5675 staticpro (&QCrehash_threshold
);
5676 QCweakness
= intern (":weakness");
5677 staticpro (&QCweakness
);
5678 Qkey
= intern ("key");
5680 Qvalue
= intern ("value");
5681 staticpro (&Qvalue
);
5682 Qhash_table_test
= intern ("hash-table-test");
5683 staticpro (&Qhash_table_test
);
5684 Qkey_or_value
= intern ("key-or-value");
5685 staticpro (&Qkey_or_value
);
5686 Qkey_and_value
= intern ("key-and-value");
5687 staticpro (&Qkey_and_value
);
5690 defsubr (&Smake_hash_table
);
5691 defsubr (&Scopy_hash_table
);
5692 defsubr (&Shash_table_count
);
5693 defsubr (&Shash_table_rehash_size
);
5694 defsubr (&Shash_table_rehash_threshold
);
5695 defsubr (&Shash_table_size
);
5696 defsubr (&Shash_table_test
);
5697 defsubr (&Shash_table_weakness
);
5698 defsubr (&Shash_table_p
);
5699 defsubr (&Sclrhash
);
5700 defsubr (&Sgethash
);
5701 defsubr (&Sputhash
);
5702 defsubr (&Sremhash
);
5703 defsubr (&Smaphash
);
5704 defsubr (&Sdefine_hash_table_test
);
5706 Qstring_lessp
= intern ("string-lessp");
5707 staticpro (&Qstring_lessp
);
5708 Qprovide
= intern ("provide");
5709 staticpro (&Qprovide
);
5710 Qrequire
= intern ("require");
5711 staticpro (&Qrequire
);
5712 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5713 staticpro (&Qyes_or_no_p_history
);
5714 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5715 staticpro (&Qcursor_in_echo_area
);
5716 Qwidget_type
= intern ("widget-type");
5717 staticpro (&Qwidget_type
);
5719 staticpro (&string_char_byte_cache_string
);
5720 string_char_byte_cache_string
= Qnil
;
5722 require_nesting_list
= Qnil
;
5723 staticpro (&require_nesting_list
);
5725 Fset (Qyes_or_no_p_history
, Qnil
);
5727 DEFVAR_LISP ("features", &Vfeatures
,
5728 doc
: /* A list of symbols which are the features of the executing emacs.
5729 Used by `featurep' and `require', and altered by `provide'. */);
5731 Qsubfeatures
= intern ("subfeatures");
5732 staticpro (&Qsubfeatures
);
5734 #ifdef HAVE_LANGINFO_CODESET
5735 Qcodeset
= intern ("codeset");
5736 staticpro (&Qcodeset
);
5737 Qdays
= intern ("days");
5739 Qmonths
= intern ("months");
5740 staticpro (&Qmonths
);
5741 Qpaper
= intern ("paper");
5742 staticpro (&Qpaper
);
5743 #endif /* HAVE_LANGINFO_CODESET */
5745 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5746 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5747 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5748 invoked by mouse clicks and mouse menu items. */);
5751 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5752 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5753 This applies to commands from menus and tool bar buttons. The value of
5754 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5755 used if both `use-dialog-box' and this variable are non-nil. */);
5756 use_file_dialog
= 1;
5758 defsubr (&Sidentity
);
5761 defsubr (&Ssafe_length
);
5762 defsubr (&Sstring_bytes
);
5763 defsubr (&Sstring_equal
);
5764 defsubr (&Scompare_strings
);
5765 defsubr (&Sstring_lessp
);
5768 defsubr (&Svconcat
);
5769 defsubr (&Scopy_sequence
);
5770 defsubr (&Sstring_make_multibyte
);
5771 defsubr (&Sstring_make_unibyte
);
5772 defsubr (&Sstring_as_multibyte
);
5773 defsubr (&Sstring_as_unibyte
);
5774 defsubr (&Sstring_to_multibyte
);
5775 defsubr (&Scopy_alist
);
5776 defsubr (&Ssubstring
);
5777 defsubr (&Ssubstring_no_properties
);
5789 defsubr (&Snreverse
);
5790 defsubr (&Sreverse
);
5792 defsubr (&Splist_get
);
5793 defsubr (&Ssafe_plist_get
);
5795 defsubr (&Splist_put
);
5797 defsubr (&Slax_plist_get
);
5798 defsubr (&Slax_plist_put
);
5801 defsubr (&Sequal_including_properties
);
5802 defsubr (&Sfillarray
);
5803 defsubr (&Sclear_string
);
5804 defsubr (&Schar_table_subtype
);
5805 defsubr (&Schar_table_parent
);
5806 defsubr (&Sset_char_table_parent
);
5807 defsubr (&Schar_table_extra_slot
);
5808 defsubr (&Sset_char_table_extra_slot
);
5809 defsubr (&Schar_table_range
);
5810 defsubr (&Sset_char_table_range
);
5811 defsubr (&Sset_char_table_default
);
5812 defsubr (&Soptimize_char_table
);
5813 defsubr (&Smap_char_table
);
5817 defsubr (&Smapconcat
);
5818 defsubr (&Sy_or_n_p
);
5819 defsubr (&Syes_or_no_p
);
5820 defsubr (&Sload_average
);
5821 defsubr (&Sfeaturep
);
5822 defsubr (&Srequire
);
5823 defsubr (&Sprovide
);
5824 defsubr (&Splist_member
);
5825 defsubr (&Swidget_put
);
5826 defsubr (&Swidget_get
);
5827 defsubr (&Swidget_apply
);
5828 defsubr (&Sbase64_encode_region
);
5829 defsubr (&Sbase64_decode_region
);
5830 defsubr (&Sbase64_encode_string
);
5831 defsubr (&Sbase64_decode_string
);
5833 defsubr (&Slocale_info
);
5840 Vweak_hash_tables
= Qnil
;
5843 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5844 (do not change this comment) */