1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 02, 03, 2004
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* On Mac OS, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 /* Nonzero enables use of a file dialog for file name
63 questions asked by mouse commands. */
66 extern int minibuffer_auto_raise
;
67 extern Lisp_Object minibuf_window
;
68 extern Lisp_Object Vlocale_coding_system
;
69 extern Lisp_Object Vloads_in_progress
;
71 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
72 Lisp_Object Qyes_or_no_p_history
;
73 Lisp_Object Qcursor_in_echo_area
;
74 Lisp_Object Qwidget_type
;
75 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
77 extern Lisp_Object Qinput_method_function
;
79 static int internal_equal ();
81 extern long get_random ();
82 extern void seed_random ();
88 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
89 doc
: /* Return the argument unchanged. */)
96 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
97 doc
: /* Return a pseudo-random number.
98 All integers representable in Lisp are equally likely.
99 On most systems, this is 29 bits' worth.
100 With positive integer argument N, return random number in interval [0,N).
101 With argument t, set the random number seed from the current time and pid. */)
106 Lisp_Object lispy_val
;
107 unsigned long denominator
;
110 seed_random (getpid () + time (NULL
));
111 if (NATNUMP (n
) && XFASTINT (n
) != 0)
113 /* Try to take our random number from the higher bits of VAL,
114 not the lower, since (says Gentzel) the low bits of `random'
115 are less random than the higher ones. We do this by using the
116 quotient rather than the remainder. At the high end of the RNG
117 it's possible to get a quotient larger than n; discarding
118 these values eliminates the bias that would otherwise appear
119 when using a large n. */
120 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
122 val
= get_random () / denominator
;
123 while (val
>= XFASTINT (n
));
127 XSETINT (lispy_val
, val
);
131 /* Random data-structure functions */
133 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
134 doc
: /* Return the length of vector, list or string SEQUENCE.
135 A byte-code function object is also allowed.
136 If the string contains multibyte characters, this is not necessarily
137 the number of bytes in the string; it is the number of characters.
138 To get the number of bytes, use `string-bytes'. */)
140 register Lisp_Object sequence
;
142 register Lisp_Object val
;
146 if (STRINGP (sequence
))
147 XSETFASTINT (val
, SCHARS (sequence
));
148 else if (VECTORP (sequence
))
149 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
150 else if (SUB_CHAR_TABLE_P (sequence
))
151 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
152 else if (CHAR_TABLE_P (sequence
))
153 XSETFASTINT (val
, MAX_CHAR
);
154 else if (BOOL_VECTOR_P (sequence
))
155 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
156 else if (COMPILEDP (sequence
))
157 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
158 else if (CONSP (sequence
))
161 while (CONSP (sequence
))
163 sequence
= XCDR (sequence
);
166 if (!CONSP (sequence
))
169 sequence
= XCDR (sequence
);
174 if (!NILP (sequence
))
175 wrong_type_argument (Qlistp
, sequence
);
177 val
= make_number (i
);
179 else if (NILP (sequence
))
180 XSETFASTINT (val
, 0);
183 sequence
= wrong_type_argument (Qsequencep
, sequence
);
189 /* This does not check for quits. That is safe
190 since it must terminate. */
192 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
193 doc
: /* Return the length of a list, but avoid error or infinite loop.
194 This function never gets an error. If LIST is not really a list,
195 it returns 0. If LIST is circular, it returns a finite value
196 which is at least the number of distinct elements. */)
200 Lisp_Object tail
, halftail
, length
;
203 /* halftail is used to detect circular lists. */
205 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
207 if (EQ (tail
, halftail
) && len
!= 0)
211 halftail
= XCDR (halftail
);
214 XSETINT (length
, len
);
218 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
219 doc
: /* Return the number of bytes in STRING.
220 If STRING is a multibyte string, this is greater than the length of STRING. */)
224 CHECK_STRING (string
);
225 return make_number (SBYTES (string
));
228 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
229 doc
: /* Return t if two strings have identical contents.
230 Case is significant, but text properties are ignored.
231 Symbols are also allowed; their print names are used instead. */)
233 register Lisp_Object s1
, s2
;
236 s1
= SYMBOL_NAME (s1
);
238 s2
= SYMBOL_NAME (s2
);
242 if (SCHARS (s1
) != SCHARS (s2
)
243 || SBYTES (s1
) != SBYTES (s2
)
244 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
249 DEFUN ("compare-strings", Fcompare_strings
,
250 Scompare_strings
, 6, 7, 0,
251 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
252 In string STR1, skip the first START1 characters and stop at END1.
253 In string STR2, skip the first START2 characters and stop at END2.
254 END1 and END2 default to the full lengths of the respective strings.
256 Case is significant in this comparison if IGNORE-CASE is nil.
257 Unibyte strings are converted to multibyte for comparison.
259 The value is t if the strings (or specified portions) match.
260 If string STR1 is less, the value is a negative number N;
261 - 1 - N is the number of characters that match at the beginning.
262 If string STR1 is greater, the value is a positive number N;
263 N - 1 is the number of characters that match at the beginning. */)
264 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
265 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
267 register int end1_char
, end2_char
;
268 register int i1
, i1_byte
, i2
, i2_byte
;
273 start1
= make_number (0);
275 start2
= make_number (0);
276 CHECK_NATNUM (start1
);
277 CHECK_NATNUM (start2
);
286 i1_byte
= string_char_to_byte (str1
, i1
);
287 i2_byte
= string_char_to_byte (str2
, i2
);
289 end1_char
= SCHARS (str1
);
290 if (! NILP (end1
) && end1_char
> XINT (end1
))
291 end1_char
= XINT (end1
);
293 end2_char
= SCHARS (str2
);
294 if (! NILP (end2
) && end2_char
> XINT (end2
))
295 end2_char
= XINT (end2
);
297 while (i1
< end1_char
&& i2
< end2_char
)
299 /* When we find a mismatch, we must compare the
300 characters, not just the bytes. */
303 if (STRING_MULTIBYTE (str1
))
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
307 c1
= SREF (str1
, i1
++);
308 c1
= unibyte_char_to_multibyte (c1
);
311 if (STRING_MULTIBYTE (str2
))
312 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
315 c2
= SREF (str2
, i2
++);
316 c2
= unibyte_char_to_multibyte (c2
);
322 if (! NILP (ignore_case
))
326 tem
= Fupcase (make_number (c1
));
328 tem
= Fupcase (make_number (c2
));
335 /* Note that I1 has already been incremented
336 past the character that we are comparing;
337 hence we don't add or subtract 1 here. */
339 return make_number (- i1
+ XINT (start1
));
341 return make_number (i1
- XINT (start1
));
345 return make_number (i1
- XINT (start1
) + 1);
347 return make_number (- i1
+ XINT (start1
) - 1);
352 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
353 doc
: /* Return t if first arg string is less than second in lexicographic order.
355 Symbols are also allowed; their print names are used instead. */)
357 register Lisp_Object s1
, s2
;
360 register int i1
, i1_byte
, i2
, i2_byte
;
363 s1
= SYMBOL_NAME (s1
);
365 s2
= SYMBOL_NAME (s2
);
369 i1
= i1_byte
= i2
= i2_byte
= 0;
372 if (end
> SCHARS (s2
))
377 /* When we find a mismatch, we must compare the
378 characters, not just the bytes. */
381 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
382 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
385 return c1
< c2
? Qt
: Qnil
;
387 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
390 static Lisp_Object
concat ();
401 return concat (2, args
, Lisp_String
, 0);
403 return concat (2, &s1
, Lisp_String
, 0);
404 #endif /* NO_ARG_ARRAY */
410 Lisp_Object s1
, s2
, s3
;
417 return concat (3, args
, Lisp_String
, 0);
419 return concat (3, &s1
, Lisp_String
, 0);
420 #endif /* NO_ARG_ARRAY */
423 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
424 doc
: /* Concatenate all the arguments and make the result a list.
425 The result is a list whose elements are the elements of all the arguments.
426 Each argument may be a list, vector or string.
427 The last argument is not copied, just used as the tail of the new list.
428 usage: (append &rest SEQUENCES) */)
433 return concat (nargs
, args
, Lisp_Cons
, 1);
436 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
437 doc
: /* Concatenate all the arguments and make the result a string.
438 The result is a string whose elements are the elements of all the arguments.
439 Each argument may be a string or a list or vector of characters (integers).
440 usage: (concat &rest SEQUENCES) */)
445 return concat (nargs
, args
, Lisp_String
, 0);
448 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
449 doc
: /* Concatenate all the arguments and make the result a vector.
450 The result is a vector whose elements are the elements of all the arguments.
451 Each argument may be a list, vector or string.
452 usage: (vconcat &rest SEQUENCES) */)
457 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
460 /* Return a copy of a sub char table ARG. The elements except for a
461 nested sub char table are not copied. */
463 copy_sub_char_table (arg
)
466 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
469 /* Copy all the contents. */
470 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
471 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
472 /* Recursively copy any sub char-tables in the ordinary slots. */
473 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
474 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
475 XCHAR_TABLE (copy
)->contents
[i
]
476 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
482 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
483 doc
: /* Return a copy of a list, vector, string or char-table.
484 The elements of a list or vector are not copied; they are shared
485 with the original. */)
489 if (NILP (arg
)) return arg
;
491 if (CHAR_TABLE_P (arg
))
496 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
497 /* Copy all the slots, including the extra ones. */
498 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
499 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
500 * sizeof (Lisp_Object
)));
502 /* Recursively copy any sub char tables in the ordinary slots
503 for multibyte characters. */
504 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
505 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
506 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
507 XCHAR_TABLE (copy
)->contents
[i
]
508 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
513 if (BOOL_VECTOR_P (arg
))
517 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
518 / BOOL_VECTOR_BITS_PER_CHAR
);
520 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
521 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
526 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
527 arg
= wrong_type_argument (Qsequencep
, arg
);
528 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
531 /* This structure holds information of an argument of `concat' that is
532 a string and has text properties to be copied. */
535 int argnum
; /* refer to ARGS (arguments of `concat') */
536 int from
; /* refer to ARGS[argnum] (argument string) */
537 int to
; /* refer to VAL (the target string) */
541 concat (nargs
, args
, target_type
, last_special
)
544 enum Lisp_Type target_type
;
548 register Lisp_Object tail
;
549 register Lisp_Object
this;
551 int toindex_byte
= 0;
552 register int result_len
;
553 register int result_len_byte
;
555 Lisp_Object last_tail
;
558 /* When we make a multibyte string, we can't copy text properties
559 while concatinating each string because the length of resulting
560 string can't be decided until we finish the whole concatination.
561 So, we record strings that have text properties to be copied
562 here, and copy the text properties after the concatination. */
563 struct textprop_rec
*textprops
= NULL
;
564 /* Number of elments in textprops. */
565 int num_textprops
= 0;
570 /* In append, the last arg isn't treated like the others */
571 if (last_special
&& nargs
> 0)
574 last_tail
= args
[nargs
];
579 /* Canonicalize each argument. */
580 for (argnum
= 0; argnum
< nargs
; argnum
++)
583 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
584 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
586 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
590 /* Compute total length in chars of arguments in RESULT_LEN.
591 If desired output is a string, also compute length in bytes
592 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
593 whether the result should be a multibyte string. */
597 for (argnum
= 0; argnum
< nargs
; argnum
++)
601 len
= XFASTINT (Flength (this));
602 if (target_type
== Lisp_String
)
604 /* We must count the number of bytes needed in the string
605 as well as the number of characters. */
611 for (i
= 0; i
< len
; i
++)
613 ch
= XVECTOR (this)->contents
[i
];
615 wrong_type_argument (Qintegerp
, ch
);
616 this_len_byte
= CHAR_BYTES (XINT (ch
));
617 result_len_byte
+= this_len_byte
;
618 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
621 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
622 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
623 else if (CONSP (this))
624 for (; CONSP (this); this = XCDR (this))
628 wrong_type_argument (Qintegerp
, ch
);
629 this_len_byte
= CHAR_BYTES (XINT (ch
));
630 result_len_byte
+= this_len_byte
;
631 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
634 else if (STRINGP (this))
636 if (STRING_MULTIBYTE (this))
639 result_len_byte
+= SBYTES (this);
642 result_len_byte
+= count_size_as_multibyte (SDATA (this),
650 if (! some_multibyte
)
651 result_len_byte
= result_len
;
653 /* Create the output object. */
654 if (target_type
== Lisp_Cons
)
655 val
= Fmake_list (make_number (result_len
), Qnil
);
656 else if (target_type
== Lisp_Vectorlike
)
657 val
= Fmake_vector (make_number (result_len
), Qnil
);
658 else if (some_multibyte
)
659 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
661 val
= make_uninit_string (result_len
);
663 /* In `append', if all but last arg are nil, return last arg. */
664 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
667 /* Copy the contents of the args into the result. */
669 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
671 toindex
= 0, toindex_byte
= 0;
675 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
677 for (argnum
= 0; argnum
< nargs
; argnum
++)
681 register unsigned int thisindex
= 0;
682 register unsigned int thisindex_byte
= 0;
686 thislen
= Flength (this), thisleni
= XINT (thislen
);
688 /* Between strings of the same kind, copy fast. */
689 if (STRINGP (this) && STRINGP (val
)
690 && STRING_MULTIBYTE (this) == some_multibyte
)
692 int thislen_byte
= SBYTES (this);
694 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
696 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
698 textprops
[num_textprops
].argnum
= argnum
;
699 textprops
[num_textprops
].from
= 0;
700 textprops
[num_textprops
++].to
= toindex
;
702 toindex_byte
+= thislen_byte
;
704 STRING_SET_CHARS (val
, SCHARS (val
));
706 /* Copy a single-byte string to a multibyte string. */
707 else if (STRINGP (this) && STRINGP (val
))
709 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
711 textprops
[num_textprops
].argnum
= argnum
;
712 textprops
[num_textprops
].from
= 0;
713 textprops
[num_textprops
++].to
= toindex
;
715 toindex_byte
+= copy_text (SDATA (this),
716 SDATA (val
) + toindex_byte
,
717 SCHARS (this), 0, 1);
721 /* Copy element by element. */
724 register Lisp_Object elt
;
726 /* Fetch next element of `this' arg into `elt', or break if
727 `this' is exhausted. */
728 if (NILP (this)) break;
730 elt
= XCAR (this), this = XCDR (this);
731 else if (thisindex
>= thisleni
)
733 else if (STRINGP (this))
736 if (STRING_MULTIBYTE (this))
738 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
741 XSETFASTINT (elt
, c
);
745 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
747 && (XINT (elt
) >= 0240
748 || (XINT (elt
) >= 0200
749 && ! NILP (Vnonascii_translation_table
)))
750 && XINT (elt
) < 0400)
752 c
= unibyte_char_to_multibyte (XINT (elt
));
757 else if (BOOL_VECTOR_P (this))
760 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
761 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
768 elt
= XVECTOR (this)->contents
[thisindex
++];
770 /* Store this element into the result. */
777 else if (VECTORP (val
))
778 XVECTOR (val
)->contents
[toindex
++] = elt
;
782 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
786 += CHAR_STRING (XINT (elt
),
787 SDATA (val
) + toindex_byte
);
789 SSET (val
, toindex_byte
++, XINT (elt
));
793 /* If we have any multibyte characters,
794 we already decided to make a multibyte string. */
797 /* P exists as a variable
798 to avoid a bug on the Masscomp C compiler. */
799 unsigned char *p
= SDATA (val
) + toindex_byte
;
801 toindex_byte
+= CHAR_STRING (c
, p
);
808 XSETCDR (prev
, last_tail
);
810 if (num_textprops
> 0)
813 int last_to_end
= -1;
815 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
817 this = args
[textprops
[argnum
].argnum
];
818 props
= text_property_list (this,
820 make_number (SCHARS (this)),
822 /* If successive arguments have properites, be sure that the
823 value of `composition' property be the copy. */
824 if (last_to_end
== textprops
[argnum
].to
)
825 make_composition_value_copy (props
);
826 add_text_properties_from_list (val
, props
,
827 make_number (textprops
[argnum
].to
));
828 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
836 static Lisp_Object string_char_byte_cache_string
;
837 static int string_char_byte_cache_charpos
;
838 static int string_char_byte_cache_bytepos
;
841 clear_string_char_byte_cache ()
843 string_char_byte_cache_string
= Qnil
;
846 /* Return the character index corresponding to CHAR_INDEX in STRING. */
849 string_char_to_byte (string
, char_index
)
854 int best_below
, best_below_byte
;
855 int best_above
, best_above_byte
;
857 best_below
= best_below_byte
= 0;
858 best_above
= SCHARS (string
);
859 best_above_byte
= SBYTES (string
);
860 if (best_above
== best_above_byte
)
863 if (EQ (string
, string_char_byte_cache_string
))
865 if (string_char_byte_cache_charpos
< char_index
)
867 best_below
= string_char_byte_cache_charpos
;
868 best_below_byte
= string_char_byte_cache_bytepos
;
872 best_above
= string_char_byte_cache_charpos
;
873 best_above_byte
= string_char_byte_cache_bytepos
;
877 if (char_index
- best_below
< best_above
- char_index
)
879 while (best_below
< char_index
)
882 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
883 best_below
, best_below_byte
);
886 i_byte
= best_below_byte
;
890 while (best_above
> char_index
)
892 unsigned char *pend
= SDATA (string
) + best_above_byte
;
893 unsigned char *pbeg
= pend
- best_above_byte
;
894 unsigned char *p
= pend
- 1;
897 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
898 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
899 if (bytes
== pend
- p
)
900 best_above_byte
-= bytes
;
901 else if (bytes
> pend
- p
)
902 best_above_byte
-= (pend
- p
);
908 i_byte
= best_above_byte
;
911 string_char_byte_cache_bytepos
= i_byte
;
912 string_char_byte_cache_charpos
= i
;
913 string_char_byte_cache_string
= string
;
918 /* Return the character index corresponding to BYTE_INDEX in STRING. */
921 string_byte_to_char (string
, byte_index
)
926 int best_below
, best_below_byte
;
927 int best_above
, best_above_byte
;
929 best_below
= best_below_byte
= 0;
930 best_above
= SCHARS (string
);
931 best_above_byte
= SBYTES (string
);
932 if (best_above
== best_above_byte
)
935 if (EQ (string
, string_char_byte_cache_string
))
937 if (string_char_byte_cache_bytepos
< byte_index
)
939 best_below
= string_char_byte_cache_charpos
;
940 best_below_byte
= string_char_byte_cache_bytepos
;
944 best_above
= string_char_byte_cache_charpos
;
945 best_above_byte
= string_char_byte_cache_bytepos
;
949 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
951 while (best_below_byte
< byte_index
)
954 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
955 best_below
, best_below_byte
);
958 i_byte
= best_below_byte
;
962 while (best_above_byte
> byte_index
)
964 unsigned char *pend
= SDATA (string
) + best_above_byte
;
965 unsigned char *pbeg
= pend
- best_above_byte
;
966 unsigned char *p
= pend
- 1;
969 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
970 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
971 if (bytes
== pend
- p
)
972 best_above_byte
-= bytes
;
973 else if (bytes
> pend
- p
)
974 best_above_byte
-= (pend
- p
);
980 i_byte
= best_above_byte
;
983 string_char_byte_cache_bytepos
= i_byte
;
984 string_char_byte_cache_charpos
= i
;
985 string_char_byte_cache_string
= string
;
990 /* Convert STRING to a multibyte string.
991 Single-byte characters 0240 through 0377 are converted
992 by adding nonascii_insert_offset to each. */
995 string_make_multibyte (string
)
1003 if (STRING_MULTIBYTE (string
))
1006 nbytes
= count_size_as_multibyte (SDATA (string
),
1008 /* If all the chars are ASCII, they won't need any more bytes
1009 once converted. In that case, we can return STRING itself. */
1010 if (nbytes
== SBYTES (string
))
1013 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1014 copy_text (SDATA (string
), buf
, SBYTES (string
),
1017 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1024 /* Convert STRING to a multibyte string without changing each
1025 character codes. Thus, characters 0200 trough 0237 are converted
1026 to eight-bit-control characters, and characters 0240 through 0377
1027 are converted eight-bit-graphic characters. */
1030 string_to_multibyte (string
)
1038 if (STRING_MULTIBYTE (string
))
1041 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1042 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1043 any more bytes once converted. */
1044 if (nbytes
== SBYTES (string
))
1045 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1047 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1048 bcopy (SDATA (string
), buf
, SBYTES (string
));
1049 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1051 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1058 /* Convert STRING to a single-byte string. */
1061 string_make_unibyte (string
)
1069 if (! STRING_MULTIBYTE (string
))
1072 nchars
= SCHARS (string
);
1074 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1075 copy_text (SDATA (string
), buf
, SBYTES (string
),
1078 ret
= make_unibyte_string (buf
, nchars
);
1084 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1086 doc
: /* Return the multibyte equivalent of STRING.
1087 If STRING is unibyte and contains non-ASCII characters, the function
1088 `unibyte-char-to-multibyte' is used to convert each unibyte character
1089 to a multibyte character. In this case, the returned string is a
1090 newly created string with no text properties. If STRING is multibyte
1091 or entirely ASCII, it is returned unchanged. In particular, when
1092 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1093 \(When the characters are all ASCII, Emacs primitives will treat the
1094 string the same way whether it is unibyte or multibyte.) */)
1098 CHECK_STRING (string
);
1100 return string_make_multibyte (string
);
1103 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1105 doc
: /* Return the unibyte equivalent of STRING.
1106 Multibyte character codes are converted to unibyte according to
1107 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1108 If the lookup in the translation table fails, this function takes just
1109 the low 8 bits of each character. */)
1113 CHECK_STRING (string
);
1115 return string_make_unibyte (string
);
1118 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1120 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1121 If STRING is unibyte, the result is STRING itself.
1122 Otherwise it is a newly created string, with no text properties.
1123 If STRING is multibyte and contains a character of charset
1124 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1125 corresponding single byte. */)
1129 CHECK_STRING (string
);
1131 if (STRING_MULTIBYTE (string
))
1133 int bytes
= SBYTES (string
);
1134 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1136 bcopy (SDATA (string
), str
, bytes
);
1137 bytes
= str_as_unibyte (str
, bytes
);
1138 string
= make_unibyte_string (str
, bytes
);
1144 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1146 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1147 If STRING is multibyte, the result is STRING itself.
1148 Otherwise it is a newly created string, with no text properties.
1149 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1150 part of a multibyte form), it is converted to the corresponding
1151 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1155 CHECK_STRING (string
);
1157 if (! STRING_MULTIBYTE (string
))
1159 Lisp_Object new_string
;
1162 parse_str_as_multibyte (SDATA (string
),
1165 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1166 bcopy (SDATA (string
), SDATA (new_string
),
1168 if (nbytes
!= SBYTES (string
))
1169 str_as_multibyte (SDATA (new_string
), nbytes
,
1170 SBYTES (string
), NULL
);
1171 string
= new_string
;
1172 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1177 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1179 doc
: /* Return a multibyte string with the same individual chars as STRING.
1180 If STRING is multibyte, the result is STRING itself.
1181 Otherwise it is a newly created string, with no text properties.
1182 Characters 0200 through 0237 are converted to eight-bit-control
1183 characters of the same character code. Characters 0240 through 0377
1184 are converted to eight-bit-graphic characters of the same character
1189 CHECK_STRING (string
);
1191 return string_to_multibyte (string
);
1195 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1196 doc
: /* Return a copy of ALIST.
1197 This is an alist which represents the same mapping from objects to objects,
1198 but does not share the alist structure with ALIST.
1199 The objects mapped (cars and cdrs of elements of the alist)
1200 are shared, however.
1201 Elements of ALIST that are not conses are also shared. */)
1205 register Lisp_Object tem
;
1210 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1211 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1213 register Lisp_Object car
;
1217 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1222 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1223 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1224 TO may be nil or omitted; then the substring runs to the end of STRING.
1225 FROM and TO start at 0. If either is negative, it counts from the end.
1227 This function allows vectors as well as strings. */)
1230 register Lisp_Object from
, to
;
1235 int from_char
, to_char
;
1236 int from_byte
= 0, to_byte
= 0;
1238 if (! (STRINGP (string
) || VECTORP (string
)))
1239 wrong_type_argument (Qarrayp
, string
);
1241 CHECK_NUMBER (from
);
1243 if (STRINGP (string
))
1245 size
= SCHARS (string
);
1246 size_byte
= SBYTES (string
);
1249 size
= XVECTOR (string
)->size
;
1254 to_byte
= size_byte
;
1260 to_char
= XINT (to
);
1264 if (STRINGP (string
))
1265 to_byte
= string_char_to_byte (string
, to_char
);
1268 from_char
= XINT (from
);
1271 if (STRINGP (string
))
1272 from_byte
= string_char_to_byte (string
, from_char
);
1274 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1275 args_out_of_range_3 (string
, make_number (from_char
),
1276 make_number (to_char
));
1278 if (STRINGP (string
))
1280 res
= make_specified_string (SDATA (string
) + from_byte
,
1281 to_char
- from_char
, to_byte
- from_byte
,
1282 STRING_MULTIBYTE (string
));
1283 copy_text_properties (make_number (from_char
), make_number (to_char
),
1284 string
, make_number (0), res
, Qnil
);
1287 res
= Fvector (to_char
- from_char
,
1288 XVECTOR (string
)->contents
+ from_char
);
1294 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1295 doc
: /* Return a substring of STRING, without text properties.
1296 It starts at index FROM and ending before TO.
1297 TO may be nil or omitted; then the substring runs to the end of STRING.
1298 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1299 If FROM or TO is negative, it counts from the end.
1301 With one argument, just copy STRING without its properties. */)
1304 register Lisp_Object from
, to
;
1306 int size
, size_byte
;
1307 int from_char
, to_char
;
1308 int from_byte
, to_byte
;
1310 CHECK_STRING (string
);
1312 size
= SCHARS (string
);
1313 size_byte
= SBYTES (string
);
1316 from_char
= from_byte
= 0;
1319 CHECK_NUMBER (from
);
1320 from_char
= XINT (from
);
1324 from_byte
= string_char_to_byte (string
, from_char
);
1330 to_byte
= size_byte
;
1336 to_char
= XINT (to
);
1340 to_byte
= string_char_to_byte (string
, to_char
);
1343 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1344 args_out_of_range_3 (string
, make_number (from_char
),
1345 make_number (to_char
));
1347 return make_specified_string (SDATA (string
) + from_byte
,
1348 to_char
- from_char
, to_byte
- from_byte
,
1349 STRING_MULTIBYTE (string
));
1352 /* Extract a substring of STRING, giving start and end positions
1353 both in characters and in bytes. */
1356 substring_both (string
, from
, from_byte
, to
, to_byte
)
1358 int from
, from_byte
, to
, to_byte
;
1364 if (! (STRINGP (string
) || VECTORP (string
)))
1365 wrong_type_argument (Qarrayp
, string
);
1367 if (STRINGP (string
))
1369 size
= SCHARS (string
);
1370 size_byte
= SBYTES (string
);
1373 size
= XVECTOR (string
)->size
;
1375 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1376 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1378 if (STRINGP (string
))
1380 res
= make_specified_string (SDATA (string
) + from_byte
,
1381 to
- from
, to_byte
- from_byte
,
1382 STRING_MULTIBYTE (string
));
1383 copy_text_properties (make_number (from
), make_number (to
),
1384 string
, make_number (0), res
, Qnil
);
1387 res
= Fvector (to
- from
,
1388 XVECTOR (string
)->contents
+ from
);
1393 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1394 doc
: /* Take cdr N times on LIST, returns the result. */)
1397 register Lisp_Object list
;
1399 register int i
, num
;
1402 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1406 wrong_type_argument (Qlistp
, list
);
1412 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1413 doc
: /* Return the Nth element of LIST.
1414 N counts from zero. If LIST is not that long, nil is returned. */)
1416 Lisp_Object n
, list
;
1418 return Fcar (Fnthcdr (n
, list
));
1421 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1422 doc
: /* Return element of SEQUENCE at index N. */)
1424 register Lisp_Object sequence
, n
;
1429 if (CONSP (sequence
) || NILP (sequence
))
1430 return Fcar (Fnthcdr (n
, sequence
));
1431 else if (STRINGP (sequence
) || VECTORP (sequence
)
1432 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1433 return Faref (sequence
, n
);
1435 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1439 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1440 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1441 The value is actually the tail of LIST whose car is ELT. */)
1443 register Lisp_Object elt
;
1446 register Lisp_Object tail
;
1447 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1449 register Lisp_Object tem
;
1451 wrong_type_argument (Qlistp
, list
);
1453 if (! NILP (Fequal (elt
, tem
)))
1460 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1461 doc
: /* Return non-nil if ELT is an element of LIST.
1462 Comparison done with EQ. The value is actually the tail of LIST
1463 whose car is ELT. */)
1465 Lisp_Object elt
, list
;
1469 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1473 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1477 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1484 if (!CONSP (list
) && !NILP (list
))
1485 list
= wrong_type_argument (Qlistp
, list
);
1490 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1491 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1492 The value is actually the first element of LIST whose car is KEY.
1493 Elements of LIST that are not conses are ignored. */)
1495 Lisp_Object key
, list
;
1502 || (CONSP (XCAR (list
))
1503 && EQ (XCAR (XCAR (list
)), key
)))
1508 || (CONSP (XCAR (list
))
1509 && EQ (XCAR (XCAR (list
)), key
)))
1514 || (CONSP (XCAR (list
))
1515 && EQ (XCAR (XCAR (list
)), key
)))
1523 result
= XCAR (list
);
1524 else if (NILP (list
))
1527 result
= wrong_type_argument (Qlistp
, list
);
1532 /* Like Fassq but never report an error and do not allow quits.
1533 Use only on lists known never to be circular. */
1536 assq_no_quit (key
, list
)
1537 Lisp_Object key
, list
;
1540 && (!CONSP (XCAR (list
))
1541 || !EQ (XCAR (XCAR (list
)), key
)))
1544 return CONSP (list
) ? XCAR (list
) : Qnil
;
1547 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1548 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1549 The value is actually the first element of LIST whose car equals KEY. */)
1551 Lisp_Object key
, list
;
1553 Lisp_Object result
, car
;
1558 || (CONSP (XCAR (list
))
1559 && (car
= XCAR (XCAR (list
)),
1560 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1565 || (CONSP (XCAR (list
))
1566 && (car
= XCAR (XCAR (list
)),
1567 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1572 || (CONSP (XCAR (list
))
1573 && (car
= XCAR (XCAR (list
)),
1574 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1582 result
= XCAR (list
);
1583 else if (NILP (list
))
1586 result
= wrong_type_argument (Qlistp
, list
);
1591 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1592 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1593 The value is actually the first element of LIST whose cdr is KEY. */)
1595 register Lisp_Object key
;
1603 || (CONSP (XCAR (list
))
1604 && EQ (XCDR (XCAR (list
)), key
)))
1609 || (CONSP (XCAR (list
))
1610 && EQ (XCDR (XCAR (list
)), key
)))
1615 || (CONSP (XCAR (list
))
1616 && EQ (XCDR (XCAR (list
)), key
)))
1625 else if (CONSP (list
))
1626 result
= XCAR (list
);
1628 result
= wrong_type_argument (Qlistp
, list
);
1633 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1634 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1635 The value is actually the first element of LIST whose cdr equals KEY. */)
1637 Lisp_Object key
, list
;
1639 Lisp_Object result
, cdr
;
1644 || (CONSP (XCAR (list
))
1645 && (cdr
= XCDR (XCAR (list
)),
1646 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1651 || (CONSP (XCAR (list
))
1652 && (cdr
= XCDR (XCAR (list
)),
1653 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1658 || (CONSP (XCAR (list
))
1659 && (cdr
= XCDR (XCAR (list
)),
1660 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1668 result
= XCAR (list
);
1669 else if (NILP (list
))
1672 result
= wrong_type_argument (Qlistp
, list
);
1677 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1678 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1679 The modified LIST is returned. Comparison is done with `eq'.
1680 If the first member of LIST is ELT, there is no way to remove it by side effect;
1681 therefore, write `(setq foo (delq element foo))'
1682 to be sure of changing the value of `foo'. */)
1684 register Lisp_Object elt
;
1687 register Lisp_Object tail
, prev
;
1688 register Lisp_Object tem
;
1692 while (!NILP (tail
))
1695 wrong_type_argument (Qlistp
, list
);
1702 Fsetcdr (prev
, XCDR (tail
));
1712 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1713 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1714 SEQ must be a list, a vector, or a string.
1715 The modified SEQ is returned. Comparison is done with `equal'.
1716 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1717 is not a side effect; it is simply using a different sequence.
1718 Therefore, write `(setq foo (delete element foo))'
1719 to be sure of changing the value of `foo'. */)
1721 Lisp_Object elt
, seq
;
1727 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1728 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1731 if (n
!= ASIZE (seq
))
1733 struct Lisp_Vector
*p
= allocate_vector (n
);
1735 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1736 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1737 p
->contents
[n
++] = AREF (seq
, i
);
1739 XSETVECTOR (seq
, p
);
1742 else if (STRINGP (seq
))
1744 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1747 for (i
= nchars
= nbytes
= ibyte
= 0;
1749 ++i
, ibyte
+= cbytes
)
1751 if (STRING_MULTIBYTE (seq
))
1753 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1754 SBYTES (seq
) - ibyte
);
1755 cbytes
= CHAR_BYTES (c
);
1763 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1770 if (nchars
!= SCHARS (seq
))
1774 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1775 if (!STRING_MULTIBYTE (seq
))
1776 STRING_SET_UNIBYTE (tem
);
1778 for (i
= nchars
= nbytes
= ibyte
= 0;
1780 ++i
, ibyte
+= cbytes
)
1782 if (STRING_MULTIBYTE (seq
))
1784 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1785 SBYTES (seq
) - ibyte
);
1786 cbytes
= CHAR_BYTES (c
);
1794 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1796 unsigned char *from
= SDATA (seq
) + ibyte
;
1797 unsigned char *to
= SDATA (tem
) + nbytes
;
1803 for (n
= cbytes
; n
--; )
1813 Lisp_Object tail
, prev
;
1815 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1818 wrong_type_argument (Qlistp
, seq
);
1820 if (!NILP (Fequal (elt
, XCAR (tail
))))
1825 Fsetcdr (prev
, XCDR (tail
));
1836 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1837 doc
: /* Reverse LIST by modifying cdr pointers.
1838 Return the reversed list. */)
1842 register Lisp_Object prev
, tail
, next
;
1844 if (NILP (list
)) return list
;
1847 while (!NILP (tail
))
1851 wrong_type_argument (Qlistp
, list
);
1853 Fsetcdr (tail
, prev
);
1860 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1861 doc
: /* Reverse LIST, copying. Return the reversed list.
1862 See also the function `nreverse', which is used more often. */)
1868 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1871 new = Fcons (XCAR (list
), new);
1874 wrong_type_argument (Qconsp
, list
);
1878 Lisp_Object
merge ();
1880 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1881 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1882 Returns the sorted list. LIST is modified by side effects.
1883 PREDICATE is called with two elements of LIST, and should return t
1884 if the first element is "less" than the second. */)
1886 Lisp_Object list
, predicate
;
1888 Lisp_Object front
, back
;
1889 register Lisp_Object len
, tem
;
1890 struct gcpro gcpro1
, gcpro2
;
1891 register int length
;
1894 len
= Flength (list
);
1895 length
= XINT (len
);
1899 XSETINT (len
, (length
/ 2) - 1);
1900 tem
= Fnthcdr (len
, list
);
1902 Fsetcdr (tem
, Qnil
);
1904 GCPRO2 (front
, back
);
1905 front
= Fsort (front
, predicate
);
1906 back
= Fsort (back
, predicate
);
1908 return merge (front
, back
, predicate
);
1912 merge (org_l1
, org_l2
, pred
)
1913 Lisp_Object org_l1
, org_l2
;
1917 register Lisp_Object tail
;
1919 register Lisp_Object l1
, l2
;
1920 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1927 /* It is sufficient to protect org_l1 and org_l2.
1928 When l1 and l2 are updated, we copy the new values
1929 back into the org_ vars. */
1930 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1950 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1966 Fsetcdr (tail
, tem
);
1972 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1973 doc
: /* Extract a value from a property list.
1974 PLIST is a property list, which is a list of the form
1975 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1976 corresponding to the given PROP, or nil if PROP is not
1977 one of the properties on the list. */)
1985 CONSP (tail
) && CONSP (XCDR (tail
));
1986 tail
= XCDR (XCDR (tail
)))
1988 if (EQ (prop
, XCAR (tail
)))
1989 return XCAR (XCDR (tail
));
1991 /* This function can be called asynchronously
1992 (setup_coding_system). Don't QUIT in that case. */
1993 if (!interrupt_input_blocked
)
1998 wrong_type_argument (Qlistp
, prop
);
2003 DEFUN ("safe-plist-get", Fsafe_plist_get
, Ssafe_plist_get
, 2, 2, 0,
2004 doc
: /* Extract a value from a property list.
2005 PLIST is a property list, which is a list of the form
2006 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2007 corresponding to the given PROP, or nil if PROP is not
2008 one of the properties on the list.
2009 This function never signals an error. */)
2014 Lisp_Object tail
, halftail
;
2016 /* halftail is used to detect circular lists. */
2017 tail
= halftail
= plist
;
2018 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2020 if (EQ (prop
, XCAR (tail
)))
2021 return XCAR (XCDR (tail
));
2023 tail
= XCDR (XCDR (tail
));
2024 halftail
= XCDR (halftail
);
2025 if (EQ (tail
, halftail
))
2032 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2033 doc
: /* Return the value of SYMBOL's PROPNAME property.
2034 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2036 Lisp_Object symbol
, propname
;
2038 CHECK_SYMBOL (symbol
);
2039 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2042 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2043 doc
: /* Change value in PLIST of PROP to VAL.
2044 PLIST is a property list, which is a list of the form
2045 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2046 If PROP is already a property on the list, its value is set to VAL,
2047 otherwise the new PROP VAL pair is added. The new plist is returned;
2048 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2049 The PLIST is modified by side effects. */)
2052 register Lisp_Object prop
;
2055 register Lisp_Object tail
, prev
;
2056 Lisp_Object newcell
;
2058 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2059 tail
= XCDR (XCDR (tail
)))
2061 if (EQ (prop
, XCAR (tail
)))
2063 Fsetcar (XCDR (tail
), val
);
2070 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2074 Fsetcdr (XCDR (prev
), newcell
);
2078 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2079 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2080 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2081 (symbol
, propname
, value
)
2082 Lisp_Object symbol
, propname
, value
;
2084 CHECK_SYMBOL (symbol
);
2085 XSYMBOL (symbol
)->plist
2086 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2090 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2091 doc
: /* Extract a value from a property list, comparing with `equal'.
2092 PLIST is a property list, which is a list of the form
2093 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2094 corresponding to the given PROP, or nil if PROP is not
2095 one of the properties on the list. */)
2103 CONSP (tail
) && CONSP (XCDR (tail
));
2104 tail
= XCDR (XCDR (tail
)))
2106 if (! NILP (Fequal (prop
, XCAR (tail
))))
2107 return XCAR (XCDR (tail
));
2113 wrong_type_argument (Qlistp
, prop
);
2118 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2119 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2120 PLIST is a property list, which is a list of the form
2121 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2122 If PROP is already a property on the list, its value is set to VAL,
2123 otherwise the new PROP VAL pair is added. The new plist is returned;
2124 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2125 The PLIST is modified by side effects. */)
2128 register Lisp_Object prop
;
2131 register Lisp_Object tail
, prev
;
2132 Lisp_Object newcell
;
2134 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2135 tail
= XCDR (XCDR (tail
)))
2137 if (! NILP (Fequal (prop
, XCAR (tail
))))
2139 Fsetcar (XCDR (tail
), val
);
2146 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2150 Fsetcdr (XCDR (prev
), newcell
);
2154 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2155 doc
: /* Return t if the two args are the same Lisp object.
2156 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2158 Lisp_Object obj1
, obj2
;
2161 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2163 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2166 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2167 doc
: /* Return t if two Lisp objects have similar structure and contents.
2168 They must have the same data type.
2169 Conses are compared by comparing the cars and the cdrs.
2170 Vectors and strings are compared element by element.
2171 Numbers are compared by value, but integers cannot equal floats.
2172 (Use `=' if you want integers and floats to be able to be equal.)
2173 Symbols must match exactly. */)
2175 register Lisp_Object o1
, o2
;
2177 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2180 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2181 doc
: /* Return t if two Lisp objects have similar structure and contents.
2182 This is like `equal' except that it compares the text properties
2183 of strings. (`equal' ignores text properties.) */)
2185 register Lisp_Object o1
, o2
;
2187 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2190 /* DEPTH is current depth of recursion. Signal an error if it
2192 PROPS, if non-nil, means compare string text properties too. */
2195 internal_equal (o1
, o2
, depth
, props
)
2196 register Lisp_Object o1
, o2
;
2200 error ("Stack overflow in equal");
2206 if (XTYPE (o1
) != XTYPE (o2
))
2215 d1
= extract_float (o1
);
2216 d2
= extract_float (o2
);
2217 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2218 though they are not =. */
2219 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2223 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2230 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2234 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2236 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2239 o1
= XOVERLAY (o1
)->plist
;
2240 o2
= XOVERLAY (o2
)->plist
;
2245 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2246 && (XMARKER (o1
)->buffer
== 0
2247 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2251 case Lisp_Vectorlike
:
2254 EMACS_INT size
= XVECTOR (o1
)->size
;
2255 /* Pseudovectors have the type encoded in the size field, so this test
2256 actually checks that the objects have the same type as well as the
2258 if (XVECTOR (o2
)->size
!= size
)
2260 /* Boolvectors are compared much like strings. */
2261 if (BOOL_VECTOR_P (o1
))
2264 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2265 / BOOL_VECTOR_BITS_PER_CHAR
);
2267 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2269 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2274 if (WINDOW_CONFIGURATIONP (o1
))
2275 return compare_window_configurations (o1
, o2
, 0);
2277 /* Aside from them, only true vectors, char-tables, and compiled
2278 functions are sensible to compare, so eliminate the others now. */
2279 if (size
& PSEUDOVECTOR_FLAG
)
2281 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2283 size
&= PSEUDOVECTOR_SIZE_MASK
;
2285 for (i
= 0; i
< size
; i
++)
2288 v1
= XVECTOR (o1
)->contents
[i
];
2289 v2
= XVECTOR (o2
)->contents
[i
];
2290 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2298 if (SCHARS (o1
) != SCHARS (o2
))
2300 if (SBYTES (o1
) != SBYTES (o2
))
2302 if (bcmp (SDATA (o1
), SDATA (o2
),
2305 if (props
&& !compare_string_intervals (o1
, o2
))
2311 case Lisp_Type_Limit
:
2318 extern Lisp_Object
Fmake_char_internal ();
2320 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2321 doc
: /* Store each element of ARRAY with ITEM.
2322 ARRAY is a vector, string, char-table, or bool-vector. */)
2324 Lisp_Object array
, item
;
2326 register int size
, index
, charval
;
2328 if (VECTORP (array
))
2330 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2331 size
= XVECTOR (array
)->size
;
2332 for (index
= 0; index
< size
; index
++)
2335 else if (CHAR_TABLE_P (array
))
2337 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2338 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2339 for (index
= 0; index
< size
; index
++)
2341 XCHAR_TABLE (array
)->defalt
= Qnil
;
2343 else if (STRINGP (array
))
2345 register unsigned char *p
= SDATA (array
);
2346 CHECK_NUMBER (item
);
2347 charval
= XINT (item
);
2348 size
= SCHARS (array
);
2349 if (STRING_MULTIBYTE (array
))
2351 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2352 int len
= CHAR_STRING (charval
, str
);
2353 int size_byte
= SBYTES (array
);
2354 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2357 if (size
!= size_byte
)
2360 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2361 if (len
!= this_len
)
2362 error ("Attempt to change byte length of a string");
2365 for (i
= 0; i
< size_byte
; i
++)
2366 *p
++ = str
[i
% len
];
2369 for (index
= 0; index
< size
; index
++)
2372 else if (BOOL_VECTOR_P (array
))
2374 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2376 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2377 / BOOL_VECTOR_BITS_PER_CHAR
);
2379 charval
= (! NILP (item
) ? -1 : 0);
2380 for (index
= 0; index
< size_in_chars
- 1; index
++)
2382 if (index
< size_in_chars
)
2384 /* Mask out bits beyond the vector size. */
2385 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2386 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2392 array
= wrong_type_argument (Qarrayp
, array
);
2398 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2400 doc
: /* Clear the contents of STRING.
2401 This makes STRING unibyte and may change its length. */)
2406 CHECK_STRING (string
);
2407 len
= SBYTES (string
);
2408 bzero (SDATA (string
), len
);
2409 STRING_SET_CHARS (string
, len
);
2410 STRING_SET_UNIBYTE (string
);
2414 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2416 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2418 Lisp_Object char_table
;
2420 CHECK_CHAR_TABLE (char_table
);
2422 return XCHAR_TABLE (char_table
)->purpose
;
2425 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2427 doc
: /* Return the parent char-table of CHAR-TABLE.
2428 The value is either nil or another char-table.
2429 If CHAR-TABLE holds nil for a given character,
2430 then the actual applicable value is inherited from the parent char-table
2431 \(or from its parents, if necessary). */)
2433 Lisp_Object char_table
;
2435 CHECK_CHAR_TABLE (char_table
);
2437 return XCHAR_TABLE (char_table
)->parent
;
2440 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2442 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2443 Return PARENT. PARENT must be either nil or another char-table. */)
2444 (char_table
, parent
)
2445 Lisp_Object char_table
, parent
;
2449 CHECK_CHAR_TABLE (char_table
);
2453 CHECK_CHAR_TABLE (parent
);
2455 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2456 if (EQ (temp
, char_table
))
2457 error ("Attempt to make a chartable be its own parent");
2460 XCHAR_TABLE (char_table
)->parent
= parent
;
2465 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2467 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2469 Lisp_Object char_table
, n
;
2471 CHECK_CHAR_TABLE (char_table
);
2474 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2475 args_out_of_range (char_table
, n
);
2477 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2480 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2481 Sset_char_table_extra_slot
,
2483 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2484 (char_table
, n
, value
)
2485 Lisp_Object char_table
, n
, value
;
2487 CHECK_CHAR_TABLE (char_table
);
2490 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2491 args_out_of_range (char_table
, n
);
2493 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2496 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2498 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2499 RANGE should be nil (for the default value)
2500 a vector which identifies a character set or a row of a character set,
2501 a character set name, or a character code. */)
2503 Lisp_Object char_table
, range
;
2505 CHECK_CHAR_TABLE (char_table
);
2507 if (EQ (range
, Qnil
))
2508 return XCHAR_TABLE (char_table
)->defalt
;
2509 else if (INTEGERP (range
))
2510 return Faref (char_table
, range
);
2511 else if (SYMBOLP (range
))
2513 Lisp_Object charset_info
;
2515 charset_info
= Fget (range
, Qcharset
);
2516 CHECK_VECTOR (charset_info
);
2518 return Faref (char_table
,
2519 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2522 else if (VECTORP (range
))
2524 if (XVECTOR (range
)->size
== 1)
2525 return Faref (char_table
,
2526 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2529 int size
= XVECTOR (range
)->size
;
2530 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2531 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2532 size
<= 1 ? Qnil
: val
[1],
2533 size
<= 2 ? Qnil
: val
[2]);
2534 return Faref (char_table
, ch
);
2538 error ("Invalid RANGE argument to `char-table-range'");
2542 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2544 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2545 RANGE should be t (for all characters), nil (for the default value),
2546 a character set, a vector which identifies a character set, a row of a
2547 character set, or a character code. Return VALUE. */)
2548 (char_table
, range
, value
)
2549 Lisp_Object char_table
, range
, value
;
2553 CHECK_CHAR_TABLE (char_table
);
2556 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2557 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2558 else if (EQ (range
, Qnil
))
2559 XCHAR_TABLE (char_table
)->defalt
= value
;
2560 else if (SYMBOLP (range
))
2562 Lisp_Object charset_info
;
2565 charset_info
= Fget (range
, Qcharset
);
2566 if (! VECTORP (charset_info
)
2567 || ! NATNUMP (AREF (charset_info
, 0))
2568 || (charset_id
= XINT (AREF (charset_info
, 0)),
2569 ! CHARSET_DEFINED_P (charset_id
)))
2570 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2572 if (charset_id
== CHARSET_ASCII
)
2573 for (i
= 0; i
< 128; i
++)
2574 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2575 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2576 for (i
= 128; i
< 160; i
++)
2577 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2578 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2579 for (i
= 160; i
< 256; i
++)
2580 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2582 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2584 else if (INTEGERP (range
))
2585 Faset (char_table
, range
, value
);
2586 else if (VECTORP (range
))
2588 if (XVECTOR (range
)->size
== 1)
2589 return Faset (char_table
,
2590 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2594 int size
= XVECTOR (range
)->size
;
2595 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2596 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2597 size
<= 1 ? Qnil
: val
[1],
2598 size
<= 2 ? Qnil
: val
[2]);
2599 return Faset (char_table
, ch
, value
);
2603 error ("Invalid RANGE argument to `set-char-table-range'");
2608 DEFUN ("set-char-table-default", Fset_char_table_default
,
2609 Sset_char_table_default
, 3, 3, 0,
2610 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2611 The generic character specifies the group of characters.
2612 See also the documentation of `make-char'. */)
2613 (char_table
, ch
, value
)
2614 Lisp_Object char_table
, ch
, value
;
2616 int c
, charset
, code1
, code2
;
2619 CHECK_CHAR_TABLE (char_table
);
2623 SPLIT_CHAR (c
, charset
, code1
, code2
);
2625 /* Since we may want to set the default value for a character set
2626 not yet defined, we check only if the character set is in the
2627 valid range or not, instead of it is already defined or not. */
2628 if (! CHARSET_VALID_P (charset
))
2629 invalid_character (c
);
2631 if (charset
== CHARSET_ASCII
)
2632 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2634 /* Even if C is not a generic char, we had better behave as if a
2635 generic char is specified. */
2636 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2638 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2641 if (SUB_CHAR_TABLE_P (temp
))
2642 XCHAR_TABLE (temp
)->defalt
= value
;
2644 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2647 if (SUB_CHAR_TABLE_P (temp
))
2650 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2651 = make_sub_char_table (temp
));
2652 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2653 if (SUB_CHAR_TABLE_P (temp
))
2654 XCHAR_TABLE (temp
)->defalt
= value
;
2656 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2660 /* Look up the element in TABLE at index CH,
2661 and return it as an integer.
2662 If the element is nil, return CH itself.
2663 (Actually we do that for any non-integer.) */
2666 char_table_translate (table
, ch
)
2671 value
= Faref (table
, make_number (ch
));
2672 if (! INTEGERP (value
))
2674 return XINT (value
);
2678 optimize_sub_char_table (table
, chars
)
2686 from
= 33, to
= 127;
2688 from
= 32, to
= 128;
2690 if (!SUB_CHAR_TABLE_P (*table
))
2692 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2693 for (; from
< to
; from
++)
2694 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2699 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2700 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2708 CHECK_CHAR_TABLE (table
);
2710 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2712 elt
= XCHAR_TABLE (table
)->contents
[i
];
2713 if (!SUB_CHAR_TABLE_P (elt
))
2715 dim
= CHARSET_DIMENSION (i
- 128);
2717 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2718 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2719 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2725 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2726 character or group of characters that share a value.
2727 DEPTH is the current depth in the originally specified
2728 chartable, and INDICES contains the vector indices
2729 for the levels our callers have descended.
2731 ARG is passed to C_FUNCTION when that is called. */
2734 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2735 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2736 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2740 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2742 GCPRO4 (arg
, table
, subtable
, function
);
2746 /* At first, handle ASCII and 8-bit European characters. */
2747 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2749 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2751 elt
= XCHAR_TABLE (subtable
)->defalt
;
2753 elt
= Faref (subtable
, make_number (i
));
2755 (*c_function
) (arg
, make_number (i
), elt
);
2757 call2 (function
, make_number (i
), elt
);
2759 #if 0 /* If the char table has entries for higher characters,
2760 we should report them. */
2761 if (NILP (current_buffer
->enable_multibyte_characters
))
2767 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2771 int charset
= XFASTINT (indices
[0]) - 128;
2774 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2775 if (CHARSET_CHARS (charset
) == 94)
2784 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2785 XSETFASTINT (indices
[depth
], i
);
2786 charset
= XFASTINT (indices
[0]) - 128;
2788 && (!CHARSET_DEFINED_P (charset
)
2789 || charset
== CHARSET_8_BIT_CONTROL
2790 || charset
== CHARSET_8_BIT_GRAPHIC
))
2793 if (SUB_CHAR_TABLE_P (elt
))
2796 error ("Too deep char table");
2797 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2803 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2804 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2805 c
= MAKE_CHAR (charset
, c1
, c2
);
2808 elt
= XCHAR_TABLE (subtable
)->defalt
;
2810 elt
= Faref (table
, make_number (c
));
2813 (*c_function
) (arg
, make_number (c
), elt
);
2815 call2 (function
, make_number (c
), elt
);
2821 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2823 void_call2 (a
, b
, c
)
2824 Lisp_Object a
, b
, c
;
2829 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2831 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2832 FUNCTION is called with two arguments--a key and a value.
2833 The key is always a possible IDX argument to `aref'. */)
2834 (function
, char_table
)
2835 Lisp_Object function
, char_table
;
2837 /* The depth of char table is at most 3. */
2838 Lisp_Object indices
[3];
2840 CHECK_CHAR_TABLE (char_table
);
2842 /* When Lisp_Object is represented as a union, `call2' cannot directly
2843 be passed to map_char_table because it returns a Lisp_Object rather
2844 than returning nothing.
2845 Casting leads to crashes on some architectures. -stef */
2846 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2850 /* Return a value for character C in char-table TABLE. Store the
2851 actual index for that value in *IDX. Ignore the default value of
2855 char_table_ref_and_index (table
, c
, idx
)
2859 int charset
, c1
, c2
;
2862 if (SINGLE_BYTE_CHAR_P (c
))
2865 return XCHAR_TABLE (table
)->contents
[c
];
2867 SPLIT_CHAR (c
, charset
, c1
, c2
);
2868 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2869 *idx
= MAKE_CHAR (charset
, 0, 0);
2870 if (!SUB_CHAR_TABLE_P (elt
))
2872 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2873 return XCHAR_TABLE (elt
)->defalt
;
2874 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2875 *idx
= MAKE_CHAR (charset
, c1
, 0);
2876 if (!SUB_CHAR_TABLE_P (elt
))
2878 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2879 return XCHAR_TABLE (elt
)->defalt
;
2881 return XCHAR_TABLE (elt
)->contents
[c2
];
2891 Lisp_Object args
[2];
2894 return Fnconc (2, args
);
2896 return Fnconc (2, &s1
);
2897 #endif /* NO_ARG_ARRAY */
2900 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2901 doc
: /* Concatenate any number of lists by altering them.
2902 Only the last argument is not altered, and need not be a list.
2903 usage: (nconc &rest LISTS) */)
2908 register int argnum
;
2909 register Lisp_Object tail
, tem
, val
;
2913 for (argnum
= 0; argnum
< nargs
; argnum
++)
2916 if (NILP (tem
)) continue;
2921 if (argnum
+ 1 == nargs
) break;
2924 tem
= wrong_type_argument (Qlistp
, tem
);
2933 tem
= args
[argnum
+ 1];
2934 Fsetcdr (tail
, tem
);
2936 args
[argnum
+ 1] = tail
;
2942 /* This is the guts of all mapping functions.
2943 Apply FN to each element of SEQ, one by one,
2944 storing the results into elements of VALS, a C vector of Lisp_Objects.
2945 LENI is the length of VALS, which should also be the length of SEQ. */
2948 mapcar1 (leni
, vals
, fn
, seq
)
2951 Lisp_Object fn
, seq
;
2953 register Lisp_Object tail
;
2956 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2960 /* Don't let vals contain any garbage when GC happens. */
2961 for (i
= 0; i
< leni
; i
++)
2964 GCPRO3 (dummy
, fn
, seq
);
2966 gcpro1
.nvars
= leni
;
2970 /* We need not explicitly protect `tail' because it is used only on lists, and
2971 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2975 for (i
= 0; i
< leni
; i
++)
2977 dummy
= XVECTOR (seq
)->contents
[i
];
2978 dummy
= call1 (fn
, dummy
);
2983 else if (BOOL_VECTOR_P (seq
))
2985 for (i
= 0; i
< leni
; i
++)
2988 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2989 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
2994 dummy
= call1 (fn
, dummy
);
2999 else if (STRINGP (seq
))
3003 for (i
= 0, i_byte
= 0; i
< leni
;)
3008 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3009 XSETFASTINT (dummy
, c
);
3010 dummy
= call1 (fn
, dummy
);
3012 vals
[i_before
] = dummy
;
3015 else /* Must be a list, since Flength did not get an error */
3018 for (i
= 0; i
< leni
; i
++)
3020 dummy
= call1 (fn
, Fcar (tail
));
3030 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3031 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3032 In between each pair of results, stick in SEPARATOR. Thus, " " as
3033 SEPARATOR results in spaces between the values returned by FUNCTION.
3034 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3035 (function
, sequence
, separator
)
3036 Lisp_Object function
, sequence
, separator
;
3041 register Lisp_Object
*args
;
3043 struct gcpro gcpro1
;
3047 len
= Flength (sequence
);
3049 nargs
= leni
+ leni
- 1;
3050 if (nargs
< 0) return build_string ("");
3052 SAFE_ALLOCA_LISP (args
, nargs
);
3055 mapcar1 (leni
, args
, function
, sequence
);
3058 for (i
= leni
- 1; i
>= 0; i
--)
3059 args
[i
+ i
] = args
[i
];
3061 for (i
= 1; i
< nargs
; i
+= 2)
3062 args
[i
] = separator
;
3064 ret
= Fconcat (nargs
, args
);
3070 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3071 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3072 The result is a list just as long as SEQUENCE.
3073 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3074 (function
, sequence
)
3075 Lisp_Object function
, sequence
;
3077 register Lisp_Object len
;
3079 register Lisp_Object
*args
;
3083 len
= Flength (sequence
);
3084 leni
= XFASTINT (len
);
3086 SAFE_ALLOCA_LISP (args
, leni
);
3088 mapcar1 (leni
, args
, function
, sequence
);
3090 ret
= Flist (leni
, args
);
3096 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3097 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3098 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3099 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3100 (function
, sequence
)
3101 Lisp_Object function
, sequence
;
3105 leni
= XFASTINT (Flength (sequence
));
3106 mapcar1 (leni
, 0, function
, sequence
);
3111 /* Anything that calls this function must protect from GC! */
3113 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3114 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3115 Takes one argument, which is the string to display to ask the question.
3116 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3117 No confirmation of the answer is requested; a single character is enough.
3118 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3119 the bindings in `query-replace-map'; see the documentation of that variable
3120 for more information. In this case, the useful bindings are `act', `skip',
3121 `recenter', and `quit'.\)
3123 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3124 is nil and `use-dialog-box' is non-nil. */)
3128 register Lisp_Object obj
, key
, def
, map
;
3129 register int answer
;
3130 Lisp_Object xprompt
;
3131 Lisp_Object args
[2];
3132 struct gcpro gcpro1
, gcpro2
;
3133 int count
= SPECPDL_INDEX ();
3135 specbind (Qcursor_in_echo_area
, Qt
);
3137 map
= Fsymbol_value (intern ("query-replace-map"));
3139 CHECK_STRING (prompt
);
3141 GCPRO2 (prompt
, xprompt
);
3143 #ifdef HAVE_X_WINDOWS
3144 if (display_hourglass_p
)
3145 cancel_hourglass ();
3152 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3156 Lisp_Object pane
, menu
;
3157 redisplay_preserve_echo_area (3);
3158 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3159 Fcons (Fcons (build_string ("No"), Qnil
),
3161 menu
= Fcons (prompt
, pane
);
3162 obj
= Fx_popup_dialog (Qt
, menu
);
3163 answer
= !NILP (obj
);
3166 #endif /* HAVE_MENUS */
3167 cursor_in_echo_area
= 1;
3168 choose_minibuf_frame ();
3171 Lisp_Object pargs
[3];
3173 /* Colorize prompt according to `minibuffer-prompt' face. */
3174 pargs
[0] = build_string ("%s(y or n) ");
3175 pargs
[1] = intern ("face");
3176 pargs
[2] = intern ("minibuffer-prompt");
3177 args
[0] = Fpropertize (3, pargs
);
3182 if (minibuffer_auto_raise
)
3184 Lisp_Object mini_frame
;
3186 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3188 Fraise_frame (mini_frame
);
3191 obj
= read_filtered_event (1, 0, 0, 0);
3192 cursor_in_echo_area
= 0;
3193 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3196 key
= Fmake_vector (make_number (1), obj
);
3197 def
= Flookup_key (map
, key
, Qt
);
3199 if (EQ (def
, intern ("skip")))
3204 else if (EQ (def
, intern ("act")))
3209 else if (EQ (def
, intern ("recenter")))
3215 else if (EQ (def
, intern ("quit")))
3217 /* We want to exit this command for exit-prefix,
3218 and this is the only way to do it. */
3219 else if (EQ (def
, intern ("exit-prefix")))
3224 /* If we don't clear this, then the next call to read_char will
3225 return quit_char again, and we'll enter an infinite loop. */
3230 if (EQ (xprompt
, prompt
))
3232 args
[0] = build_string ("Please answer y or n. ");
3234 xprompt
= Fconcat (2, args
);
3239 if (! noninteractive
)
3241 cursor_in_echo_area
= -1;
3242 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3246 unbind_to (count
, Qnil
);
3247 return answer
? Qt
: Qnil
;
3250 /* This is how C code calls `yes-or-no-p' and allows the user
3253 Anything that calls this function must protect from GC! */
3256 do_yes_or_no_p (prompt
)
3259 return call1 (intern ("yes-or-no-p"), prompt
);
3262 /* Anything that calls this function must protect from GC! */
3264 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3265 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3266 Takes one argument, which is the string to display to ask the question.
3267 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3268 The user must confirm the answer with RET,
3269 and can edit it until it has been confirmed.
3271 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3272 is nil, and `use-dialog-box' is non-nil. */)
3276 register Lisp_Object ans
;
3277 Lisp_Object args
[2];
3278 struct gcpro gcpro1
;
3280 CHECK_STRING (prompt
);
3283 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3287 Lisp_Object pane
, menu
, obj
;
3288 redisplay_preserve_echo_area (4);
3289 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3290 Fcons (Fcons (build_string ("No"), Qnil
),
3293 menu
= Fcons (prompt
, pane
);
3294 obj
= Fx_popup_dialog (Qt
, menu
);
3298 #endif /* HAVE_MENUS */
3301 args
[1] = build_string ("(yes or no) ");
3302 prompt
= Fconcat (2, args
);
3308 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3309 Qyes_or_no_p_history
, Qnil
,
3311 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3316 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3324 message ("Please answer yes or no.");
3325 Fsleep_for (make_number (2), Qnil
);
3329 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3330 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3332 Each of the three load averages is multiplied by 100, then converted
3335 When USE-FLOATS is non-nil, floats will be used instead of integers.
3336 These floats are not multiplied by 100.
3338 If the 5-minute or 15-minute load averages are not available, return a
3339 shortened list, containing only those averages which are available.
3341 An error is thrown if the load average can't be obtained. In some
3342 cases making it work would require Emacs being installed setuid or
3343 setgid so that it can read kernel information, and that usually isn't
3346 Lisp_Object use_floats
;
3349 int loads
= getloadavg (load_ave
, 3);
3350 Lisp_Object ret
= Qnil
;
3353 error ("load-average not implemented for this operating system");
3357 Lisp_Object load
= (NILP (use_floats
) ?
3358 make_number ((int) (100.0 * load_ave
[loads
]))
3359 : make_float (load_ave
[loads
]));
3360 ret
= Fcons (load
, ret
);
3366 Lisp_Object Vfeatures
, Qsubfeatures
;
3367 extern Lisp_Object Vafter_load_alist
;
3369 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3370 doc
: /* Returns t if FEATURE is present in this Emacs.
3372 Use this to conditionalize execution of lisp code based on the
3373 presence or absence of emacs or environment extensions.
3374 Use `provide' to declare that a feature is available. This function
3375 looks at the value of the variable `features'. The optional argument
3376 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3377 (feature
, subfeature
)
3378 Lisp_Object feature
, subfeature
;
3380 register Lisp_Object tem
;
3381 CHECK_SYMBOL (feature
);
3382 tem
= Fmemq (feature
, Vfeatures
);
3383 if (!NILP (tem
) && !NILP (subfeature
))
3384 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3385 return (NILP (tem
)) ? Qnil
: Qt
;
3388 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3389 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3390 The optional argument SUBFEATURES should be a list of symbols listing
3391 particular subfeatures supported in this version of FEATURE. */)
3392 (feature
, subfeatures
)
3393 Lisp_Object feature
, subfeatures
;
3395 register Lisp_Object tem
;
3396 CHECK_SYMBOL (feature
);
3397 CHECK_LIST (subfeatures
);
3398 if (!NILP (Vautoload_queue
))
3399 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3400 tem
= Fmemq (feature
, Vfeatures
);
3402 Vfeatures
= Fcons (feature
, Vfeatures
);
3403 if (!NILP (subfeatures
))
3404 Fput (feature
, Qsubfeatures
, subfeatures
);
3405 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3407 /* Run any load-hooks for this file. */
3408 tem
= Fassq (feature
, Vafter_load_alist
);
3410 Fprogn (XCDR (tem
));
3415 /* `require' and its subroutines. */
3417 /* List of features currently being require'd, innermost first. */
3419 Lisp_Object require_nesting_list
;
3422 require_unwind (old_value
)
3423 Lisp_Object old_value
;
3425 return require_nesting_list
= old_value
;
3428 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3429 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3430 If FEATURE is not a member of the list `features', then the feature
3431 is not loaded; so load the file FILENAME.
3432 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3433 and `load' will try to load this name appended with the suffix `.elc' or
3434 `.el', in that order. The name without appended suffix will not be used.
3435 If the optional third argument NOERROR is non-nil,
3436 then return nil if the file is not found instead of signaling an error.
3437 Normally the return value is FEATURE.
3438 The normal messages at start and end of loading FILENAME are suppressed. */)
3439 (feature
, filename
, noerror
)
3440 Lisp_Object feature
, filename
, noerror
;
3442 register Lisp_Object tem
;
3443 struct gcpro gcpro1
, gcpro2
;
3445 CHECK_SYMBOL (feature
);
3447 /* Record the presence of `require' in this file
3448 even if the feature specified is already loaded.
3449 But not more than once in any file,
3450 and not when we aren't loading a file. */
3451 if (! NILP (Vloads_in_progress
))
3453 tem
= Fcons (Qrequire
, feature
);
3454 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3455 LOADHIST_ATTACH (tem
);
3457 tem
= Fmemq (feature
, Vfeatures
);
3461 int count
= SPECPDL_INDEX ();
3464 /* This is to make sure that loadup.el gives a clear picture
3465 of what files are preloaded and when. */
3466 if (! NILP (Vpurify_flag
))
3467 error ("(require %s) while preparing to dump",
3468 SDATA (SYMBOL_NAME (feature
)));
3470 /* A certain amount of recursive `require' is legitimate,
3471 but if we require the same feature recursively 3 times,
3473 tem
= require_nesting_list
;
3474 while (! NILP (tem
))
3476 if (! NILP (Fequal (feature
, XCAR (tem
))))
3481 error ("Recursive `require' for feature `%s'",
3482 SDATA (SYMBOL_NAME (feature
)));
3484 /* Update the list for any nested `require's that occur. */
3485 record_unwind_protect (require_unwind
, require_nesting_list
);
3486 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3488 /* Value saved here is to be restored into Vautoload_queue */
3489 record_unwind_protect (un_autoload
, Vautoload_queue
);
3490 Vautoload_queue
= Qt
;
3492 /* Load the file. */
3493 GCPRO2 (feature
, filename
);
3494 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3495 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3498 /* If load failed entirely, return nil. */
3500 return unbind_to (count
, Qnil
);
3502 tem
= Fmemq (feature
, Vfeatures
);
3504 error ("Required feature `%s' was not provided",
3505 SDATA (SYMBOL_NAME (feature
)));
3507 /* Once loading finishes, don't undo it. */
3508 Vautoload_queue
= Qt
;
3509 feature
= unbind_to (count
, feature
);
3515 /* Primitives for work of the "widget" library.
3516 In an ideal world, this section would not have been necessary.
3517 However, lisp function calls being as slow as they are, it turns
3518 out that some functions in the widget library (wid-edit.el) are the
3519 bottleneck of Widget operation. Here is their translation to C,
3520 for the sole reason of efficiency. */
3522 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3523 doc
: /* Return non-nil if PLIST has the property PROP.
3524 PLIST is a property list, which is a list of the form
3525 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3526 Unlike `plist-get', this allows you to distinguish between a missing
3527 property and a property with the value nil.
3528 The value is actually the tail of PLIST whose car is PROP. */)
3530 Lisp_Object plist
, prop
;
3532 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3535 plist
= XCDR (plist
);
3536 plist
= CDR (plist
);
3541 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3542 doc
: /* In WIDGET, set PROPERTY to VALUE.
3543 The value can later be retrieved with `widget-get'. */)
3544 (widget
, property
, value
)
3545 Lisp_Object widget
, property
, value
;
3547 CHECK_CONS (widget
);
3548 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3552 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3553 doc
: /* In WIDGET, get the value of PROPERTY.
3554 The value could either be specified when the widget was created, or
3555 later with `widget-put'. */)
3557 Lisp_Object widget
, property
;
3565 CHECK_CONS (widget
);
3566 tmp
= Fplist_member (XCDR (widget
), property
);
3572 tmp
= XCAR (widget
);
3575 widget
= Fget (tmp
, Qwidget_type
);
3579 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3580 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3581 ARGS are passed as extra arguments to the function.
3582 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3587 /* This function can GC. */
3588 Lisp_Object newargs
[3];
3589 struct gcpro gcpro1
, gcpro2
;
3592 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3593 newargs
[1] = args
[0];
3594 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3595 GCPRO2 (newargs
[0], newargs
[2]);
3596 result
= Fapply (3, newargs
);
3601 #ifdef HAVE_LANGINFO_CODESET
3602 #include <langinfo.h>
3605 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3606 doc
: /* Access locale data ITEM for the current C locale, if available.
3607 ITEM should be one of the following:
3609 `codeset', returning the character set as a string (locale item CODESET);
3611 `days', returning a 7-element vector of day names (locale items DAY_n);
3613 `months', returning a 12-element vector of month names (locale items MON_n);
3615 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3616 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3618 If the system can't provide such information through a call to
3619 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3621 See also Info node `(libc)Locales'.
3623 The data read from the system are decoded using `locale-coding-system'. */)
3628 #ifdef HAVE_LANGINFO_CODESET
3630 if (EQ (item
, Qcodeset
))
3632 str
= nl_langinfo (CODESET
);
3633 return build_string (str
);
3636 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3638 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3639 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3641 synchronize_system_time_locale ();
3642 for (i
= 0; i
< 7; i
++)
3644 str
= nl_langinfo (days
[i
]);
3645 val
= make_unibyte_string (str
, strlen (str
));
3646 /* Fixme: Is this coding system necessarily right, even if
3647 it is consistent with CODESET? If not, what to do? */
3648 Faset (v
, make_number (i
),
3649 code_convert_string_norecord (val
, Vlocale_coding_system
,
3656 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3658 struct Lisp_Vector
*p
= allocate_vector (12);
3659 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3660 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3662 synchronize_system_time_locale ();
3663 for (i
= 0; i
< 12; i
++)
3665 str
= nl_langinfo (months
[i
]);
3666 val
= make_unibyte_string (str
, strlen (str
));
3668 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3670 XSETVECTOR (val
, p
);
3674 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3675 but is in the locale files. This could be used by ps-print. */
3677 else if (EQ (item
, Qpaper
))
3679 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3680 make_number (nl_langinfo (PAPER_HEIGHT
)));
3682 #endif /* PAPER_WIDTH */
3683 #endif /* HAVE_LANGINFO_CODESET*/
3687 /* base64 encode/decode functions (RFC 2045).
3688 Based on code from GNU recode. */
3690 #define MIME_LINE_LENGTH 76
3692 #define IS_ASCII(Character) \
3694 #define IS_BASE64(Character) \
3695 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3696 #define IS_BASE64_IGNORABLE(Character) \
3697 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3698 || (Character) == '\f' || (Character) == '\r')
3700 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3701 character or return retval if there are no characters left to
3703 #define READ_QUADRUPLET_BYTE(retval) \
3708 if (nchars_return) \
3709 *nchars_return = nchars; \
3714 while (IS_BASE64_IGNORABLE (c))
3716 /* Table of characters coding the 64 values. */
3717 static char base64_value_to_char
[64] =
3719 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3720 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3721 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3722 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3723 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3724 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3725 '8', '9', '+', '/' /* 60-63 */
3728 /* Table of base64 values for first 128 characters. */
3729 static short base64_char_to_value
[128] =
3731 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3732 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3733 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3734 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3735 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3736 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3737 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3738 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3739 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3740 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3741 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3742 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3743 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3746 /* The following diagram shows the logical steps by which three octets
3747 get transformed into four base64 characters.
3749 .--------. .--------. .--------.
3750 |aaaaaabb| |bbbbcccc| |ccdddddd|
3751 `--------' `--------' `--------'
3753 .--------+--------+--------+--------.
3754 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3755 `--------+--------+--------+--------'
3757 .--------+--------+--------+--------.
3758 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3759 `--------+--------+--------+--------'
3761 The octets are divided into 6 bit chunks, which are then encoded into
3762 base64 characters. */
3765 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3766 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3768 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3770 doc
: /* Base64-encode the region between BEG and END.
3771 Return the length of the encoded text.
3772 Optional third argument NO-LINE-BREAK means do not break long lines
3773 into shorter lines. */)
3774 (beg
, end
, no_line_break
)
3775 Lisp_Object beg
, end
, no_line_break
;
3778 int allength
, length
;
3779 int ibeg
, iend
, encoded_length
;
3783 validate_region (&beg
, &end
);
3785 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3786 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3787 move_gap_both (XFASTINT (beg
), ibeg
);
3789 /* We need to allocate enough room for encoding the text.
3790 We need 33 1/3% more space, plus a newline every 76
3791 characters, and then we round up. */
3792 length
= iend
- ibeg
;
3793 allength
= length
+ length
/3 + 1;
3794 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3796 SAFE_ALLOCA (encoded
, char *, allength
);
3797 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3798 NILP (no_line_break
),
3799 !NILP (current_buffer
->enable_multibyte_characters
));
3800 if (encoded_length
> allength
)
3803 if (encoded_length
< 0)
3805 /* The encoding wasn't possible. */
3807 error ("Multibyte character in data for base64 encoding");
3810 /* Now we have encoded the region, so we insert the new contents
3811 and delete the old. (Insert first in order to preserve markers.) */
3812 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3813 insert (encoded
, encoded_length
);
3815 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3817 /* If point was outside of the region, restore it exactly; else just
3818 move to the beginning of the region. */
3819 if (old_pos
>= XFASTINT (end
))
3820 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3821 else if (old_pos
> XFASTINT (beg
))
3822 old_pos
= XFASTINT (beg
);
3825 /* We return the length of the encoded text. */
3826 return make_number (encoded_length
);
3829 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3831 doc
: /* Base64-encode STRING and return the result.
3832 Optional second argument NO-LINE-BREAK means do not break long lines
3833 into shorter lines. */)
3834 (string
, no_line_break
)
3835 Lisp_Object string
, no_line_break
;
3837 int allength
, length
, encoded_length
;
3839 Lisp_Object encoded_string
;
3842 CHECK_STRING (string
);
3844 /* We need to allocate enough room for encoding the text.
3845 We need 33 1/3% more space, plus a newline every 76
3846 characters, and then we round up. */
3847 length
= SBYTES (string
);
3848 allength
= length
+ length
/3 + 1;
3849 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3851 /* We need to allocate enough room for decoding the text. */
3852 SAFE_ALLOCA (encoded
, char *, allength
);
3854 encoded_length
= base64_encode_1 (SDATA (string
),
3855 encoded
, length
, NILP (no_line_break
),
3856 STRING_MULTIBYTE (string
));
3857 if (encoded_length
> allength
)
3860 if (encoded_length
< 0)
3862 /* The encoding wasn't possible. */
3864 error ("Multibyte character in data for base64 encoding");
3867 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3870 return encoded_string
;
3874 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3881 int counter
= 0, i
= 0;
3891 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3899 /* Wrap line every 76 characters. */
3903 if (counter
< MIME_LINE_LENGTH
/ 4)
3912 /* Process first byte of a triplet. */
3914 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3915 value
= (0x03 & c
) << 4;
3917 /* Process second byte of a triplet. */
3921 *e
++ = base64_value_to_char
[value
];
3929 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3937 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3938 value
= (0x0f & c
) << 2;
3940 /* Process third byte of a triplet. */
3944 *e
++ = base64_value_to_char
[value
];
3951 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3959 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3960 *e
++ = base64_value_to_char
[0x3f & c
];
3967 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3969 doc
: /* Base64-decode the region between BEG and END.
3970 Return the length of the decoded text.
3971 If the region can't be decoded, signal an error and don't modify the buffer. */)
3973 Lisp_Object beg
, end
;
3975 int ibeg
, iend
, length
, allength
;
3980 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3983 validate_region (&beg
, &end
);
3985 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3986 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3988 length
= iend
- ibeg
;
3990 /* We need to allocate enough room for decoding the text. If we are
3991 working on a multibyte buffer, each decoded code may occupy at
3993 allength
= multibyte
? length
* 2 : length
;
3994 SAFE_ALLOCA (decoded
, char *, allength
);
3996 move_gap_both (XFASTINT (beg
), ibeg
);
3997 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3998 multibyte
, &inserted_chars
);
3999 if (decoded_length
> allength
)
4002 if (decoded_length
< 0)
4004 /* The decoding wasn't possible. */
4006 error ("Invalid base64 data");
4009 /* Now we have decoded the region, so we insert the new contents
4010 and delete the old. (Insert first in order to preserve markers.) */
4011 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4012 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4015 /* Delete the original text. */
4016 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4017 iend
+ decoded_length
, 1);
4019 /* If point was outside of the region, restore it exactly; else just
4020 move to the beginning of the region. */
4021 if (old_pos
>= XFASTINT (end
))
4022 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4023 else if (old_pos
> XFASTINT (beg
))
4024 old_pos
= XFASTINT (beg
);
4025 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4027 return make_number (inserted_chars
);
4030 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4032 doc
: /* Base64-decode STRING and return the result. */)
4037 int length
, decoded_length
;
4038 Lisp_Object decoded_string
;
4041 CHECK_STRING (string
);
4043 length
= SBYTES (string
);
4044 /* We need to allocate enough room for decoding the text. */
4045 SAFE_ALLOCA (decoded
, char *, length
);
4047 /* The decoded result should be unibyte. */
4048 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4050 if (decoded_length
> length
)
4052 else if (decoded_length
>= 0)
4053 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4055 decoded_string
= Qnil
;
4058 if (!STRINGP (decoded_string
))
4059 error ("Invalid base64 data");
4061 return decoded_string
;
4064 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4065 MULTIBYTE is nonzero, the decoded result should be in multibyte
4066 form. If NCHARS_RETRUN is not NULL, store the number of produced
4067 characters in *NCHARS_RETURN. */
4070 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4080 unsigned long value
;
4085 /* Process first byte of a quadruplet. */
4087 READ_QUADRUPLET_BYTE (e
-to
);
4091 value
= base64_char_to_value
[c
] << 18;
4093 /* Process second byte of a quadruplet. */
4095 READ_QUADRUPLET_BYTE (-1);
4099 value
|= base64_char_to_value
[c
] << 12;
4101 c
= (unsigned char) (value
>> 16);
4103 e
+= CHAR_STRING (c
, e
);
4108 /* Process third byte of a quadruplet. */
4110 READ_QUADRUPLET_BYTE (-1);
4114 READ_QUADRUPLET_BYTE (-1);
4123 value
|= base64_char_to_value
[c
] << 6;
4125 c
= (unsigned char) (0xff & value
>> 8);
4127 e
+= CHAR_STRING (c
, e
);
4132 /* Process fourth byte of a quadruplet. */
4134 READ_QUADRUPLET_BYTE (-1);
4141 value
|= base64_char_to_value
[c
];
4143 c
= (unsigned char) (0xff & value
);
4145 e
+= CHAR_STRING (c
, e
);
4154 /***********************************************************************
4156 ***** Hash Tables *****
4158 ***********************************************************************/
4160 /* Implemented by gerd@gnu.org. This hash table implementation was
4161 inspired by CMUCL hash tables. */
4165 1. For small tables, association lists are probably faster than
4166 hash tables because they have lower overhead.
4168 For uses of hash tables where the O(1) behavior of table
4169 operations is not a requirement, it might therefore be a good idea
4170 not to hash. Instead, we could just do a linear search in the
4171 key_and_value vector of the hash table. This could be done
4172 if a `:linear-search t' argument is given to make-hash-table. */
4175 /* The list of all weak hash tables. Don't staticpro this one. */
4177 Lisp_Object Vweak_hash_tables
;
4179 /* Various symbols. */
4181 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4182 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4183 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4185 /* Function prototypes. */
4187 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4188 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4189 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4190 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4191 Lisp_Object
, unsigned));
4192 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4193 Lisp_Object
, unsigned));
4194 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4195 unsigned, Lisp_Object
, unsigned));
4196 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4197 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4198 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4199 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4201 static unsigned sxhash_string
P_ ((unsigned char *, int));
4202 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4203 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4204 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4205 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4209 /***********************************************************************
4211 ***********************************************************************/
4213 /* If OBJ is a Lisp hash table, return a pointer to its struct
4214 Lisp_Hash_Table. Otherwise, signal an error. */
4216 static struct Lisp_Hash_Table
*
4217 check_hash_table (obj
)
4220 CHECK_HASH_TABLE (obj
);
4221 return XHASH_TABLE (obj
);
4225 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4229 next_almost_prime (n
)
4242 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4243 which USED[I] is non-zero. If found at index I in ARGS, set
4244 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4245 -1. This function is used to extract a keyword/argument pair from
4246 a DEFUN parameter list. */
4249 get_key_arg (key
, nargs
, args
, used
)
4257 for (i
= 0; i
< nargs
- 1; ++i
)
4258 if (!used
[i
] && EQ (args
[i
], key
))
4273 /* Return a Lisp vector which has the same contents as VEC but has
4274 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4275 vector that are not copied from VEC are set to INIT. */
4278 larger_vector (vec
, new_size
, init
)
4283 struct Lisp_Vector
*v
;
4286 xassert (VECTORP (vec
));
4287 old_size
= XVECTOR (vec
)->size
;
4288 xassert (new_size
>= old_size
);
4290 v
= allocate_vector (new_size
);
4291 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4292 old_size
* sizeof *v
->contents
);
4293 for (i
= old_size
; i
< new_size
; ++i
)
4294 v
->contents
[i
] = init
;
4295 XSETVECTOR (vec
, v
);
4300 /***********************************************************************
4302 ***********************************************************************/
4304 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4305 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4306 KEY2 are the same. */
4309 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4310 struct Lisp_Hash_Table
*h
;
4311 Lisp_Object key1
, key2
;
4312 unsigned hash1
, hash2
;
4314 return (FLOATP (key1
)
4316 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4320 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4321 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4322 KEY2 are the same. */
4325 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4326 struct Lisp_Hash_Table
*h
;
4327 Lisp_Object key1
, key2
;
4328 unsigned hash1
, hash2
;
4330 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4334 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4335 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4336 if KEY1 and KEY2 are the same. */
4339 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4340 struct Lisp_Hash_Table
*h
;
4341 Lisp_Object key1
, key2
;
4342 unsigned hash1
, hash2
;
4346 Lisp_Object args
[3];
4348 args
[0] = h
->user_cmp_function
;
4351 return !NILP (Ffuncall (3, args
));
4358 /* Value is a hash code for KEY for use in hash table H which uses
4359 `eq' to compare keys. The hash code returned is guaranteed to fit
4360 in a Lisp integer. */
4364 struct Lisp_Hash_Table
*h
;
4367 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4368 xassert ((hash
& ~INTMASK
) == 0);
4373 /* Value is a hash code for KEY for use in hash table H which uses
4374 `eql' to compare keys. The hash code returned is guaranteed to fit
4375 in a Lisp integer. */
4379 struct Lisp_Hash_Table
*h
;
4384 hash
= sxhash (key
, 0);
4386 hash
= XUINT (key
) ^ XGCTYPE (key
);
4387 xassert ((hash
& ~INTMASK
) == 0);
4392 /* Value is a hash code for KEY for use in hash table H which uses
4393 `equal' to compare keys. The hash code returned is guaranteed to fit
4394 in a Lisp integer. */
4397 hashfn_equal (h
, key
)
4398 struct Lisp_Hash_Table
*h
;
4401 unsigned hash
= sxhash (key
, 0);
4402 xassert ((hash
& ~INTMASK
) == 0);
4407 /* Value is a hash code for KEY for use in hash table H which uses as
4408 user-defined function to compare keys. The hash code returned is
4409 guaranteed to fit in a Lisp integer. */
4412 hashfn_user_defined (h
, key
)
4413 struct Lisp_Hash_Table
*h
;
4416 Lisp_Object args
[2], hash
;
4418 args
[0] = h
->user_hash_function
;
4420 hash
= Ffuncall (2, args
);
4421 if (!INTEGERP (hash
))
4423 list2 (build_string ("Invalid hash code returned from \
4424 user-supplied hash function"),
4426 return XUINT (hash
);
4430 /* Create and initialize a new hash table.
4432 TEST specifies the test the hash table will use to compare keys.
4433 It must be either one of the predefined tests `eq', `eql' or
4434 `equal' or a symbol denoting a user-defined test named TEST with
4435 test and hash functions USER_TEST and USER_HASH.
4437 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4439 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4440 new size when it becomes full is computed by adding REHASH_SIZE to
4441 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4442 table's new size is computed by multiplying its old size with
4445 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4446 be resized when the ratio of (number of entries in the table) /
4447 (table size) is >= REHASH_THRESHOLD.
4449 WEAK specifies the weakness of the table. If non-nil, it must be
4450 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4453 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4454 user_test
, user_hash
)
4455 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4456 Lisp_Object user_test
, user_hash
;
4458 struct Lisp_Hash_Table
*h
;
4460 int index_size
, i
, sz
;
4462 /* Preconditions. */
4463 xassert (SYMBOLP (test
));
4464 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4465 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4466 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4467 xassert (FLOATP (rehash_threshold
)
4468 && XFLOATINT (rehash_threshold
) > 0
4469 && XFLOATINT (rehash_threshold
) <= 1.0);
4471 if (XFASTINT (size
) == 0)
4472 size
= make_number (1);
4474 /* Allocate a table and initialize it. */
4475 h
= allocate_hash_table ();
4477 /* Initialize hash table slots. */
4478 sz
= XFASTINT (size
);
4481 if (EQ (test
, Qeql
))
4483 h
->cmpfn
= cmpfn_eql
;
4484 h
->hashfn
= hashfn_eql
;
4486 else if (EQ (test
, Qeq
))
4489 h
->hashfn
= hashfn_eq
;
4491 else if (EQ (test
, Qequal
))
4493 h
->cmpfn
= cmpfn_equal
;
4494 h
->hashfn
= hashfn_equal
;
4498 h
->user_cmp_function
= user_test
;
4499 h
->user_hash_function
= user_hash
;
4500 h
->cmpfn
= cmpfn_user_defined
;
4501 h
->hashfn
= hashfn_user_defined
;
4505 h
->rehash_threshold
= rehash_threshold
;
4506 h
->rehash_size
= rehash_size
;
4507 h
->count
= make_number (0);
4508 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4509 h
->hash
= Fmake_vector (size
, Qnil
);
4510 h
->next
= Fmake_vector (size
, Qnil
);
4511 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4512 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4513 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4515 /* Set up the free list. */
4516 for (i
= 0; i
< sz
- 1; ++i
)
4517 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4518 h
->next_free
= make_number (0);
4520 XSET_HASH_TABLE (table
, h
);
4521 xassert (HASH_TABLE_P (table
));
4522 xassert (XHASH_TABLE (table
) == h
);
4524 /* Maybe add this hash table to the list of all weak hash tables. */
4526 h
->next_weak
= Qnil
;
4529 h
->next_weak
= Vweak_hash_tables
;
4530 Vweak_hash_tables
= table
;
4537 /* Return a copy of hash table H1. Keys and values are not copied,
4538 only the table itself is. */
4541 copy_hash_table (h1
)
4542 struct Lisp_Hash_Table
*h1
;
4545 struct Lisp_Hash_Table
*h2
;
4546 struct Lisp_Vector
*next
;
4548 h2
= allocate_hash_table ();
4549 next
= h2
->vec_next
;
4550 bcopy (h1
, h2
, sizeof *h2
);
4551 h2
->vec_next
= next
;
4552 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4553 h2
->hash
= Fcopy_sequence (h1
->hash
);
4554 h2
->next
= Fcopy_sequence (h1
->next
);
4555 h2
->index
= Fcopy_sequence (h1
->index
);
4556 XSET_HASH_TABLE (table
, h2
);
4558 /* Maybe add this hash table to the list of all weak hash tables. */
4559 if (!NILP (h2
->weak
))
4561 h2
->next_weak
= Vweak_hash_tables
;
4562 Vweak_hash_tables
= table
;
4569 /* Resize hash table H if it's too full. If H cannot be resized
4570 because it's already too large, throw an error. */
4573 maybe_resize_hash_table (h
)
4574 struct Lisp_Hash_Table
*h
;
4576 if (NILP (h
->next_free
))
4578 int old_size
= HASH_TABLE_SIZE (h
);
4579 int i
, new_size
, index_size
;
4581 if (INTEGERP (h
->rehash_size
))
4582 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4584 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4585 new_size
= max (old_size
+ 1, new_size
);
4586 index_size
= next_almost_prime ((int)
4588 / XFLOATINT (h
->rehash_threshold
)));
4589 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4590 error ("Hash table too large to resize");
4592 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4593 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4594 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4595 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4597 /* Update the free list. Do it so that new entries are added at
4598 the end of the free list. This makes some operations like
4600 for (i
= old_size
; i
< new_size
- 1; ++i
)
4601 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4603 if (!NILP (h
->next_free
))
4605 Lisp_Object last
, next
;
4607 last
= h
->next_free
;
4608 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4612 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4615 XSETFASTINT (h
->next_free
, old_size
);
4618 for (i
= 0; i
< old_size
; ++i
)
4619 if (!NILP (HASH_HASH (h
, i
)))
4621 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4622 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4623 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4624 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4630 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4631 the hash code of KEY. Value is the index of the entry in H
4632 matching KEY, or -1 if not found. */
4635 hash_lookup (h
, key
, hash
)
4636 struct Lisp_Hash_Table
*h
;
4641 int start_of_bucket
;
4644 hash_code
= h
->hashfn (h
, key
);
4648 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4649 idx
= HASH_INDEX (h
, start_of_bucket
);
4651 /* We need not gcpro idx since it's either an integer or nil. */
4654 int i
= XFASTINT (idx
);
4655 if (EQ (key
, HASH_KEY (h
, i
))
4657 && h
->cmpfn (h
, key
, hash_code
,
4658 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4660 idx
= HASH_NEXT (h
, i
);
4663 return NILP (idx
) ? -1 : XFASTINT (idx
);
4667 /* Put an entry into hash table H that associates KEY with VALUE.
4668 HASH is a previously computed hash code of KEY.
4669 Value is the index of the entry in H matching KEY. */
4672 hash_put (h
, key
, value
, hash
)
4673 struct Lisp_Hash_Table
*h
;
4674 Lisp_Object key
, value
;
4677 int start_of_bucket
, i
;
4679 xassert ((hash
& ~INTMASK
) == 0);
4681 /* Increment count after resizing because resizing may fail. */
4682 maybe_resize_hash_table (h
);
4683 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4685 /* Store key/value in the key_and_value vector. */
4686 i
= XFASTINT (h
->next_free
);
4687 h
->next_free
= HASH_NEXT (h
, i
);
4688 HASH_KEY (h
, i
) = key
;
4689 HASH_VALUE (h
, i
) = value
;
4691 /* Remember its hash code. */
4692 HASH_HASH (h
, i
) = make_number (hash
);
4694 /* Add new entry to its collision chain. */
4695 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4696 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4697 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4702 /* Remove the entry matching KEY from hash table H, if there is one. */
4705 hash_remove (h
, key
)
4706 struct Lisp_Hash_Table
*h
;
4710 int start_of_bucket
;
4711 Lisp_Object idx
, prev
;
4713 hash_code
= h
->hashfn (h
, key
);
4714 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4715 idx
= HASH_INDEX (h
, start_of_bucket
);
4718 /* We need not gcpro idx, prev since they're either integers or nil. */
4721 int i
= XFASTINT (idx
);
4723 if (EQ (key
, HASH_KEY (h
, i
))
4725 && h
->cmpfn (h
, key
, hash_code
,
4726 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4728 /* Take entry out of collision chain. */
4730 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4732 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4734 /* Clear slots in key_and_value and add the slots to
4736 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4737 HASH_NEXT (h
, i
) = h
->next_free
;
4738 h
->next_free
= make_number (i
);
4739 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4740 xassert (XINT (h
->count
) >= 0);
4746 idx
= HASH_NEXT (h
, i
);
4752 /* Clear hash table H. */
4756 struct Lisp_Hash_Table
*h
;
4758 if (XFASTINT (h
->count
) > 0)
4760 int i
, size
= HASH_TABLE_SIZE (h
);
4762 for (i
= 0; i
< size
; ++i
)
4764 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4765 HASH_KEY (h
, i
) = Qnil
;
4766 HASH_VALUE (h
, i
) = Qnil
;
4767 HASH_HASH (h
, i
) = Qnil
;
4770 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4771 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4773 h
->next_free
= make_number (0);
4774 h
->count
= make_number (0);
4780 /************************************************************************
4782 ************************************************************************/
4784 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4785 entries from the table that don't survive the current GC.
4786 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4787 non-zero if anything was marked. */
4790 sweep_weak_table (h
, remove_entries_p
)
4791 struct Lisp_Hash_Table
*h
;
4792 int remove_entries_p
;
4794 int bucket
, n
, marked
;
4796 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4799 for (bucket
= 0; bucket
< n
; ++bucket
)
4801 Lisp_Object idx
, next
, prev
;
4803 /* Follow collision chain, removing entries that
4804 don't survive this garbage collection. */
4806 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4808 int i
= XFASTINT (idx
);
4809 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4810 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4813 if (EQ (h
->weak
, Qkey
))
4814 remove_p
= !key_known_to_survive_p
;
4815 else if (EQ (h
->weak
, Qvalue
))
4816 remove_p
= !value_known_to_survive_p
;
4817 else if (EQ (h
->weak
, Qkey_or_value
))
4818 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4819 else if (EQ (h
->weak
, Qkey_and_value
))
4820 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4824 next
= HASH_NEXT (h
, i
);
4826 if (remove_entries_p
)
4830 /* Take out of collision chain. */
4832 HASH_INDEX (h
, bucket
) = next
;
4834 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4836 /* Add to free list. */
4837 HASH_NEXT (h
, i
) = h
->next_free
;
4840 /* Clear key, value, and hash. */
4841 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4842 HASH_HASH (h
, i
) = Qnil
;
4844 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4855 /* Make sure key and value survive. */
4856 if (!key_known_to_survive_p
)
4858 mark_object (HASH_KEY (h
, i
));
4862 if (!value_known_to_survive_p
)
4864 mark_object (HASH_VALUE (h
, i
));
4875 /* Remove elements from weak hash tables that don't survive the
4876 current garbage collection. Remove weak tables that don't survive
4877 from Vweak_hash_tables. Called from gc_sweep. */
4880 sweep_weak_hash_tables ()
4882 Lisp_Object table
, used
, next
;
4883 struct Lisp_Hash_Table
*h
;
4886 /* Mark all keys and values that are in use. Keep on marking until
4887 there is no more change. This is necessary for cases like
4888 value-weak table A containing an entry X -> Y, where Y is used in a
4889 key-weak table B, Z -> Y. If B comes after A in the list of weak
4890 tables, X -> Y might be removed from A, although when looking at B
4891 one finds that it shouldn't. */
4895 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4897 h
= XHASH_TABLE (table
);
4898 if (h
->size
& ARRAY_MARK_FLAG
)
4899 marked
|= sweep_weak_table (h
, 0);
4904 /* Remove tables and entries that aren't used. */
4905 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4907 h
= XHASH_TABLE (table
);
4908 next
= h
->next_weak
;
4910 if (h
->size
& ARRAY_MARK_FLAG
)
4912 /* TABLE is marked as used. Sweep its contents. */
4913 if (XFASTINT (h
->count
) > 0)
4914 sweep_weak_table (h
, 1);
4916 /* Add table to the list of used weak hash tables. */
4917 h
->next_weak
= used
;
4922 Vweak_hash_tables
= used
;
4927 /***********************************************************************
4928 Hash Code Computation
4929 ***********************************************************************/
4931 /* Maximum depth up to which to dive into Lisp structures. */
4933 #define SXHASH_MAX_DEPTH 3
4935 /* Maximum length up to which to take list and vector elements into
4938 #define SXHASH_MAX_LEN 7
4940 /* Combine two integers X and Y for hashing. */
4942 #define SXHASH_COMBINE(X, Y) \
4943 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4947 /* Return a hash for string PTR which has length LEN. The hash
4948 code returned is guaranteed to fit in a Lisp integer. */
4951 sxhash_string (ptr
, len
)
4955 unsigned char *p
= ptr
;
4956 unsigned char *end
= p
+ len
;
4965 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4968 return hash
& INTMASK
;
4972 /* Return a hash for list LIST. DEPTH is the current depth in the
4973 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4976 sxhash_list (list
, depth
)
4983 if (depth
< SXHASH_MAX_DEPTH
)
4985 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4986 list
= XCDR (list
), ++i
)
4988 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4989 hash
= SXHASH_COMBINE (hash
, hash2
);
4996 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4997 the Lisp structure. */
5000 sxhash_vector (vec
, depth
)
5004 unsigned hash
= XVECTOR (vec
)->size
;
5007 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5008 for (i
= 0; i
< n
; ++i
)
5010 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5011 hash
= SXHASH_COMBINE (hash
, hash2
);
5018 /* Return a hash for bool-vector VECTOR. */
5021 sxhash_bool_vector (vec
)
5024 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5027 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5028 for (i
= 0; i
< n
; ++i
)
5029 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5035 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5036 structure. Value is an unsigned integer clipped to INTMASK. */
5045 if (depth
> SXHASH_MAX_DEPTH
)
5048 switch (XTYPE (obj
))
5059 obj
= SYMBOL_NAME (obj
);
5063 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5066 /* This can be everything from a vector to an overlay. */
5067 case Lisp_Vectorlike
:
5069 /* According to the CL HyperSpec, two arrays are equal only if
5070 they are `eq', except for strings and bit-vectors. In
5071 Emacs, this works differently. We have to compare element
5073 hash
= sxhash_vector (obj
, depth
);
5074 else if (BOOL_VECTOR_P (obj
))
5075 hash
= sxhash_bool_vector (obj
);
5077 /* Others are `equal' if they are `eq', so let's take their
5083 hash
= sxhash_list (obj
, depth
);
5088 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5089 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5090 for (hash
= 0; p
< e
; ++p
)
5091 hash
= SXHASH_COMBINE (hash
, *p
);
5099 return hash
& INTMASK
;
5104 /***********************************************************************
5106 ***********************************************************************/
5109 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5110 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5114 unsigned hash
= sxhash (obj
, 0);;
5115 return make_number (hash
);
5119 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5120 doc
: /* Create and return a new hash table.
5122 Arguments are specified as keyword/argument pairs. The following
5123 arguments are defined:
5125 :test TEST -- TEST must be a symbol that specifies how to compare
5126 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5127 `equal'. User-supplied test and hash functions can be specified via
5128 `define-hash-table-test'.
5130 :size SIZE -- A hint as to how many elements will be put in the table.
5133 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5134 fills up. If REHASH-SIZE is an integer, add that many space. If it
5135 is a float, it must be > 1.0, and the new size is computed by
5136 multiplying the old size with that factor. Default is 1.5.
5138 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5139 Resize the hash table when ratio of the number of entries in the
5140 table. Default is 0.8.
5142 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5143 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5144 returned is a weak table. Key/value pairs are removed from a weak
5145 hash table when there are no non-weak references pointing to their
5146 key, value, one of key or value, or both key and value, depending on
5147 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5150 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5155 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5156 Lisp_Object user_test
, user_hash
;
5160 /* The vector `used' is used to keep track of arguments that
5161 have been consumed. */
5162 used
= (char *) alloca (nargs
* sizeof *used
);
5163 bzero (used
, nargs
* sizeof *used
);
5165 /* See if there's a `:test TEST' among the arguments. */
5166 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5167 test
= i
< 0 ? Qeql
: args
[i
];
5168 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5170 /* See if it is a user-defined test. */
5173 prop
= Fget (test
, Qhash_table_test
);
5174 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5175 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5177 user_test
= XCAR (prop
);
5178 user_hash
= XCAR (XCDR (prop
));
5181 user_test
= user_hash
= Qnil
;
5183 /* See if there's a `:size SIZE' argument. */
5184 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5185 size
= i
< 0 ? Qnil
: args
[i
];
5187 size
= make_number (DEFAULT_HASH_SIZE
);
5188 else if (!INTEGERP (size
) || XINT (size
) < 0)
5190 list2 (build_string ("Invalid hash table size"),
5193 /* Look for `:rehash-size SIZE'. */
5194 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5195 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5196 if (!NUMBERP (rehash_size
)
5197 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5198 || XFLOATINT (rehash_size
) <= 1.0)
5200 list2 (build_string ("Invalid hash table rehash size"),
5203 /* Look for `:rehash-threshold THRESHOLD'. */
5204 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5205 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5206 if (!FLOATP (rehash_threshold
)
5207 || XFLOATINT (rehash_threshold
) <= 0.0
5208 || XFLOATINT (rehash_threshold
) > 1.0)
5210 list2 (build_string ("Invalid hash table rehash threshold"),
5213 /* Look for `:weakness WEAK'. */
5214 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5215 weak
= i
< 0 ? Qnil
: args
[i
];
5217 weak
= Qkey_and_value
;
5220 && !EQ (weak
, Qvalue
)
5221 && !EQ (weak
, Qkey_or_value
)
5222 && !EQ (weak
, Qkey_and_value
))
5223 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5226 /* Now, all args should have been used up, or there's a problem. */
5227 for (i
= 0; i
< nargs
; ++i
)
5230 list2 (build_string ("Invalid argument list"), args
[i
]));
5232 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5233 user_test
, user_hash
);
5237 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5238 doc
: /* Return a copy of hash table TABLE. */)
5242 return copy_hash_table (check_hash_table (table
));
5246 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5247 doc
: /* Return the number of elements in TABLE. */)
5251 return check_hash_table (table
)->count
;
5255 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5256 Shash_table_rehash_size
, 1, 1, 0,
5257 doc
: /* Return the current rehash size of TABLE. */)
5261 return check_hash_table (table
)->rehash_size
;
5265 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5266 Shash_table_rehash_threshold
, 1, 1, 0,
5267 doc
: /* Return the current rehash threshold of TABLE. */)
5271 return check_hash_table (table
)->rehash_threshold
;
5275 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5276 doc
: /* Return the size of TABLE.
5277 The size can be used as an argument to `make-hash-table' to create
5278 a hash table than can hold as many elements of TABLE holds
5279 without need for resizing. */)
5283 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5284 return make_number (HASH_TABLE_SIZE (h
));
5288 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5289 doc
: /* Return the test TABLE uses. */)
5293 return check_hash_table (table
)->test
;
5297 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5299 doc
: /* Return the weakness of TABLE. */)
5303 return check_hash_table (table
)->weak
;
5307 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5308 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5312 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5316 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5317 doc
: /* Clear hash table TABLE. */)
5321 hash_clear (check_hash_table (table
));
5326 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5327 doc
: /* Look up KEY in TABLE and return its associated value.
5328 If KEY is not found, return DFLT which defaults to nil. */)
5330 Lisp_Object key
, table
, dflt
;
5332 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5333 int i
= hash_lookup (h
, key
, NULL
);
5334 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5338 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5339 doc
: /* Associate KEY with VALUE in hash table TABLE.
5340 If KEY is already present in table, replace its current value with
5343 Lisp_Object key
, value
, table
;
5345 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5349 i
= hash_lookup (h
, key
, &hash
);
5351 HASH_VALUE (h
, i
) = value
;
5353 hash_put (h
, key
, value
, hash
);
5359 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5360 doc
: /* Remove KEY from TABLE. */)
5362 Lisp_Object key
, table
;
5364 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5365 hash_remove (h
, key
);
5370 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5371 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5372 FUNCTION is called with 2 arguments KEY and VALUE. */)
5374 Lisp_Object function
, table
;
5376 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5377 Lisp_Object args
[3];
5380 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5381 if (!NILP (HASH_HASH (h
, i
)))
5384 args
[1] = HASH_KEY (h
, i
);
5385 args
[2] = HASH_VALUE (h
, i
);
5393 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5394 Sdefine_hash_table_test
, 3, 3, 0,
5395 doc
: /* Define a new hash table test with name NAME, a symbol.
5397 In hash tables created with NAME specified as test, use TEST to
5398 compare keys, and HASH for computing hash codes of keys.
5400 TEST must be a function taking two arguments and returning non-nil if
5401 both arguments are the same. HASH must be a function taking one
5402 argument and return an integer that is the hash code of the argument.
5403 Hash code computation should use the whole value range of integers,
5404 including negative integers. */)
5406 Lisp_Object name
, test
, hash
;
5408 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5413 /************************************************************************
5415 ************************************************************************/
5420 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5421 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5423 A message digest is a cryptographic checksum of a document, and the
5424 algorithm to calculate it is defined in RFC 1321.
5426 The two optional arguments START and END are character positions
5427 specifying for which part of OBJECT the message digest should be
5428 computed. If nil or omitted, the digest is computed for the whole
5431 The MD5 message digest is computed from the result of encoding the
5432 text in a coding system, not directly from the internal Emacs form of
5433 the text. The optional fourth argument CODING-SYSTEM specifies which
5434 coding system to encode the text with. It should be the same coding
5435 system that you used or will use when actually writing the text into a
5438 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5439 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5440 system would be chosen by default for writing this text into a file.
5442 If OBJECT is a string, the most preferred coding system (see the
5443 command `prefer-coding-system') is used.
5445 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5446 guesswork fails. Normally, an error is signaled in such case. */)
5447 (object
, start
, end
, coding_system
, noerror
)
5448 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5450 unsigned char digest
[16];
5451 unsigned char value
[33];
5455 int start_char
= 0, end_char
= 0;
5456 int start_byte
= 0, end_byte
= 0;
5458 register struct buffer
*bp
;
5461 if (STRINGP (object
))
5463 if (NILP (coding_system
))
5465 /* Decide the coding-system to encode the data with. */
5467 if (STRING_MULTIBYTE (object
))
5468 /* use default, we can't guess correct value */
5469 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5471 coding_system
= Qraw_text
;
5474 if (NILP (Fcoding_system_p (coding_system
)))
5476 /* Invalid coding system. */
5478 if (!NILP (noerror
))
5479 coding_system
= Qraw_text
;
5482 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5485 if (STRING_MULTIBYTE (object
))
5486 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5488 size
= SCHARS (object
);
5489 size_byte
= SBYTES (object
);
5493 CHECK_NUMBER (start
);
5495 start_char
= XINT (start
);
5500 start_byte
= string_char_to_byte (object
, start_char
);
5506 end_byte
= size_byte
;
5512 end_char
= XINT (end
);
5517 end_byte
= string_char_to_byte (object
, end_char
);
5520 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5521 args_out_of_range_3 (object
, make_number (start_char
),
5522 make_number (end_char
));
5526 struct buffer
*prev
= current_buffer
;
5528 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5530 CHECK_BUFFER (object
);
5532 bp
= XBUFFER (object
);
5533 if (bp
!= current_buffer
)
5534 set_buffer_internal (bp
);
5540 CHECK_NUMBER_COERCE_MARKER (start
);
5548 CHECK_NUMBER_COERCE_MARKER (end
);
5553 temp
= b
, b
= e
, e
= temp
;
5555 if (!(BEGV
<= b
&& e
<= ZV
))
5556 args_out_of_range (start
, end
);
5558 if (NILP (coding_system
))
5560 /* Decide the coding-system to encode the data with.
5561 See fileio.c:Fwrite-region */
5563 if (!NILP (Vcoding_system_for_write
))
5564 coding_system
= Vcoding_system_for_write
;
5567 int force_raw_text
= 0;
5569 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5570 if (NILP (coding_system
)
5571 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5573 coding_system
= Qnil
;
5574 if (NILP (current_buffer
->enable_multibyte_characters
))
5578 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5580 /* Check file-coding-system-alist. */
5581 Lisp_Object args
[4], val
;
5583 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5584 args
[3] = Fbuffer_file_name(object
);
5585 val
= Ffind_operation_coding_system (4, args
);
5586 if (CONSP (val
) && !NILP (XCDR (val
)))
5587 coding_system
= XCDR (val
);
5590 if (NILP (coding_system
)
5591 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5593 /* If we still have not decided a coding system, use the
5594 default value of buffer-file-coding-system. */
5595 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5599 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5600 /* Confirm that VAL can surely encode the current region. */
5601 coding_system
= call4 (Vselect_safe_coding_system_function
,
5602 make_number (b
), make_number (e
),
5603 coding_system
, Qnil
);
5606 coding_system
= Qraw_text
;
5609 if (NILP (Fcoding_system_p (coding_system
)))
5611 /* Invalid coding system. */
5613 if (!NILP (noerror
))
5614 coding_system
= Qraw_text
;
5617 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5621 object
= make_buffer_string (b
, e
, 0);
5622 if (prev
!= current_buffer
)
5623 set_buffer_internal (prev
);
5624 /* Discard the unwind protect for recovering the current
5628 if (STRING_MULTIBYTE (object
))
5629 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5632 md5_buffer (SDATA (object
) + start_byte
,
5633 SBYTES (object
) - (size_byte
- end_byte
),
5636 for (i
= 0; i
< 16; i
++)
5637 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5640 return make_string (value
, 32);
5647 /* Hash table stuff. */
5648 Qhash_table_p
= intern ("hash-table-p");
5649 staticpro (&Qhash_table_p
);
5650 Qeq
= intern ("eq");
5652 Qeql
= intern ("eql");
5654 Qequal
= intern ("equal");
5655 staticpro (&Qequal
);
5656 QCtest
= intern (":test");
5657 staticpro (&QCtest
);
5658 QCsize
= intern (":size");
5659 staticpro (&QCsize
);
5660 QCrehash_size
= intern (":rehash-size");
5661 staticpro (&QCrehash_size
);
5662 QCrehash_threshold
= intern (":rehash-threshold");
5663 staticpro (&QCrehash_threshold
);
5664 QCweakness
= intern (":weakness");
5665 staticpro (&QCweakness
);
5666 Qkey
= intern ("key");
5668 Qvalue
= intern ("value");
5669 staticpro (&Qvalue
);
5670 Qhash_table_test
= intern ("hash-table-test");
5671 staticpro (&Qhash_table_test
);
5672 Qkey_or_value
= intern ("key-or-value");
5673 staticpro (&Qkey_or_value
);
5674 Qkey_and_value
= intern ("key-and-value");
5675 staticpro (&Qkey_and_value
);
5678 defsubr (&Smake_hash_table
);
5679 defsubr (&Scopy_hash_table
);
5680 defsubr (&Shash_table_count
);
5681 defsubr (&Shash_table_rehash_size
);
5682 defsubr (&Shash_table_rehash_threshold
);
5683 defsubr (&Shash_table_size
);
5684 defsubr (&Shash_table_test
);
5685 defsubr (&Shash_table_weakness
);
5686 defsubr (&Shash_table_p
);
5687 defsubr (&Sclrhash
);
5688 defsubr (&Sgethash
);
5689 defsubr (&Sputhash
);
5690 defsubr (&Sremhash
);
5691 defsubr (&Smaphash
);
5692 defsubr (&Sdefine_hash_table_test
);
5694 Qstring_lessp
= intern ("string-lessp");
5695 staticpro (&Qstring_lessp
);
5696 Qprovide
= intern ("provide");
5697 staticpro (&Qprovide
);
5698 Qrequire
= intern ("require");
5699 staticpro (&Qrequire
);
5700 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5701 staticpro (&Qyes_or_no_p_history
);
5702 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5703 staticpro (&Qcursor_in_echo_area
);
5704 Qwidget_type
= intern ("widget-type");
5705 staticpro (&Qwidget_type
);
5707 staticpro (&string_char_byte_cache_string
);
5708 string_char_byte_cache_string
= Qnil
;
5710 require_nesting_list
= Qnil
;
5711 staticpro (&require_nesting_list
);
5713 Fset (Qyes_or_no_p_history
, Qnil
);
5715 DEFVAR_LISP ("features", &Vfeatures
,
5716 doc
: /* A list of symbols which are the features of the executing emacs.
5717 Used by `featurep' and `require', and altered by `provide'. */);
5719 Qsubfeatures
= intern ("subfeatures");
5720 staticpro (&Qsubfeatures
);
5722 #ifdef HAVE_LANGINFO_CODESET
5723 Qcodeset
= intern ("codeset");
5724 staticpro (&Qcodeset
);
5725 Qdays
= intern ("days");
5727 Qmonths
= intern ("months");
5728 staticpro (&Qmonths
);
5729 Qpaper
= intern ("paper");
5730 staticpro (&Qpaper
);
5731 #endif /* HAVE_LANGINFO_CODESET */
5733 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5734 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5735 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5736 invoked by mouse clicks and mouse menu items. */);
5739 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5740 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5741 This applies to commands from menus and tool bar buttons. The value of
5742 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5743 used if both `use-dialog-box' and this variable are non-nil. */);
5744 use_file_dialog
= 1;
5746 defsubr (&Sidentity
);
5749 defsubr (&Ssafe_length
);
5750 defsubr (&Sstring_bytes
);
5751 defsubr (&Sstring_equal
);
5752 defsubr (&Scompare_strings
);
5753 defsubr (&Sstring_lessp
);
5756 defsubr (&Svconcat
);
5757 defsubr (&Scopy_sequence
);
5758 defsubr (&Sstring_make_multibyte
);
5759 defsubr (&Sstring_make_unibyte
);
5760 defsubr (&Sstring_as_multibyte
);
5761 defsubr (&Sstring_as_unibyte
);
5762 defsubr (&Sstring_to_multibyte
);
5763 defsubr (&Scopy_alist
);
5764 defsubr (&Ssubstring
);
5765 defsubr (&Ssubstring_no_properties
);
5777 defsubr (&Snreverse
);
5778 defsubr (&Sreverse
);
5780 defsubr (&Splist_get
);
5781 defsubr (&Ssafe_plist_get
);
5783 defsubr (&Splist_put
);
5785 defsubr (&Slax_plist_get
);
5786 defsubr (&Slax_plist_put
);
5789 defsubr (&Sequal_including_properties
);
5790 defsubr (&Sfillarray
);
5791 defsubr (&Sclear_string
);
5792 defsubr (&Schar_table_subtype
);
5793 defsubr (&Schar_table_parent
);
5794 defsubr (&Sset_char_table_parent
);
5795 defsubr (&Schar_table_extra_slot
);
5796 defsubr (&Sset_char_table_extra_slot
);
5797 defsubr (&Schar_table_range
);
5798 defsubr (&Sset_char_table_range
);
5799 defsubr (&Sset_char_table_default
);
5800 defsubr (&Soptimize_char_table
);
5801 defsubr (&Smap_char_table
);
5805 defsubr (&Smapconcat
);
5806 defsubr (&Sy_or_n_p
);
5807 defsubr (&Syes_or_no_p
);
5808 defsubr (&Sload_average
);
5809 defsubr (&Sfeaturep
);
5810 defsubr (&Srequire
);
5811 defsubr (&Sprovide
);
5812 defsubr (&Splist_member
);
5813 defsubr (&Swidget_put
);
5814 defsubr (&Swidget_get
);
5815 defsubr (&Swidget_apply
);
5816 defsubr (&Sbase64_encode_region
);
5817 defsubr (&Sbase64_decode_region
);
5818 defsubr (&Sbase64_encode_string
);
5819 defsubr (&Sbase64_decode_string
);
5821 defsubr (&Slocale_info
);
5828 Vweak_hash_tables
= Qnil
;
5831 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5832 (do not change this comment) */