1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* On Mac OS, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 /* Nonzero enables use of a file dialog for file name
63 questions asked by mouse commands. */
66 extern int minibuffer_auto_raise
;
67 extern Lisp_Object minibuf_window
;
68 extern Lisp_Object Vlocale_coding_system
;
69 extern int load_in_progress
;
71 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
72 Lisp_Object Qyes_or_no_p_history
;
73 Lisp_Object Qcursor_in_echo_area
;
74 Lisp_Object Qwidget_type
;
75 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
77 extern Lisp_Object Qinput_method_function
;
79 static int internal_equal ();
81 extern long get_random ();
82 extern void seed_random ();
88 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
89 doc
: /* Return the argument unchanged. */)
96 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
97 doc
: /* Return a pseudo-random number.
98 All integers representable in Lisp are equally likely.
99 On most systems, this is 29 bits' worth.
100 With positive integer argument N, return random number in interval [0,N).
101 With argument t, set the random number seed from the current time and pid. */)
106 Lisp_Object lispy_val
;
107 unsigned long denominator
;
110 seed_random (getpid () + time (NULL
));
111 if (NATNUMP (n
) && XFASTINT (n
) != 0)
113 /* Try to take our random number from the higher bits of VAL,
114 not the lower, since (says Gentzel) the low bits of `random'
115 are less random than the higher ones. We do this by using the
116 quotient rather than the remainder. At the high end of the RNG
117 it's possible to get a quotient larger than n; discarding
118 these values eliminates the bias that would otherwise appear
119 when using a large n. */
120 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
122 val
= get_random () / denominator
;
123 while (val
>= XFASTINT (n
));
127 XSETINT (lispy_val
, val
);
131 /* Random data-structure functions */
133 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
134 doc
: /* Return the length of vector, list or string SEQUENCE.
135 A byte-code function object is also allowed.
136 If the string contains multibyte characters, this is not necessarily
137 the number of bytes in the string; it is the number of characters.
138 To get the number of bytes, use `string-bytes'. */)
140 register Lisp_Object sequence
;
142 register Lisp_Object val
;
146 if (STRINGP (sequence
))
147 XSETFASTINT (val
, SCHARS (sequence
));
148 else if (VECTORP (sequence
))
149 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
150 else if (SUB_CHAR_TABLE_P (sequence
))
151 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
152 else if (CHAR_TABLE_P (sequence
))
153 XSETFASTINT (val
, MAX_CHAR
);
154 else if (BOOL_VECTOR_P (sequence
))
155 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
156 else if (COMPILEDP (sequence
))
157 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
158 else if (CONSP (sequence
))
161 while (CONSP (sequence
))
163 sequence
= XCDR (sequence
);
166 if (!CONSP (sequence
))
169 sequence
= XCDR (sequence
);
174 if (!NILP (sequence
))
175 wrong_type_argument (Qlistp
, sequence
);
177 val
= make_number (i
);
179 else if (NILP (sequence
))
180 XSETFASTINT (val
, 0);
183 sequence
= wrong_type_argument (Qsequencep
, sequence
);
189 /* This does not check for quits. That is safe
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 ("safe-get", Fsafe_get
, Ssafe_get
, 2, 2, 0,
2055 doc
: /* Return the value of SYMBOL's PROPNAME property.
2056 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.
2057 This function never signals an error. */)
2059 Lisp_Object symbol
, propname
;
2061 if (!SYMBOLP (symbol
))
2063 return Fsafe_plist_get (XSYMBOL (symbol
)->plist
, propname
);
2066 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2067 doc
: /* Change value in PLIST of PROP to VAL.
2068 PLIST is a property list, which is a list of the form
2069 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2070 If PROP is already a property on the list, its value is set to VAL,
2071 otherwise the new PROP VAL pair is added. The new plist is returned;
2072 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2073 The PLIST is modified by side effects. */)
2076 register Lisp_Object prop
;
2079 register Lisp_Object tail
, prev
;
2080 Lisp_Object newcell
;
2082 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2083 tail
= XCDR (XCDR (tail
)))
2085 if (EQ (prop
, XCAR (tail
)))
2087 Fsetcar (XCDR (tail
), val
);
2094 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2098 Fsetcdr (XCDR (prev
), newcell
);
2102 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2103 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2104 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2105 (symbol
, propname
, value
)
2106 Lisp_Object symbol
, propname
, value
;
2108 CHECK_SYMBOL (symbol
);
2109 XSYMBOL (symbol
)->plist
2110 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2114 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2115 doc
: /* Extract a value from a property list, comparing with `equal'.
2116 PLIST is a property list, which is a list of the form
2117 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2118 corresponding to the given PROP, or nil if PROP is not
2119 one of the properties on the list. */)
2127 CONSP (tail
) && CONSP (XCDR (tail
));
2128 tail
= XCDR (XCDR (tail
)))
2130 if (! NILP (Fequal (prop
, XCAR (tail
))))
2131 return XCAR (XCDR (tail
));
2137 wrong_type_argument (Qlistp
, prop
);
2142 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2143 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2144 PLIST is a property list, which is a list of the form
2145 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2146 If PROP is already a property on the list, its value is set to VAL,
2147 otherwise the new PROP VAL pair is added. The new plist is returned;
2148 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2149 The PLIST is modified by side effects. */)
2152 register Lisp_Object prop
;
2155 register Lisp_Object tail
, prev
;
2156 Lisp_Object newcell
;
2158 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2159 tail
= XCDR (XCDR (tail
)))
2161 if (! NILP (Fequal (prop
, XCAR (tail
))))
2163 Fsetcar (XCDR (tail
), val
);
2170 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2174 Fsetcdr (XCDR (prev
), newcell
);
2178 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2179 doc
: /* Return t if the two args are the same Lisp object.
2180 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2182 Lisp_Object obj1
, obj2
;
2185 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2187 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2190 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2191 doc
: /* Return t if two Lisp objects have similar structure and contents.
2192 They must have the same data type.
2193 Conses are compared by comparing the cars and the cdrs.
2194 Vectors and strings are compared element by element.
2195 Numbers are compared by value, but integers cannot equal floats.
2196 (Use `=' if you want integers and floats to be able to be equal.)
2197 Symbols must match exactly. */)
2199 register Lisp_Object o1
, o2
;
2201 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2204 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2205 doc
: /* Return t if two Lisp objects have similar structure and contents.
2206 This is like `equal' except that it compares the text properties
2207 of strings. (`equal' ignores text properties.) */)
2209 register Lisp_Object o1
, o2
;
2211 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2214 /* DEPTH is current depth of recursion. Signal an error if it
2216 PROPS, if non-nil, means compare string text properties too. */
2219 internal_equal (o1
, o2
, depth
, props
)
2220 register Lisp_Object o1
, o2
;
2224 error ("Stack overflow in equal");
2230 if (XTYPE (o1
) != XTYPE (o2
))
2239 d1
= extract_float (o1
);
2240 d2
= extract_float (o2
);
2241 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2242 though they are not =. */
2243 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2247 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2254 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2258 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2260 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2263 o1
= XOVERLAY (o1
)->plist
;
2264 o2
= XOVERLAY (o2
)->plist
;
2269 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2270 && (XMARKER (o1
)->buffer
== 0
2271 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2275 case Lisp_Vectorlike
:
2278 EMACS_INT size
= XVECTOR (o1
)->size
;
2279 /* Pseudovectors have the type encoded in the size field, so this test
2280 actually checks that the objects have the same type as well as the
2282 if (XVECTOR (o2
)->size
!= size
)
2284 /* Boolvectors are compared much like strings. */
2285 if (BOOL_VECTOR_P (o1
))
2288 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2289 / BOOL_VECTOR_BITS_PER_CHAR
);
2291 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2293 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2298 if (WINDOW_CONFIGURATIONP (o1
))
2299 return compare_window_configurations (o1
, o2
, 0);
2301 /* Aside from them, only true vectors, char-tables, and compiled
2302 functions are sensible to compare, so eliminate the others now. */
2303 if (size
& PSEUDOVECTOR_FLAG
)
2305 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2307 size
&= PSEUDOVECTOR_SIZE_MASK
;
2309 for (i
= 0; i
< size
; i
++)
2312 v1
= XVECTOR (o1
)->contents
[i
];
2313 v2
= XVECTOR (o2
)->contents
[i
];
2314 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2322 if (SCHARS (o1
) != SCHARS (o2
))
2324 if (SBYTES (o1
) != SBYTES (o2
))
2326 if (bcmp (SDATA (o1
), SDATA (o2
),
2329 if (props
&& !compare_string_intervals (o1
, o2
))
2335 case Lisp_Type_Limit
:
2342 extern Lisp_Object
Fmake_char_internal ();
2344 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2345 doc
: /* Store each element of ARRAY with ITEM.
2346 ARRAY is a vector, string, char-table, or bool-vector. */)
2348 Lisp_Object array
, item
;
2350 register int size
, index
, charval
;
2352 if (VECTORP (array
))
2354 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2355 size
= XVECTOR (array
)->size
;
2356 for (index
= 0; index
< size
; index
++)
2359 else if (CHAR_TABLE_P (array
))
2361 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2362 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2363 for (index
= 0; index
< size
; index
++)
2365 XCHAR_TABLE (array
)->defalt
= Qnil
;
2367 else if (STRINGP (array
))
2369 register unsigned char *p
= SDATA (array
);
2370 CHECK_NUMBER (item
);
2371 charval
= XINT (item
);
2372 size
= SCHARS (array
);
2373 if (STRING_MULTIBYTE (array
))
2375 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2376 int len
= CHAR_STRING (charval
, str
);
2377 int size_byte
= SBYTES (array
);
2378 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2381 if (size
!= size_byte
)
2384 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2385 if (len
!= this_len
)
2386 error ("Attempt to change byte length of a string");
2389 for (i
= 0; i
< size_byte
; i
++)
2390 *p
++ = str
[i
% len
];
2393 for (index
= 0; index
< size
; index
++)
2396 else if (BOOL_VECTOR_P (array
))
2398 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2400 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2401 / BOOL_VECTOR_BITS_PER_CHAR
);
2403 charval
= (! NILP (item
) ? -1 : 0);
2404 for (index
= 0; index
< size_in_chars
- 1; index
++)
2406 if (index
< size_in_chars
)
2408 /* Mask out bits beyond the vector size. */
2409 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2410 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2416 array
= wrong_type_argument (Qarrayp
, array
);
2422 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2424 doc
: /* Clear the contents of STRING.
2425 This makes STRING unibyte and may change its length. */)
2430 CHECK_STRING (string
);
2431 len
= SBYTES (string
);
2432 bzero (SDATA (string
), len
);
2433 STRING_SET_CHARS (string
, len
);
2434 STRING_SET_UNIBYTE (string
);
2438 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2440 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2442 Lisp_Object char_table
;
2444 CHECK_CHAR_TABLE (char_table
);
2446 return XCHAR_TABLE (char_table
)->purpose
;
2449 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2451 doc
: /* Return the parent char-table of CHAR-TABLE.
2452 The value is either nil or another char-table.
2453 If CHAR-TABLE holds nil for a given character,
2454 then the actual applicable value is inherited from the parent char-table
2455 \(or from its parents, if necessary). */)
2457 Lisp_Object char_table
;
2459 CHECK_CHAR_TABLE (char_table
);
2461 return XCHAR_TABLE (char_table
)->parent
;
2464 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2466 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2467 Return PARENT. PARENT must be either nil or another char-table. */)
2468 (char_table
, parent
)
2469 Lisp_Object char_table
, parent
;
2473 CHECK_CHAR_TABLE (char_table
);
2477 CHECK_CHAR_TABLE (parent
);
2479 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2480 if (EQ (temp
, char_table
))
2481 error ("Attempt to make a chartable be its own parent");
2484 XCHAR_TABLE (char_table
)->parent
= parent
;
2489 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2491 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2493 Lisp_Object char_table
, n
;
2495 CHECK_CHAR_TABLE (char_table
);
2498 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2499 args_out_of_range (char_table
, n
);
2501 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2504 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2505 Sset_char_table_extra_slot
,
2507 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2508 (char_table
, n
, value
)
2509 Lisp_Object char_table
, n
, value
;
2511 CHECK_CHAR_TABLE (char_table
);
2514 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2515 args_out_of_range (char_table
, n
);
2517 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2520 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2522 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2523 RANGE should be nil (for the default value)
2524 a vector which identifies a character set or a row of a character set,
2525 a character set name, or a character code. */)
2527 Lisp_Object char_table
, range
;
2529 CHECK_CHAR_TABLE (char_table
);
2531 if (EQ (range
, Qnil
))
2532 return XCHAR_TABLE (char_table
)->defalt
;
2533 else if (INTEGERP (range
))
2534 return Faref (char_table
, range
);
2535 else if (SYMBOLP (range
))
2537 Lisp_Object charset_info
;
2539 charset_info
= Fget (range
, Qcharset
);
2540 CHECK_VECTOR (charset_info
);
2542 return Faref (char_table
,
2543 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2546 else if (VECTORP (range
))
2548 if (XVECTOR (range
)->size
== 1)
2549 return Faref (char_table
,
2550 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2553 int size
= XVECTOR (range
)->size
;
2554 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2555 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2556 size
<= 1 ? Qnil
: val
[1],
2557 size
<= 2 ? Qnil
: val
[2]);
2558 return Faref (char_table
, ch
);
2562 error ("Invalid RANGE argument to `char-table-range'");
2566 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2568 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2569 RANGE should be t (for all characters), nil (for the default value),
2570 a character set, a vector which identifies a character set, a row of a
2571 character set, or a character code. Return VALUE. */)
2572 (char_table
, range
, value
)
2573 Lisp_Object char_table
, range
, value
;
2577 CHECK_CHAR_TABLE (char_table
);
2580 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2582 /* Don't set these special slots used for default values of
2583 ascii, eight-bit-control, and eight-bit-graphic. */
2584 if (i
!= CHAR_TABLE_DEFAULT_SLOT_ASCII
2585 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2586 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
)
2587 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2589 else if (EQ (range
, Qnil
))
2590 XCHAR_TABLE (char_table
)->defalt
= value
;
2591 else if (SYMBOLP (range
))
2593 Lisp_Object charset_info
;
2596 charset_info
= Fget (range
, Qcharset
);
2597 if (! VECTORP (charset_info
)
2598 || ! NATNUMP (AREF (charset_info
, 0))
2599 || (charset_id
= XINT (AREF (charset_info
, 0)),
2600 ! CHARSET_DEFINED_P (charset_id
)))
2601 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2603 if (charset_id
== CHARSET_ASCII
)
2604 for (i
= 0; i
< 128; i
++)
2605 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2606 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2607 for (i
= 128; i
< 160; i
++)
2608 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2609 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2610 for (i
= 160; i
< 256; i
++)
2611 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2613 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2615 else if (INTEGERP (range
))
2616 Faset (char_table
, range
, value
);
2617 else if (VECTORP (range
))
2619 int size
= XVECTOR (range
)->size
;
2620 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2621 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2622 size
<= 1 ? Qnil
: val
[1],
2623 size
<= 2 ? Qnil
: val
[2]);
2624 Faset (char_table
, ch
, value
);
2627 error ("Invalid RANGE argument to `set-char-table-range'");
2632 DEFUN ("set-char-table-default", Fset_char_table_default
,
2633 Sset_char_table_default
, 3, 3, 0,
2634 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2635 The generic character specifies the group of characters.
2636 If CH is a normal character, set the default value for a group of
2637 characters to which CH belongs.
2638 See also the documentation of `make-char'. */)
2639 (char_table
, ch
, value
)
2640 Lisp_Object char_table
, ch
, value
;
2642 int c
, charset
, code1
, code2
;
2645 CHECK_CHAR_TABLE (char_table
);
2649 SPLIT_CHAR (c
, charset
, code1
, code2
);
2651 /* Since we may want to set the default value for a character set
2652 not yet defined, we check only if the character set is in the
2653 valid range or not, instead of it is already defined or not. */
2654 if (! CHARSET_VALID_P (charset
))
2655 invalid_character (c
);
2657 if (SINGLE_BYTE_CHAR_P (c
))
2659 /* We use special slots for the default values of single byte
2662 = (c
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2663 : c
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2664 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2666 return (XCHAR_TABLE (char_table
)->contents
[default_slot
] = value
);
2669 /* Even if C is not a generic char, we had better behave as if a
2670 generic char is specified. */
2671 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2673 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2674 if (! SUB_CHAR_TABLE_P (temp
))
2676 temp
= make_sub_char_table (temp
);
2677 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = temp
;
2681 XCHAR_TABLE (temp
)->defalt
= value
;
2685 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2686 if (SUB_CHAR_TABLE_P (temp
))
2687 XCHAR_TABLE (temp
)->defalt
= value
;
2689 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2693 /* Look up the element in TABLE at index CH,
2694 and return it as an integer.
2695 If the element is nil, return CH itself.
2696 (Actually we do that for any non-integer.) */
2699 char_table_translate (table
, ch
)
2704 value
= Faref (table
, make_number (ch
));
2705 if (! INTEGERP (value
))
2707 return XINT (value
);
2711 optimize_sub_char_table (table
, chars
)
2719 from
= 33, to
= 127;
2721 from
= 32, to
= 128;
2723 if (!SUB_CHAR_TABLE_P (*table
))
2725 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2726 for (; from
< to
; from
++)
2727 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2732 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2733 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2741 CHECK_CHAR_TABLE (table
);
2743 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2745 elt
= XCHAR_TABLE (table
)->contents
[i
];
2746 if (!SUB_CHAR_TABLE_P (elt
))
2748 dim
= CHARSET_DIMENSION (i
- 128);
2750 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2751 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2752 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2758 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2759 character or group of characters that share a value.
2760 DEPTH is the current depth in the originally specified
2761 chartable, and INDICES contains the vector indices
2762 for the levels our callers have descended.
2764 ARG is passed to C_FUNCTION when that is called. */
2767 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2768 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2769 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2773 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2775 GCPRO4 (arg
, table
, subtable
, function
);
2779 /* At first, handle ASCII and 8-bit European characters. */
2780 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2782 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2784 elt
= XCHAR_TABLE (subtable
)->defalt
;
2786 elt
= Faref (subtable
, make_number (i
));
2788 (*c_function
) (arg
, make_number (i
), elt
);
2790 call2 (function
, make_number (i
), elt
);
2792 #if 0 /* If the char table has entries for higher characters,
2793 we should report them. */
2794 if (NILP (current_buffer
->enable_multibyte_characters
))
2800 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2804 int charset
= XFASTINT (indices
[0]) - 128;
2807 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2808 if (CHARSET_CHARS (charset
) == 94)
2817 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2818 XSETFASTINT (indices
[depth
], i
);
2819 charset
= XFASTINT (indices
[0]) - 128;
2821 && (!CHARSET_DEFINED_P (charset
)
2822 || charset
== CHARSET_8_BIT_CONTROL
2823 || charset
== CHARSET_8_BIT_GRAPHIC
))
2826 if (SUB_CHAR_TABLE_P (elt
))
2829 error ("Too deep char table");
2830 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2836 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2837 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2838 c
= MAKE_CHAR (charset
, c1
, c2
);
2841 elt
= XCHAR_TABLE (subtable
)->defalt
;
2843 elt
= Faref (table
, make_number (c
));
2846 (*c_function
) (arg
, make_number (c
), elt
);
2848 call2 (function
, make_number (c
), elt
);
2854 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2856 void_call2 (a
, b
, c
)
2857 Lisp_Object a
, b
, c
;
2862 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2864 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2865 FUNCTION is called with two arguments--a key and a value.
2866 The key is always a possible IDX argument to `aref'. */)
2867 (function
, char_table
)
2868 Lisp_Object function
, char_table
;
2870 /* The depth of char table is at most 3. */
2871 Lisp_Object indices
[3];
2873 CHECK_CHAR_TABLE (char_table
);
2875 /* When Lisp_Object is represented as a union, `call2' cannot directly
2876 be passed to map_char_table because it returns a Lisp_Object rather
2877 than returning nothing.
2878 Casting leads to crashes on some architectures. -stef */
2879 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2883 /* Return a value for character C in char-table TABLE. Store the
2884 actual index for that value in *IDX. Ignore the default value of
2888 char_table_ref_and_index (table
, c
, idx
)
2892 int charset
, c1
, c2
;
2895 if (SINGLE_BYTE_CHAR_P (c
))
2898 return XCHAR_TABLE (table
)->contents
[c
];
2900 SPLIT_CHAR (c
, charset
, c1
, c2
);
2901 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2902 *idx
= MAKE_CHAR (charset
, 0, 0);
2903 if (!SUB_CHAR_TABLE_P (elt
))
2905 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2906 return XCHAR_TABLE (elt
)->defalt
;
2907 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2908 *idx
= MAKE_CHAR (charset
, c1
, 0);
2909 if (!SUB_CHAR_TABLE_P (elt
))
2911 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2912 return XCHAR_TABLE (elt
)->defalt
;
2914 return XCHAR_TABLE (elt
)->contents
[c2
];
2924 Lisp_Object args
[2];
2927 return Fnconc (2, args
);
2929 return Fnconc (2, &s1
);
2930 #endif /* NO_ARG_ARRAY */
2933 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2934 doc
: /* Concatenate any number of lists by altering them.
2935 Only the last argument is not altered, and need not be a list.
2936 usage: (nconc &rest LISTS) */)
2941 register int argnum
;
2942 register Lisp_Object tail
, tem
, val
;
2946 for (argnum
= 0; argnum
< nargs
; argnum
++)
2949 if (NILP (tem
)) continue;
2954 if (argnum
+ 1 == nargs
) break;
2957 tem
= wrong_type_argument (Qlistp
, tem
);
2966 tem
= args
[argnum
+ 1];
2967 Fsetcdr (tail
, tem
);
2969 args
[argnum
+ 1] = tail
;
2975 /* This is the guts of all mapping functions.
2976 Apply FN to each element of SEQ, one by one,
2977 storing the results into elements of VALS, a C vector of Lisp_Objects.
2978 LENI is the length of VALS, which should also be the length of SEQ. */
2981 mapcar1 (leni
, vals
, fn
, seq
)
2984 Lisp_Object fn
, seq
;
2986 register Lisp_Object tail
;
2989 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2993 /* Don't let vals contain any garbage when GC happens. */
2994 for (i
= 0; i
< leni
; i
++)
2997 GCPRO3 (dummy
, fn
, seq
);
2999 gcpro1
.nvars
= leni
;
3003 /* We need not explicitly protect `tail' because it is used only on lists, and
3004 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
3008 for (i
= 0; i
< leni
; i
++)
3010 dummy
= XVECTOR (seq
)->contents
[i
];
3011 dummy
= call1 (fn
, dummy
);
3016 else if (BOOL_VECTOR_P (seq
))
3018 for (i
= 0; i
< leni
; i
++)
3021 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
3022 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
3027 dummy
= call1 (fn
, dummy
);
3032 else if (STRINGP (seq
))
3036 for (i
= 0, i_byte
= 0; i
< leni
;)
3041 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3042 XSETFASTINT (dummy
, c
);
3043 dummy
= call1 (fn
, dummy
);
3045 vals
[i_before
] = dummy
;
3048 else /* Must be a list, since Flength did not get an error */
3051 for (i
= 0; i
< leni
; i
++)
3053 dummy
= call1 (fn
, Fcar (tail
));
3063 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3064 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3065 In between each pair of results, stick in SEPARATOR. Thus, " " as
3066 SEPARATOR results in spaces between the values returned by FUNCTION.
3067 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3068 (function
, sequence
, separator
)
3069 Lisp_Object function
, sequence
, separator
;
3074 register Lisp_Object
*args
;
3076 struct gcpro gcpro1
;
3080 len
= Flength (sequence
);
3082 nargs
= leni
+ leni
- 1;
3083 if (nargs
< 0) return build_string ("");
3085 SAFE_ALLOCA_LISP (args
, nargs
);
3088 mapcar1 (leni
, args
, function
, sequence
);
3091 for (i
= leni
- 1; i
>= 0; i
--)
3092 args
[i
+ i
] = args
[i
];
3094 for (i
= 1; i
< nargs
; i
+= 2)
3095 args
[i
] = separator
;
3097 ret
= Fconcat (nargs
, args
);
3103 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3104 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3105 The result is a list just as long as SEQUENCE.
3106 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3107 (function
, sequence
)
3108 Lisp_Object function
, sequence
;
3110 register Lisp_Object len
;
3112 register Lisp_Object
*args
;
3116 len
= Flength (sequence
);
3117 leni
= XFASTINT (len
);
3119 SAFE_ALLOCA_LISP (args
, leni
);
3121 mapcar1 (leni
, args
, function
, sequence
);
3123 ret
= Flist (leni
, args
);
3129 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3130 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3131 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3132 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3133 (function
, sequence
)
3134 Lisp_Object function
, sequence
;
3138 leni
= XFASTINT (Flength (sequence
));
3139 mapcar1 (leni
, 0, function
, sequence
);
3144 /* Anything that calls this function must protect from GC! */
3146 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3147 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3148 Takes one argument, which is the string to display to ask the question.
3149 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3150 No confirmation of the answer is requested; a single character is enough.
3151 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3152 the bindings in `query-replace-map'; see the documentation of that variable
3153 for more information. In this case, the useful bindings are `act', `skip',
3154 `recenter', and `quit'.\)
3156 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3157 is nil and `use-dialog-box' is non-nil. */)
3161 register Lisp_Object obj
, key
, def
, map
;
3162 register int answer
;
3163 Lisp_Object xprompt
;
3164 Lisp_Object args
[2];
3165 struct gcpro gcpro1
, gcpro2
;
3166 int count
= SPECPDL_INDEX ();
3168 specbind (Qcursor_in_echo_area
, Qt
);
3170 map
= Fsymbol_value (intern ("query-replace-map"));
3172 CHECK_STRING (prompt
);
3174 GCPRO2 (prompt
, xprompt
);
3176 #ifdef HAVE_X_WINDOWS
3177 if (display_hourglass_p
)
3178 cancel_hourglass ();
3185 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3189 Lisp_Object pane
, menu
;
3190 redisplay_preserve_echo_area (3);
3191 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3192 Fcons (Fcons (build_string ("No"), Qnil
),
3194 menu
= Fcons (prompt
, pane
);
3195 obj
= Fx_popup_dialog (Qt
, menu
);
3196 answer
= !NILP (obj
);
3199 #endif /* HAVE_MENUS */
3200 cursor_in_echo_area
= 1;
3201 choose_minibuf_frame ();
3204 Lisp_Object pargs
[3];
3206 /* Colorize prompt according to `minibuffer-prompt' face. */
3207 pargs
[0] = build_string ("%s(y or n) ");
3208 pargs
[1] = intern ("face");
3209 pargs
[2] = intern ("minibuffer-prompt");
3210 args
[0] = Fpropertize (3, pargs
);
3215 if (minibuffer_auto_raise
)
3217 Lisp_Object mini_frame
;
3219 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3221 Fraise_frame (mini_frame
);
3224 obj
= read_filtered_event (1, 0, 0, 0);
3225 cursor_in_echo_area
= 0;
3226 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3229 key
= Fmake_vector (make_number (1), obj
);
3230 def
= Flookup_key (map
, key
, Qt
);
3232 if (EQ (def
, intern ("skip")))
3237 else if (EQ (def
, intern ("act")))
3242 else if (EQ (def
, intern ("recenter")))
3248 else if (EQ (def
, intern ("quit")))
3250 /* We want to exit this command for exit-prefix,
3251 and this is the only way to do it. */
3252 else if (EQ (def
, intern ("exit-prefix")))
3257 /* If we don't clear this, then the next call to read_char will
3258 return quit_char again, and we'll enter an infinite loop. */
3263 if (EQ (xprompt
, prompt
))
3265 args
[0] = build_string ("Please answer y or n. ");
3267 xprompt
= Fconcat (2, args
);
3272 if (! noninteractive
)
3274 cursor_in_echo_area
= -1;
3275 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3279 unbind_to (count
, Qnil
);
3280 return answer
? Qt
: Qnil
;
3283 /* This is how C code calls `yes-or-no-p' and allows the user
3286 Anything that calls this function must protect from GC! */
3289 do_yes_or_no_p (prompt
)
3292 return call1 (intern ("yes-or-no-p"), prompt
);
3295 /* Anything that calls this function must protect from GC! */
3297 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3298 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3299 Takes one argument, which is the string to display to ask the question.
3300 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3301 The user must confirm the answer with RET,
3302 and can edit it until it has been confirmed.
3304 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3305 is nil, and `use-dialog-box' is non-nil. */)
3309 register Lisp_Object ans
;
3310 Lisp_Object args
[2];
3311 struct gcpro gcpro1
;
3313 CHECK_STRING (prompt
);
3316 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3320 Lisp_Object pane
, menu
, obj
;
3321 redisplay_preserve_echo_area (4);
3322 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3323 Fcons (Fcons (build_string ("No"), Qnil
),
3326 menu
= Fcons (prompt
, pane
);
3327 obj
= Fx_popup_dialog (Qt
, menu
);
3331 #endif /* HAVE_MENUS */
3334 args
[1] = build_string ("(yes or no) ");
3335 prompt
= Fconcat (2, args
);
3341 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3342 Qyes_or_no_p_history
, Qnil
,
3344 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3349 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3357 message ("Please answer yes or no.");
3358 Fsleep_for (make_number (2), Qnil
);
3362 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3363 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3365 Each of the three load averages is multiplied by 100, then converted
3368 When USE-FLOATS is non-nil, floats will be used instead of integers.
3369 These floats are not multiplied by 100.
3371 If the 5-minute or 15-minute load averages are not available, return a
3372 shortened list, containing only those averages which are available.
3374 An error is thrown if the load average can't be obtained. In some
3375 cases making it work would require Emacs being installed setuid or
3376 setgid so that it can read kernel information, and that usually isn't
3379 Lisp_Object use_floats
;
3382 int loads
= getloadavg (load_ave
, 3);
3383 Lisp_Object ret
= Qnil
;
3386 error ("load-average not implemented for this operating system");
3390 Lisp_Object load
= (NILP (use_floats
) ?
3391 make_number ((int) (100.0 * load_ave
[loads
]))
3392 : make_float (load_ave
[loads
]));
3393 ret
= Fcons (load
, ret
);
3399 Lisp_Object Vfeatures
, Qsubfeatures
;
3400 extern Lisp_Object Vafter_load_alist
;
3402 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3403 doc
: /* Returns t if FEATURE is present in this Emacs.
3405 Use this to conditionalize execution of lisp code based on the
3406 presence or absence of emacs or environment extensions.
3407 Use `provide' to declare that a feature is available. This function
3408 looks at the value of the variable `features'. The optional argument
3409 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3410 (feature
, subfeature
)
3411 Lisp_Object feature
, subfeature
;
3413 register Lisp_Object tem
;
3414 CHECK_SYMBOL (feature
);
3415 tem
= Fmemq (feature
, Vfeatures
);
3416 if (!NILP (tem
) && !NILP (subfeature
))
3417 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3418 return (NILP (tem
)) ? Qnil
: Qt
;
3421 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3422 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3423 The optional argument SUBFEATURES should be a list of symbols listing
3424 particular subfeatures supported in this version of FEATURE. */)
3425 (feature
, subfeatures
)
3426 Lisp_Object feature
, subfeatures
;
3428 register Lisp_Object tem
;
3429 CHECK_SYMBOL (feature
);
3430 CHECK_LIST (subfeatures
);
3431 if (!NILP (Vautoload_queue
))
3432 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3433 tem
= Fmemq (feature
, Vfeatures
);
3435 Vfeatures
= Fcons (feature
, Vfeatures
);
3436 if (!NILP (subfeatures
))
3437 Fput (feature
, Qsubfeatures
, subfeatures
);
3438 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3440 /* Run any load-hooks for this file. */
3441 tem
= Fassq (feature
, Vafter_load_alist
);
3443 Fprogn (XCDR (tem
));
3448 /* `require' and its subroutines. */
3450 /* List of features currently being require'd, innermost first. */
3452 Lisp_Object require_nesting_list
;
3455 require_unwind (old_value
)
3456 Lisp_Object old_value
;
3458 return require_nesting_list
= old_value
;
3461 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3462 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3463 If FEATURE is not a member of the list `features', then the feature
3464 is not loaded; so load the file FILENAME.
3465 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3466 and `load' will try to load this name appended with the suffix `.elc' or
3467 `.el', in that order. The name without appended suffix will not be used.
3468 If the optional third argument NOERROR is non-nil,
3469 then return nil if the file is not found instead of signaling an error.
3470 Normally the return value is FEATURE.
3471 The normal messages at start and end of loading FILENAME are suppressed. */)
3472 (feature
, filename
, noerror
)
3473 Lisp_Object feature
, filename
, noerror
;
3475 register Lisp_Object tem
;
3476 struct gcpro gcpro1
, gcpro2
;
3478 CHECK_SYMBOL (feature
);
3480 /* Record the presence of `require' in this file
3481 even if the feature specified is already loaded.
3482 But not more than once in any file,
3483 and not when we aren't loading a file. */
3484 if (load_in_progress
)
3486 tem
= Fcons (Qrequire
, feature
);
3487 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3488 LOADHIST_ATTACH (tem
);
3490 tem
= Fmemq (feature
, Vfeatures
);
3494 int count
= SPECPDL_INDEX ();
3497 /* This is to make sure that loadup.el gives a clear picture
3498 of what files are preloaded and when. */
3499 if (! NILP (Vpurify_flag
))
3500 error ("(require %s) while preparing to dump",
3501 SDATA (SYMBOL_NAME (feature
)));
3503 /* A certain amount of recursive `require' is legitimate,
3504 but if we require the same feature recursively 3 times,
3506 tem
= require_nesting_list
;
3507 while (! NILP (tem
))
3509 if (! NILP (Fequal (feature
, XCAR (tem
))))
3514 error ("Recursive `require' for feature `%s'",
3515 SDATA (SYMBOL_NAME (feature
)));
3517 /* Update the list for any nested `require's that occur. */
3518 record_unwind_protect (require_unwind
, require_nesting_list
);
3519 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3521 /* Value saved here is to be restored into Vautoload_queue */
3522 record_unwind_protect (un_autoload
, Vautoload_queue
);
3523 Vautoload_queue
= Qt
;
3525 /* Load the file. */
3526 GCPRO2 (feature
, filename
);
3527 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3528 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3531 /* If load failed entirely, return nil. */
3533 return unbind_to (count
, Qnil
);
3535 tem
= Fmemq (feature
, Vfeatures
);
3537 error ("Required feature `%s' was not provided",
3538 SDATA (SYMBOL_NAME (feature
)));
3540 /* Once loading finishes, don't undo it. */
3541 Vautoload_queue
= Qt
;
3542 feature
= unbind_to (count
, feature
);
3548 /* Primitives for work of the "widget" library.
3549 In an ideal world, this section would not have been necessary.
3550 However, lisp function calls being as slow as they are, it turns
3551 out that some functions in the widget library (wid-edit.el) are the
3552 bottleneck of Widget operation. Here is their translation to C,
3553 for the sole reason of efficiency. */
3555 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3556 doc
: /* Return non-nil if PLIST has the property PROP.
3557 PLIST is a property list, which is a list of the form
3558 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3559 Unlike `plist-get', this allows you to distinguish between a missing
3560 property and a property with the value nil.
3561 The value is actually the tail of PLIST whose car is PROP. */)
3563 Lisp_Object plist
, prop
;
3565 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3568 plist
= XCDR (plist
);
3569 plist
= CDR (plist
);
3574 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3575 doc
: /* In WIDGET, set PROPERTY to VALUE.
3576 The value can later be retrieved with `widget-get'. */)
3577 (widget
, property
, value
)
3578 Lisp_Object widget
, property
, value
;
3580 CHECK_CONS (widget
);
3581 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3585 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3586 doc
: /* In WIDGET, get the value of PROPERTY.
3587 The value could either be specified when the widget was created, or
3588 later with `widget-put'. */)
3590 Lisp_Object widget
, property
;
3598 CHECK_CONS (widget
);
3599 tmp
= Fplist_member (XCDR (widget
), property
);
3605 tmp
= XCAR (widget
);
3608 widget
= Fget (tmp
, Qwidget_type
);
3612 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3613 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3614 ARGS are passed as extra arguments to the function.
3615 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3620 /* This function can GC. */
3621 Lisp_Object newargs
[3];
3622 struct gcpro gcpro1
, gcpro2
;
3625 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3626 newargs
[1] = args
[0];
3627 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3628 GCPRO2 (newargs
[0], newargs
[2]);
3629 result
= Fapply (3, newargs
);
3634 #ifdef HAVE_LANGINFO_CODESET
3635 #include <langinfo.h>
3638 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3639 doc
: /* Access locale data ITEM for the current C locale, if available.
3640 ITEM should be one of the following:
3642 `codeset', returning the character set as a string (locale item CODESET);
3644 `days', returning a 7-element vector of day names (locale items DAY_n);
3646 `months', returning a 12-element vector of month names (locale items MON_n);
3648 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3649 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3651 If the system can't provide such information through a call to
3652 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3654 See also Info node `(libc)Locales'.
3656 The data read from the system are decoded using `locale-coding-system'. */)
3661 #ifdef HAVE_LANGINFO_CODESET
3663 if (EQ (item
, Qcodeset
))
3665 str
= nl_langinfo (CODESET
);
3666 return build_string (str
);
3669 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3671 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3672 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3674 synchronize_system_time_locale ();
3675 for (i
= 0; i
< 7; i
++)
3677 str
= nl_langinfo (days
[i
]);
3678 val
= make_unibyte_string (str
, strlen (str
));
3679 /* Fixme: Is this coding system necessarily right, even if
3680 it is consistent with CODESET? If not, what to do? */
3681 Faset (v
, make_number (i
),
3682 code_convert_string_norecord (val
, Vlocale_coding_system
,
3689 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3691 struct Lisp_Vector
*p
= allocate_vector (12);
3692 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3693 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3695 synchronize_system_time_locale ();
3696 for (i
= 0; i
< 12; i
++)
3698 str
= nl_langinfo (months
[i
]);
3699 val
= make_unibyte_string (str
, strlen (str
));
3701 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3703 XSETVECTOR (val
, p
);
3707 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3708 but is in the locale files. This could be used by ps-print. */
3710 else if (EQ (item
, Qpaper
))
3712 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3713 make_number (nl_langinfo (PAPER_HEIGHT
)));
3715 #endif /* PAPER_WIDTH */
3716 #endif /* HAVE_LANGINFO_CODESET*/
3720 /* base64 encode/decode functions (RFC 2045).
3721 Based on code from GNU recode. */
3723 #define MIME_LINE_LENGTH 76
3725 #define IS_ASCII(Character) \
3727 #define IS_BASE64(Character) \
3728 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3729 #define IS_BASE64_IGNORABLE(Character) \
3730 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3731 || (Character) == '\f' || (Character) == '\r')
3733 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3734 character or return retval if there are no characters left to
3736 #define READ_QUADRUPLET_BYTE(retval) \
3741 if (nchars_return) \
3742 *nchars_return = nchars; \
3747 while (IS_BASE64_IGNORABLE (c))
3749 /* Table of characters coding the 64 values. */
3750 static char base64_value_to_char
[64] =
3752 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3753 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3754 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3755 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3756 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3757 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3758 '8', '9', '+', '/' /* 60-63 */
3761 /* Table of base64 values for first 128 characters. */
3762 static short base64_char_to_value
[128] =
3764 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3765 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3766 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3767 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3768 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3769 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3770 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3771 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3772 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3773 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3774 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3775 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3776 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3779 /* The following diagram shows the logical steps by which three octets
3780 get transformed into four base64 characters.
3782 .--------. .--------. .--------.
3783 |aaaaaabb| |bbbbcccc| |ccdddddd|
3784 `--------' `--------' `--------'
3786 .--------+--------+--------+--------.
3787 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3788 `--------+--------+--------+--------'
3790 .--------+--------+--------+--------.
3791 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3792 `--------+--------+--------+--------'
3794 The octets are divided into 6 bit chunks, which are then encoded into
3795 base64 characters. */
3798 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3799 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3801 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3803 doc
: /* Base64-encode the region between BEG and END.
3804 Return the length of the encoded text.
3805 Optional third argument NO-LINE-BREAK means do not break long lines
3806 into shorter lines. */)
3807 (beg
, end
, no_line_break
)
3808 Lisp_Object beg
, end
, no_line_break
;
3811 int allength
, length
;
3812 int ibeg
, iend
, encoded_length
;
3816 validate_region (&beg
, &end
);
3818 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3819 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3820 move_gap_both (XFASTINT (beg
), ibeg
);
3822 /* We need to allocate enough room for encoding the text.
3823 We need 33 1/3% more space, plus a newline every 76
3824 characters, and then we round up. */
3825 length
= iend
- ibeg
;
3826 allength
= length
+ length
/3 + 1;
3827 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3829 SAFE_ALLOCA (encoded
, char *, allength
);
3830 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3831 NILP (no_line_break
),
3832 !NILP (current_buffer
->enable_multibyte_characters
));
3833 if (encoded_length
> allength
)
3836 if (encoded_length
< 0)
3838 /* The encoding wasn't possible. */
3840 error ("Multibyte character in data for base64 encoding");
3843 /* Now we have encoded the region, so we insert the new contents
3844 and delete the old. (Insert first in order to preserve markers.) */
3845 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3846 insert (encoded
, encoded_length
);
3848 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3850 /* If point was outside of the region, restore it exactly; else just
3851 move to the beginning of the region. */
3852 if (old_pos
>= XFASTINT (end
))
3853 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3854 else if (old_pos
> XFASTINT (beg
))
3855 old_pos
= XFASTINT (beg
);
3858 /* We return the length of the encoded text. */
3859 return make_number (encoded_length
);
3862 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3864 doc
: /* Base64-encode STRING and return the result.
3865 Optional second argument NO-LINE-BREAK means do not break long lines
3866 into shorter lines. */)
3867 (string
, no_line_break
)
3868 Lisp_Object string
, no_line_break
;
3870 int allength
, length
, encoded_length
;
3872 Lisp_Object encoded_string
;
3875 CHECK_STRING (string
);
3877 /* We need to allocate enough room for encoding the text.
3878 We need 33 1/3% more space, plus a newline every 76
3879 characters, and then we round up. */
3880 length
= SBYTES (string
);
3881 allength
= length
+ length
/3 + 1;
3882 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3884 /* We need to allocate enough room for decoding the text. */
3885 SAFE_ALLOCA (encoded
, char *, allength
);
3887 encoded_length
= base64_encode_1 (SDATA (string
),
3888 encoded
, length
, NILP (no_line_break
),
3889 STRING_MULTIBYTE (string
));
3890 if (encoded_length
> allength
)
3893 if (encoded_length
< 0)
3895 /* The encoding wasn't possible. */
3897 error ("Multibyte character in data for base64 encoding");
3900 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3903 return encoded_string
;
3907 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3914 int counter
= 0, i
= 0;
3924 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3932 /* Wrap line every 76 characters. */
3936 if (counter
< MIME_LINE_LENGTH
/ 4)
3945 /* Process first byte of a triplet. */
3947 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3948 value
= (0x03 & c
) << 4;
3950 /* Process second byte of a triplet. */
3954 *e
++ = base64_value_to_char
[value
];
3962 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3970 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3971 value
= (0x0f & c
) << 2;
3973 /* Process third byte of a triplet. */
3977 *e
++ = base64_value_to_char
[value
];
3984 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3992 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3993 *e
++ = base64_value_to_char
[0x3f & c
];
4000 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
4002 doc
: /* Base64-decode the region between BEG and END.
4003 Return the length of the decoded text.
4004 If the region can't be decoded, signal an error and don't modify the buffer. */)
4006 Lisp_Object beg
, end
;
4008 int ibeg
, iend
, length
, allength
;
4013 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
4016 validate_region (&beg
, &end
);
4018 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
4019 iend
= CHAR_TO_BYTE (XFASTINT (end
));
4021 length
= iend
- ibeg
;
4023 /* We need to allocate enough room for decoding the text. If we are
4024 working on a multibyte buffer, each decoded code may occupy at
4026 allength
= multibyte
? length
* 2 : length
;
4027 SAFE_ALLOCA (decoded
, char *, allength
);
4029 move_gap_both (XFASTINT (beg
), ibeg
);
4030 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
4031 multibyte
, &inserted_chars
);
4032 if (decoded_length
> allength
)
4035 if (decoded_length
< 0)
4037 /* The decoding wasn't possible. */
4039 error ("Invalid base64 data");
4042 /* Now we have decoded the region, so we insert the new contents
4043 and delete the old. (Insert first in order to preserve markers.) */
4044 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4045 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4048 /* Delete the original text. */
4049 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4050 iend
+ decoded_length
, 1);
4052 /* If point was outside of the region, restore it exactly; else just
4053 move to the beginning of the region. */
4054 if (old_pos
>= XFASTINT (end
))
4055 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4056 else if (old_pos
> XFASTINT (beg
))
4057 old_pos
= XFASTINT (beg
);
4058 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4060 return make_number (inserted_chars
);
4063 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4065 doc
: /* Base64-decode STRING and return the result. */)
4070 int length
, decoded_length
;
4071 Lisp_Object decoded_string
;
4074 CHECK_STRING (string
);
4076 length
= SBYTES (string
);
4077 /* We need to allocate enough room for decoding the text. */
4078 SAFE_ALLOCA (decoded
, char *, length
);
4080 /* The decoded result should be unibyte. */
4081 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4083 if (decoded_length
> length
)
4085 else if (decoded_length
>= 0)
4086 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4088 decoded_string
= Qnil
;
4091 if (!STRINGP (decoded_string
))
4092 error ("Invalid base64 data");
4094 return decoded_string
;
4097 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4098 MULTIBYTE is nonzero, the decoded result should be in multibyte
4099 form. If NCHARS_RETRUN is not NULL, store the number of produced
4100 characters in *NCHARS_RETURN. */
4103 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4113 unsigned long value
;
4118 /* Process first byte of a quadruplet. */
4120 READ_QUADRUPLET_BYTE (e
-to
);
4124 value
= base64_char_to_value
[c
] << 18;
4126 /* Process second byte of a quadruplet. */
4128 READ_QUADRUPLET_BYTE (-1);
4132 value
|= base64_char_to_value
[c
] << 12;
4134 c
= (unsigned char) (value
>> 16);
4136 e
+= CHAR_STRING (c
, e
);
4141 /* Process third byte of a quadruplet. */
4143 READ_QUADRUPLET_BYTE (-1);
4147 READ_QUADRUPLET_BYTE (-1);
4156 value
|= base64_char_to_value
[c
] << 6;
4158 c
= (unsigned char) (0xff & value
>> 8);
4160 e
+= CHAR_STRING (c
, e
);
4165 /* Process fourth byte of a quadruplet. */
4167 READ_QUADRUPLET_BYTE (-1);
4174 value
|= base64_char_to_value
[c
];
4176 c
= (unsigned char) (0xff & value
);
4178 e
+= CHAR_STRING (c
, e
);
4187 /***********************************************************************
4189 ***** Hash Tables *****
4191 ***********************************************************************/
4193 /* Implemented by gerd@gnu.org. This hash table implementation was
4194 inspired by CMUCL hash tables. */
4198 1. For small tables, association lists are probably faster than
4199 hash tables because they have lower overhead.
4201 For uses of hash tables where the O(1) behavior of table
4202 operations is not a requirement, it might therefore be a good idea
4203 not to hash. Instead, we could just do a linear search in the
4204 key_and_value vector of the hash table. This could be done
4205 if a `:linear-search t' argument is given to make-hash-table. */
4208 /* The list of all weak hash tables. Don't staticpro this one. */
4210 Lisp_Object Vweak_hash_tables
;
4212 /* Various symbols. */
4214 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4215 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4216 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4218 /* Function prototypes. */
4220 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4221 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4222 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4223 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4224 Lisp_Object
, unsigned));
4225 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4226 Lisp_Object
, unsigned));
4227 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4228 unsigned, Lisp_Object
, unsigned));
4229 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4230 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4231 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4232 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4234 static unsigned sxhash_string
P_ ((unsigned char *, int));
4235 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4236 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4237 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4238 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4242 /***********************************************************************
4244 ***********************************************************************/
4246 /* If OBJ is a Lisp hash table, return a pointer to its struct
4247 Lisp_Hash_Table. Otherwise, signal an error. */
4249 static struct Lisp_Hash_Table
*
4250 check_hash_table (obj
)
4253 CHECK_HASH_TABLE (obj
);
4254 return XHASH_TABLE (obj
);
4258 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4262 next_almost_prime (n
)
4275 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4276 which USED[I] is non-zero. If found at index I in ARGS, set
4277 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4278 -1. This function is used to extract a keyword/argument pair from
4279 a DEFUN parameter list. */
4282 get_key_arg (key
, nargs
, args
, used
)
4290 for (i
= 0; i
< nargs
- 1; ++i
)
4291 if (!used
[i
] && EQ (args
[i
], key
))
4306 /* Return a Lisp vector which has the same contents as VEC but has
4307 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4308 vector that are not copied from VEC are set to INIT. */
4311 larger_vector (vec
, new_size
, init
)
4316 struct Lisp_Vector
*v
;
4319 xassert (VECTORP (vec
));
4320 old_size
= XVECTOR (vec
)->size
;
4321 xassert (new_size
>= old_size
);
4323 v
= allocate_vector (new_size
);
4324 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4325 old_size
* sizeof *v
->contents
);
4326 for (i
= old_size
; i
< new_size
; ++i
)
4327 v
->contents
[i
] = init
;
4328 XSETVECTOR (vec
, v
);
4333 /***********************************************************************
4335 ***********************************************************************/
4337 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4338 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4339 KEY2 are the same. */
4342 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4343 struct Lisp_Hash_Table
*h
;
4344 Lisp_Object key1
, key2
;
4345 unsigned hash1
, hash2
;
4347 return (FLOATP (key1
)
4349 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4353 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4354 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4355 KEY2 are the same. */
4358 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4359 struct Lisp_Hash_Table
*h
;
4360 Lisp_Object key1
, key2
;
4361 unsigned hash1
, hash2
;
4363 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4367 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4368 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4369 if KEY1 and KEY2 are the same. */
4372 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4373 struct Lisp_Hash_Table
*h
;
4374 Lisp_Object key1
, key2
;
4375 unsigned hash1
, hash2
;
4379 Lisp_Object args
[3];
4381 args
[0] = h
->user_cmp_function
;
4384 return !NILP (Ffuncall (3, args
));
4391 /* Value is a hash code for KEY for use in hash table H which uses
4392 `eq' to compare keys. The hash code returned is guaranteed to fit
4393 in a Lisp integer. */
4397 struct Lisp_Hash_Table
*h
;
4400 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4401 xassert ((hash
& ~INTMASK
) == 0);
4406 /* Value is a hash code for KEY for use in hash table H which uses
4407 `eql' to compare keys. The hash code returned is guaranteed to fit
4408 in a Lisp integer. */
4412 struct Lisp_Hash_Table
*h
;
4417 hash
= sxhash (key
, 0);
4419 hash
= XUINT (key
) ^ XGCTYPE (key
);
4420 xassert ((hash
& ~INTMASK
) == 0);
4425 /* Value is a hash code for KEY for use in hash table H which uses
4426 `equal' to compare keys. The hash code returned is guaranteed to fit
4427 in a Lisp integer. */
4430 hashfn_equal (h
, key
)
4431 struct Lisp_Hash_Table
*h
;
4434 unsigned hash
= sxhash (key
, 0);
4435 xassert ((hash
& ~INTMASK
) == 0);
4440 /* Value is a hash code for KEY for use in hash table H which uses as
4441 user-defined function to compare keys. The hash code returned is
4442 guaranteed to fit in a Lisp integer. */
4445 hashfn_user_defined (h
, key
)
4446 struct Lisp_Hash_Table
*h
;
4449 Lisp_Object args
[2], hash
;
4451 args
[0] = h
->user_hash_function
;
4453 hash
= Ffuncall (2, args
);
4454 if (!INTEGERP (hash
))
4456 list2 (build_string ("Invalid hash code returned from \
4457 user-supplied hash function"),
4459 return XUINT (hash
);
4463 /* Create and initialize a new hash table.
4465 TEST specifies the test the hash table will use to compare keys.
4466 It must be either one of the predefined tests `eq', `eql' or
4467 `equal' or a symbol denoting a user-defined test named TEST with
4468 test and hash functions USER_TEST and USER_HASH.
4470 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4472 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4473 new size when it becomes full is computed by adding REHASH_SIZE to
4474 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4475 table's new size is computed by multiplying its old size with
4478 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4479 be resized when the ratio of (number of entries in the table) /
4480 (table size) is >= REHASH_THRESHOLD.
4482 WEAK specifies the weakness of the table. If non-nil, it must be
4483 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4486 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4487 user_test
, user_hash
)
4488 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4489 Lisp_Object user_test
, user_hash
;
4491 struct Lisp_Hash_Table
*h
;
4493 int index_size
, i
, sz
;
4495 /* Preconditions. */
4496 xassert (SYMBOLP (test
));
4497 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4498 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4499 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4500 xassert (FLOATP (rehash_threshold
)
4501 && XFLOATINT (rehash_threshold
) > 0
4502 && XFLOATINT (rehash_threshold
) <= 1.0);
4504 if (XFASTINT (size
) == 0)
4505 size
= make_number (1);
4507 /* Allocate a table and initialize it. */
4508 h
= allocate_hash_table ();
4510 /* Initialize hash table slots. */
4511 sz
= XFASTINT (size
);
4514 if (EQ (test
, Qeql
))
4516 h
->cmpfn
= cmpfn_eql
;
4517 h
->hashfn
= hashfn_eql
;
4519 else if (EQ (test
, Qeq
))
4522 h
->hashfn
= hashfn_eq
;
4524 else if (EQ (test
, Qequal
))
4526 h
->cmpfn
= cmpfn_equal
;
4527 h
->hashfn
= hashfn_equal
;
4531 h
->user_cmp_function
= user_test
;
4532 h
->user_hash_function
= user_hash
;
4533 h
->cmpfn
= cmpfn_user_defined
;
4534 h
->hashfn
= hashfn_user_defined
;
4538 h
->rehash_threshold
= rehash_threshold
;
4539 h
->rehash_size
= rehash_size
;
4540 h
->count
= make_number (0);
4541 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4542 h
->hash
= Fmake_vector (size
, Qnil
);
4543 h
->next
= Fmake_vector (size
, Qnil
);
4544 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4545 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4546 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4548 /* Set up the free list. */
4549 for (i
= 0; i
< sz
- 1; ++i
)
4550 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4551 h
->next_free
= make_number (0);
4553 XSET_HASH_TABLE (table
, h
);
4554 xassert (HASH_TABLE_P (table
));
4555 xassert (XHASH_TABLE (table
) == h
);
4557 /* Maybe add this hash table to the list of all weak hash tables. */
4559 h
->next_weak
= Qnil
;
4562 h
->next_weak
= Vweak_hash_tables
;
4563 Vweak_hash_tables
= table
;
4570 /* Return a copy of hash table H1. Keys and values are not copied,
4571 only the table itself is. */
4574 copy_hash_table (h1
)
4575 struct Lisp_Hash_Table
*h1
;
4578 struct Lisp_Hash_Table
*h2
;
4579 struct Lisp_Vector
*next
;
4581 h2
= allocate_hash_table ();
4582 next
= h2
->vec_next
;
4583 bcopy (h1
, h2
, sizeof *h2
);
4584 h2
->vec_next
= next
;
4585 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4586 h2
->hash
= Fcopy_sequence (h1
->hash
);
4587 h2
->next
= Fcopy_sequence (h1
->next
);
4588 h2
->index
= Fcopy_sequence (h1
->index
);
4589 XSET_HASH_TABLE (table
, h2
);
4591 /* Maybe add this hash table to the list of all weak hash tables. */
4592 if (!NILP (h2
->weak
))
4594 h2
->next_weak
= Vweak_hash_tables
;
4595 Vweak_hash_tables
= table
;
4602 /* Resize hash table H if it's too full. If H cannot be resized
4603 because it's already too large, throw an error. */
4606 maybe_resize_hash_table (h
)
4607 struct Lisp_Hash_Table
*h
;
4609 if (NILP (h
->next_free
))
4611 int old_size
= HASH_TABLE_SIZE (h
);
4612 int i
, new_size
, index_size
;
4614 if (INTEGERP (h
->rehash_size
))
4615 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4617 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4618 new_size
= max (old_size
+ 1, new_size
);
4619 index_size
= next_almost_prime ((int)
4621 / XFLOATINT (h
->rehash_threshold
)));
4622 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4623 error ("Hash table too large to resize");
4625 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4626 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4627 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4628 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4630 /* Update the free list. Do it so that new entries are added at
4631 the end of the free list. This makes some operations like
4633 for (i
= old_size
; i
< new_size
- 1; ++i
)
4634 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4636 if (!NILP (h
->next_free
))
4638 Lisp_Object last
, next
;
4640 last
= h
->next_free
;
4641 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4645 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4648 XSETFASTINT (h
->next_free
, old_size
);
4651 for (i
= 0; i
< old_size
; ++i
)
4652 if (!NILP (HASH_HASH (h
, i
)))
4654 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4655 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4656 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4657 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4663 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4664 the hash code of KEY. Value is the index of the entry in H
4665 matching KEY, or -1 if not found. */
4668 hash_lookup (h
, key
, hash
)
4669 struct Lisp_Hash_Table
*h
;
4674 int start_of_bucket
;
4677 hash_code
= h
->hashfn (h
, key
);
4681 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4682 idx
= HASH_INDEX (h
, start_of_bucket
);
4684 /* We need not gcpro idx since it's either an integer or nil. */
4687 int i
= XFASTINT (idx
);
4688 if (EQ (key
, HASH_KEY (h
, i
))
4690 && h
->cmpfn (h
, key
, hash_code
,
4691 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4693 idx
= HASH_NEXT (h
, i
);
4696 return NILP (idx
) ? -1 : XFASTINT (idx
);
4700 /* Put an entry into hash table H that associates KEY with VALUE.
4701 HASH is a previously computed hash code of KEY.
4702 Value is the index of the entry in H matching KEY. */
4705 hash_put (h
, key
, value
, hash
)
4706 struct Lisp_Hash_Table
*h
;
4707 Lisp_Object key
, value
;
4710 int start_of_bucket
, i
;
4712 xassert ((hash
& ~INTMASK
) == 0);
4714 /* Increment count after resizing because resizing may fail. */
4715 maybe_resize_hash_table (h
);
4716 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4718 /* Store key/value in the key_and_value vector. */
4719 i
= XFASTINT (h
->next_free
);
4720 h
->next_free
= HASH_NEXT (h
, i
);
4721 HASH_KEY (h
, i
) = key
;
4722 HASH_VALUE (h
, i
) = value
;
4724 /* Remember its hash code. */
4725 HASH_HASH (h
, i
) = make_number (hash
);
4727 /* Add new entry to its collision chain. */
4728 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4729 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4730 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4735 /* Remove the entry matching KEY from hash table H, if there is one. */
4738 hash_remove (h
, key
)
4739 struct Lisp_Hash_Table
*h
;
4743 int start_of_bucket
;
4744 Lisp_Object idx
, prev
;
4746 hash_code
= h
->hashfn (h
, key
);
4747 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4748 idx
= HASH_INDEX (h
, start_of_bucket
);
4751 /* We need not gcpro idx, prev since they're either integers or nil. */
4754 int i
= XFASTINT (idx
);
4756 if (EQ (key
, HASH_KEY (h
, i
))
4758 && h
->cmpfn (h
, key
, hash_code
,
4759 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4761 /* Take entry out of collision chain. */
4763 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4765 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4767 /* Clear slots in key_and_value and add the slots to
4769 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4770 HASH_NEXT (h
, i
) = h
->next_free
;
4771 h
->next_free
= make_number (i
);
4772 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4773 xassert (XINT (h
->count
) >= 0);
4779 idx
= HASH_NEXT (h
, i
);
4785 /* Clear hash table H. */
4789 struct Lisp_Hash_Table
*h
;
4791 if (XFASTINT (h
->count
) > 0)
4793 int i
, size
= HASH_TABLE_SIZE (h
);
4795 for (i
= 0; i
< size
; ++i
)
4797 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4798 HASH_KEY (h
, i
) = Qnil
;
4799 HASH_VALUE (h
, i
) = Qnil
;
4800 HASH_HASH (h
, i
) = Qnil
;
4803 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4804 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4806 h
->next_free
= make_number (0);
4807 h
->count
= make_number (0);
4813 /************************************************************************
4815 ************************************************************************/
4817 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4818 entries from the table that don't survive the current GC.
4819 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4820 non-zero if anything was marked. */
4823 sweep_weak_table (h
, remove_entries_p
)
4824 struct Lisp_Hash_Table
*h
;
4825 int remove_entries_p
;
4827 int bucket
, n
, marked
;
4829 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4832 for (bucket
= 0; bucket
< n
; ++bucket
)
4834 Lisp_Object idx
, next
, prev
;
4836 /* Follow collision chain, removing entries that
4837 don't survive this garbage collection. */
4839 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4841 int i
= XFASTINT (idx
);
4842 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4843 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4846 if (EQ (h
->weak
, Qkey
))
4847 remove_p
= !key_known_to_survive_p
;
4848 else if (EQ (h
->weak
, Qvalue
))
4849 remove_p
= !value_known_to_survive_p
;
4850 else if (EQ (h
->weak
, Qkey_or_value
))
4851 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4852 else if (EQ (h
->weak
, Qkey_and_value
))
4853 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4857 next
= HASH_NEXT (h
, i
);
4859 if (remove_entries_p
)
4863 /* Take out of collision chain. */
4865 HASH_INDEX (h
, bucket
) = next
;
4867 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4869 /* Add to free list. */
4870 HASH_NEXT (h
, i
) = h
->next_free
;
4873 /* Clear key, value, and hash. */
4874 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4875 HASH_HASH (h
, i
) = Qnil
;
4877 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4888 /* Make sure key and value survive. */
4889 if (!key_known_to_survive_p
)
4891 mark_object (HASH_KEY (h
, i
));
4895 if (!value_known_to_survive_p
)
4897 mark_object (HASH_VALUE (h
, i
));
4908 /* Remove elements from weak hash tables that don't survive the
4909 current garbage collection. Remove weak tables that don't survive
4910 from Vweak_hash_tables. Called from gc_sweep. */
4913 sweep_weak_hash_tables ()
4915 Lisp_Object table
, used
, next
;
4916 struct Lisp_Hash_Table
*h
;
4919 /* Mark all keys and values that are in use. Keep on marking until
4920 there is no more change. This is necessary for cases like
4921 value-weak table A containing an entry X -> Y, where Y is used in a
4922 key-weak table B, Z -> Y. If B comes after A in the list of weak
4923 tables, X -> Y might be removed from A, although when looking at B
4924 one finds that it shouldn't. */
4928 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4930 h
= XHASH_TABLE (table
);
4931 if (h
->size
& ARRAY_MARK_FLAG
)
4932 marked
|= sweep_weak_table (h
, 0);
4937 /* Remove tables and entries that aren't used. */
4938 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4940 h
= XHASH_TABLE (table
);
4941 next
= h
->next_weak
;
4943 if (h
->size
& ARRAY_MARK_FLAG
)
4945 /* TABLE is marked as used. Sweep its contents. */
4946 if (XFASTINT (h
->count
) > 0)
4947 sweep_weak_table (h
, 1);
4949 /* Add table to the list of used weak hash tables. */
4950 h
->next_weak
= used
;
4955 Vweak_hash_tables
= used
;
4960 /***********************************************************************
4961 Hash Code Computation
4962 ***********************************************************************/
4964 /* Maximum depth up to which to dive into Lisp structures. */
4966 #define SXHASH_MAX_DEPTH 3
4968 /* Maximum length up to which to take list and vector elements into
4971 #define SXHASH_MAX_LEN 7
4973 /* Combine two integers X and Y for hashing. */
4975 #define SXHASH_COMBINE(X, Y) \
4976 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4980 /* Return a hash for string PTR which has length LEN. The hash
4981 code returned is guaranteed to fit in a Lisp integer. */
4984 sxhash_string (ptr
, len
)
4988 unsigned char *p
= ptr
;
4989 unsigned char *end
= p
+ len
;
4998 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
5001 return hash
& INTMASK
;
5005 /* Return a hash for list LIST. DEPTH is the current depth in the
5006 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
5009 sxhash_list (list
, depth
)
5016 if (depth
< SXHASH_MAX_DEPTH
)
5018 CONSP (list
) && i
< SXHASH_MAX_LEN
;
5019 list
= XCDR (list
), ++i
)
5021 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
5022 hash
= SXHASH_COMBINE (hash
, hash2
);
5029 /* Return a hash for vector VECTOR. DEPTH is the current depth in
5030 the Lisp structure. */
5033 sxhash_vector (vec
, depth
)
5037 unsigned hash
= XVECTOR (vec
)->size
;
5040 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5041 for (i
= 0; i
< n
; ++i
)
5043 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5044 hash
= SXHASH_COMBINE (hash
, hash2
);
5051 /* Return a hash for bool-vector VECTOR. */
5054 sxhash_bool_vector (vec
)
5057 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5060 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5061 for (i
= 0; i
< n
; ++i
)
5062 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5068 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5069 structure. Value is an unsigned integer clipped to INTMASK. */
5078 if (depth
> SXHASH_MAX_DEPTH
)
5081 switch (XTYPE (obj
))
5092 obj
= SYMBOL_NAME (obj
);
5096 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5099 /* This can be everything from a vector to an overlay. */
5100 case Lisp_Vectorlike
:
5102 /* According to the CL HyperSpec, two arrays are equal only if
5103 they are `eq', except for strings and bit-vectors. In
5104 Emacs, this works differently. We have to compare element
5106 hash
= sxhash_vector (obj
, depth
);
5107 else if (BOOL_VECTOR_P (obj
))
5108 hash
= sxhash_bool_vector (obj
);
5110 /* Others are `equal' if they are `eq', so let's take their
5116 hash
= sxhash_list (obj
, depth
);
5121 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5122 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5123 for (hash
= 0; p
< e
; ++p
)
5124 hash
= SXHASH_COMBINE (hash
, *p
);
5132 return hash
& INTMASK
;
5137 /***********************************************************************
5139 ***********************************************************************/
5142 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5143 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5147 unsigned hash
= sxhash (obj
, 0);;
5148 return make_number (hash
);
5152 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5153 doc
: /* Create and return a new hash table.
5155 Arguments are specified as keyword/argument pairs. The following
5156 arguments are defined:
5158 :test TEST -- TEST must be a symbol that specifies how to compare
5159 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5160 `equal'. User-supplied test and hash functions can be specified via
5161 `define-hash-table-test'.
5163 :size SIZE -- A hint as to how many elements will be put in the table.
5166 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5167 fills up. If REHASH-SIZE is an integer, add that many space. If it
5168 is a float, it must be > 1.0, and the new size is computed by
5169 multiplying the old size with that factor. Default is 1.5.
5171 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5172 Resize the hash table when ratio of the number of entries in the
5173 table. Default is 0.8.
5175 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5176 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5177 returned is a weak table. Key/value pairs are removed from a weak
5178 hash table when there are no non-weak references pointing to their
5179 key, value, one of key or value, or both key and value, depending on
5180 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5183 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5188 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5189 Lisp_Object user_test
, user_hash
;
5193 /* The vector `used' is used to keep track of arguments that
5194 have been consumed. */
5195 used
= (char *) alloca (nargs
* sizeof *used
);
5196 bzero (used
, nargs
* sizeof *used
);
5198 /* See if there's a `:test TEST' among the arguments. */
5199 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5200 test
= i
< 0 ? Qeql
: args
[i
];
5201 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5203 /* See if it is a user-defined test. */
5206 prop
= Fget (test
, Qhash_table_test
);
5207 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5208 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5210 user_test
= XCAR (prop
);
5211 user_hash
= XCAR (XCDR (prop
));
5214 user_test
= user_hash
= Qnil
;
5216 /* See if there's a `:size SIZE' argument. */
5217 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5218 size
= i
< 0 ? Qnil
: args
[i
];
5220 size
= make_number (DEFAULT_HASH_SIZE
);
5221 else if (!INTEGERP (size
) || XINT (size
) < 0)
5223 list2 (build_string ("Invalid hash table size"),
5226 /* Look for `:rehash-size SIZE'. */
5227 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5228 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5229 if (!NUMBERP (rehash_size
)
5230 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5231 || XFLOATINT (rehash_size
) <= 1.0)
5233 list2 (build_string ("Invalid hash table rehash size"),
5236 /* Look for `:rehash-threshold THRESHOLD'. */
5237 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5238 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5239 if (!FLOATP (rehash_threshold
)
5240 || XFLOATINT (rehash_threshold
) <= 0.0
5241 || XFLOATINT (rehash_threshold
) > 1.0)
5243 list2 (build_string ("Invalid hash table rehash threshold"),
5246 /* Look for `:weakness WEAK'. */
5247 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5248 weak
= i
< 0 ? Qnil
: args
[i
];
5250 weak
= Qkey_and_value
;
5253 && !EQ (weak
, Qvalue
)
5254 && !EQ (weak
, Qkey_or_value
)
5255 && !EQ (weak
, Qkey_and_value
))
5256 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5259 /* Now, all args should have been used up, or there's a problem. */
5260 for (i
= 0; i
< nargs
; ++i
)
5263 list2 (build_string ("Invalid argument list"), args
[i
]));
5265 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5266 user_test
, user_hash
);
5270 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5271 doc
: /* Return a copy of hash table TABLE. */)
5275 return copy_hash_table (check_hash_table (table
));
5279 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5280 doc
: /* Return the number of elements in TABLE. */)
5284 return check_hash_table (table
)->count
;
5288 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5289 Shash_table_rehash_size
, 1, 1, 0,
5290 doc
: /* Return the current rehash size of TABLE. */)
5294 return check_hash_table (table
)->rehash_size
;
5298 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5299 Shash_table_rehash_threshold
, 1, 1, 0,
5300 doc
: /* Return the current rehash threshold of TABLE. */)
5304 return check_hash_table (table
)->rehash_threshold
;
5308 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5309 doc
: /* Return the size of TABLE.
5310 The size can be used as an argument to `make-hash-table' to create
5311 a hash table than can hold as many elements of TABLE holds
5312 without need for resizing. */)
5316 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5317 return make_number (HASH_TABLE_SIZE (h
));
5321 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5322 doc
: /* Return the test TABLE uses. */)
5326 return check_hash_table (table
)->test
;
5330 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5332 doc
: /* Return the weakness of TABLE. */)
5336 return check_hash_table (table
)->weak
;
5340 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5341 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5345 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5349 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5350 doc
: /* Clear hash table TABLE. */)
5354 hash_clear (check_hash_table (table
));
5359 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5360 doc
: /* Look up KEY in TABLE and return its associated value.
5361 If KEY is not found, return DFLT which defaults to nil. */)
5363 Lisp_Object key
, table
, dflt
;
5365 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5366 int i
= hash_lookup (h
, key
, NULL
);
5367 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5371 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5372 doc
: /* Associate KEY with VALUE in hash table TABLE.
5373 If KEY is already present in table, replace its current value with
5376 Lisp_Object key
, value
, table
;
5378 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5382 i
= hash_lookup (h
, key
, &hash
);
5384 HASH_VALUE (h
, i
) = value
;
5386 hash_put (h
, key
, value
, hash
);
5392 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5393 doc
: /* Remove KEY from TABLE. */)
5395 Lisp_Object key
, table
;
5397 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5398 hash_remove (h
, key
);
5403 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5404 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5405 FUNCTION is called with 2 arguments KEY and VALUE. */)
5407 Lisp_Object function
, table
;
5409 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5410 Lisp_Object args
[3];
5413 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5414 if (!NILP (HASH_HASH (h
, i
)))
5417 args
[1] = HASH_KEY (h
, i
);
5418 args
[2] = HASH_VALUE (h
, i
);
5426 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5427 Sdefine_hash_table_test
, 3, 3, 0,
5428 doc
: /* Define a new hash table test with name NAME, a symbol.
5430 In hash tables created with NAME specified as test, use TEST to
5431 compare keys, and HASH for computing hash codes of keys.
5433 TEST must be a function taking two arguments and returning non-nil if
5434 both arguments are the same. HASH must be a function taking one
5435 argument and return an integer that is the hash code of the argument.
5436 Hash code computation should use the whole value range of integers,
5437 including negative integers. */)
5439 Lisp_Object name
, test
, hash
;
5441 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5446 /************************************************************************
5448 ************************************************************************/
5453 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5454 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5456 A message digest is a cryptographic checksum of a document, and the
5457 algorithm to calculate it is defined in RFC 1321.
5459 The two optional arguments START and END are character positions
5460 specifying for which part of OBJECT the message digest should be
5461 computed. If nil or omitted, the digest is computed for the whole
5464 The MD5 message digest is computed from the result of encoding the
5465 text in a coding system, not directly from the internal Emacs form of
5466 the text. The optional fourth argument CODING-SYSTEM specifies which
5467 coding system to encode the text with. It should be the same coding
5468 system that you used or will use when actually writing the text into a
5471 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5472 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5473 system would be chosen by default for writing this text into a file.
5475 If OBJECT is a string, the most preferred coding system (see the
5476 command `prefer-coding-system') is used.
5478 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5479 guesswork fails. Normally, an error is signaled in such case. */)
5480 (object
, start
, end
, coding_system
, noerror
)
5481 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5483 unsigned char digest
[16];
5484 unsigned char value
[33];
5488 int start_char
= 0, end_char
= 0;
5489 int start_byte
= 0, end_byte
= 0;
5491 register struct buffer
*bp
;
5494 if (STRINGP (object
))
5496 if (NILP (coding_system
))
5498 /* Decide the coding-system to encode the data with. */
5500 if (STRING_MULTIBYTE (object
))
5501 /* use default, we can't guess correct value */
5502 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5504 coding_system
= Qraw_text
;
5507 if (NILP (Fcoding_system_p (coding_system
)))
5509 /* Invalid coding system. */
5511 if (!NILP (noerror
))
5512 coding_system
= Qraw_text
;
5515 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5518 if (STRING_MULTIBYTE (object
))
5519 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5521 size
= SCHARS (object
);
5522 size_byte
= SBYTES (object
);
5526 CHECK_NUMBER (start
);
5528 start_char
= XINT (start
);
5533 start_byte
= string_char_to_byte (object
, start_char
);
5539 end_byte
= size_byte
;
5545 end_char
= XINT (end
);
5550 end_byte
= string_char_to_byte (object
, end_char
);
5553 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5554 args_out_of_range_3 (object
, make_number (start_char
),
5555 make_number (end_char
));
5559 struct buffer
*prev
= current_buffer
;
5561 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5563 CHECK_BUFFER (object
);
5565 bp
= XBUFFER (object
);
5566 if (bp
!= current_buffer
)
5567 set_buffer_internal (bp
);
5573 CHECK_NUMBER_COERCE_MARKER (start
);
5581 CHECK_NUMBER_COERCE_MARKER (end
);
5586 temp
= b
, b
= e
, e
= temp
;
5588 if (!(BEGV
<= b
&& e
<= ZV
))
5589 args_out_of_range (start
, end
);
5591 if (NILP (coding_system
))
5593 /* Decide the coding-system to encode the data with.
5594 See fileio.c:Fwrite-region */
5596 if (!NILP (Vcoding_system_for_write
))
5597 coding_system
= Vcoding_system_for_write
;
5600 int force_raw_text
= 0;
5602 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5603 if (NILP (coding_system
)
5604 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5606 coding_system
= Qnil
;
5607 if (NILP (current_buffer
->enable_multibyte_characters
))
5611 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5613 /* Check file-coding-system-alist. */
5614 Lisp_Object args
[4], val
;
5616 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5617 args
[3] = Fbuffer_file_name(object
);
5618 val
= Ffind_operation_coding_system (4, args
);
5619 if (CONSP (val
) && !NILP (XCDR (val
)))
5620 coding_system
= XCDR (val
);
5623 if (NILP (coding_system
)
5624 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5626 /* If we still have not decided a coding system, use the
5627 default value of buffer-file-coding-system. */
5628 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5632 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5633 /* Confirm that VAL can surely encode the current region. */
5634 coding_system
= call4 (Vselect_safe_coding_system_function
,
5635 make_number (b
), make_number (e
),
5636 coding_system
, Qnil
);
5639 coding_system
= Qraw_text
;
5642 if (NILP (Fcoding_system_p (coding_system
)))
5644 /* Invalid coding system. */
5646 if (!NILP (noerror
))
5647 coding_system
= Qraw_text
;
5650 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5654 object
= make_buffer_string (b
, e
, 0);
5655 if (prev
!= current_buffer
)
5656 set_buffer_internal (prev
);
5657 /* Discard the unwind protect for recovering the current
5661 if (STRING_MULTIBYTE (object
))
5662 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5665 md5_buffer (SDATA (object
) + start_byte
,
5666 SBYTES (object
) - (size_byte
- end_byte
),
5669 for (i
= 0; i
< 16; i
++)
5670 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5673 return make_string (value
, 32);
5680 /* Hash table stuff. */
5681 Qhash_table_p
= intern ("hash-table-p");
5682 staticpro (&Qhash_table_p
);
5683 Qeq
= intern ("eq");
5685 Qeql
= intern ("eql");
5687 Qequal
= intern ("equal");
5688 staticpro (&Qequal
);
5689 QCtest
= intern (":test");
5690 staticpro (&QCtest
);
5691 QCsize
= intern (":size");
5692 staticpro (&QCsize
);
5693 QCrehash_size
= intern (":rehash-size");
5694 staticpro (&QCrehash_size
);
5695 QCrehash_threshold
= intern (":rehash-threshold");
5696 staticpro (&QCrehash_threshold
);
5697 QCweakness
= intern (":weakness");
5698 staticpro (&QCweakness
);
5699 Qkey
= intern ("key");
5701 Qvalue
= intern ("value");
5702 staticpro (&Qvalue
);
5703 Qhash_table_test
= intern ("hash-table-test");
5704 staticpro (&Qhash_table_test
);
5705 Qkey_or_value
= intern ("key-or-value");
5706 staticpro (&Qkey_or_value
);
5707 Qkey_and_value
= intern ("key-and-value");
5708 staticpro (&Qkey_and_value
);
5711 defsubr (&Smake_hash_table
);
5712 defsubr (&Scopy_hash_table
);
5713 defsubr (&Shash_table_count
);
5714 defsubr (&Shash_table_rehash_size
);
5715 defsubr (&Shash_table_rehash_threshold
);
5716 defsubr (&Shash_table_size
);
5717 defsubr (&Shash_table_test
);
5718 defsubr (&Shash_table_weakness
);
5719 defsubr (&Shash_table_p
);
5720 defsubr (&Sclrhash
);
5721 defsubr (&Sgethash
);
5722 defsubr (&Sputhash
);
5723 defsubr (&Sremhash
);
5724 defsubr (&Smaphash
);
5725 defsubr (&Sdefine_hash_table_test
);
5727 Qstring_lessp
= intern ("string-lessp");
5728 staticpro (&Qstring_lessp
);
5729 Qprovide
= intern ("provide");
5730 staticpro (&Qprovide
);
5731 Qrequire
= intern ("require");
5732 staticpro (&Qrequire
);
5733 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5734 staticpro (&Qyes_or_no_p_history
);
5735 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5736 staticpro (&Qcursor_in_echo_area
);
5737 Qwidget_type
= intern ("widget-type");
5738 staticpro (&Qwidget_type
);
5740 staticpro (&string_char_byte_cache_string
);
5741 string_char_byte_cache_string
= Qnil
;
5743 require_nesting_list
= Qnil
;
5744 staticpro (&require_nesting_list
);
5746 Fset (Qyes_or_no_p_history
, Qnil
);
5748 DEFVAR_LISP ("features", &Vfeatures
,
5749 doc
: /* A list of symbols which are the features of the executing emacs.
5750 Used by `featurep' and `require', and altered by `provide'. */);
5752 Qsubfeatures
= intern ("subfeatures");
5753 staticpro (&Qsubfeatures
);
5755 #ifdef HAVE_LANGINFO_CODESET
5756 Qcodeset
= intern ("codeset");
5757 staticpro (&Qcodeset
);
5758 Qdays
= intern ("days");
5760 Qmonths
= intern ("months");
5761 staticpro (&Qmonths
);
5762 Qpaper
= intern ("paper");
5763 staticpro (&Qpaper
);
5764 #endif /* HAVE_LANGINFO_CODESET */
5766 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5767 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5768 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5769 invoked by mouse clicks and mouse menu items. */);
5772 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5773 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5774 This applies to commands from menus and tool bar buttons. The value of
5775 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5776 used if both `use-dialog-box' and this variable are non-nil. */);
5777 use_file_dialog
= 1;
5779 defsubr (&Sidentity
);
5782 defsubr (&Ssafe_length
);
5783 defsubr (&Sstring_bytes
);
5784 defsubr (&Sstring_equal
);
5785 defsubr (&Scompare_strings
);
5786 defsubr (&Sstring_lessp
);
5789 defsubr (&Svconcat
);
5790 defsubr (&Scopy_sequence
);
5791 defsubr (&Sstring_make_multibyte
);
5792 defsubr (&Sstring_make_unibyte
);
5793 defsubr (&Sstring_as_multibyte
);
5794 defsubr (&Sstring_as_unibyte
);
5795 defsubr (&Sstring_to_multibyte
);
5796 defsubr (&Scopy_alist
);
5797 defsubr (&Ssubstring
);
5798 defsubr (&Ssubstring_no_properties
);
5810 defsubr (&Snreverse
);
5811 defsubr (&Sreverse
);
5813 defsubr (&Splist_get
);
5814 defsubr (&Ssafe_plist_get
);
5816 defsubr (&Ssafe_get
);
5817 defsubr (&Splist_put
);
5819 defsubr (&Slax_plist_get
);
5820 defsubr (&Slax_plist_put
);
5823 defsubr (&Sequal_including_properties
);
5824 defsubr (&Sfillarray
);
5825 defsubr (&Sclear_string
);
5826 defsubr (&Schar_table_subtype
);
5827 defsubr (&Schar_table_parent
);
5828 defsubr (&Sset_char_table_parent
);
5829 defsubr (&Schar_table_extra_slot
);
5830 defsubr (&Sset_char_table_extra_slot
);
5831 defsubr (&Schar_table_range
);
5832 defsubr (&Sset_char_table_range
);
5833 defsubr (&Sset_char_table_default
);
5834 defsubr (&Soptimize_char_table
);
5835 defsubr (&Smap_char_table
);
5839 defsubr (&Smapconcat
);
5840 defsubr (&Sy_or_n_p
);
5841 defsubr (&Syes_or_no_p
);
5842 defsubr (&Sload_average
);
5843 defsubr (&Sfeaturep
);
5844 defsubr (&Srequire
);
5845 defsubr (&Sprovide
);
5846 defsubr (&Splist_member
);
5847 defsubr (&Swidget_put
);
5848 defsubr (&Swidget_get
);
5849 defsubr (&Swidget_apply
);
5850 defsubr (&Sbase64_encode_region
);
5851 defsubr (&Sbase64_decode_region
);
5852 defsubr (&Sbase64_encode_string
);
5853 defsubr (&Sbase64_decode_string
);
5855 defsubr (&Slocale_info
);
5862 Vweak_hash_tables
= Qnil
;
5865 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5866 (do not change this comment) */