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 X, 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
;
70 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
71 Lisp_Object Qyes_or_no_p_history
;
72 Lisp_Object Qcursor_in_echo_area
;
73 Lisp_Object Qwidget_type
;
74 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
76 extern Lisp_Object Qinput_method_function
;
78 static int internal_equal ();
80 extern long get_random ();
81 extern void seed_random ();
87 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
88 doc
: /* Return the argument unchanged. */)
95 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
96 doc
: /* Return a pseudo-random number.
97 All integers representable in Lisp are equally likely.
98 On most systems, this is 29 bits' worth.
99 With positive integer argument N, return random number in interval [0,N).
100 With argument t, set the random number seed from the current time and pid. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (n
) && XFASTINT (n
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (n
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
145 if (STRINGP (sequence
))
146 XSETFASTINT (val
, SCHARS (sequence
));
147 else if (VECTORP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
149 else if (SUB_CHAR_TABLE_P (sequence
))
150 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
151 else if (CHAR_TABLE_P (sequence
))
152 XSETFASTINT (val
, MAX_CHAR
);
153 else if (BOOL_VECTOR_P (sequence
))
154 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
155 else if (COMPILEDP (sequence
))
156 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
157 else if (CONSP (sequence
))
160 while (CONSP (sequence
))
162 sequence
= XCDR (sequence
);
165 if (!CONSP (sequence
))
168 sequence
= XCDR (sequence
);
173 if (!NILP (sequence
))
174 wrong_type_argument (Qlistp
, sequence
);
176 val
= make_number (i
);
178 else if (NILP (sequence
))
179 XSETFASTINT (val
, 0);
182 sequence
= wrong_type_argument (Qsequencep
, sequence
);
188 /* This does not check for quits. That is safe
189 since it must terminate. */
191 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
192 doc
: /* Return the length of a list, but avoid error or infinite loop.
193 This function never gets an error. If LIST is not really a list,
194 it returns 0. If LIST is circular, it returns a finite value
195 which is at least the number of distinct elements. */)
199 Lisp_Object tail
, halftail
, length
;
202 /* halftail is used to detect circular lists. */
204 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
206 if (EQ (tail
, halftail
) && len
!= 0)
210 halftail
= XCDR (halftail
);
213 XSETINT (length
, len
);
217 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
218 doc
: /* Return the number of bytes in STRING.
219 If STRING is a multibyte string, this is greater than the length of STRING. */)
223 CHECK_STRING (string
);
224 return make_number (SBYTES (string
));
227 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
228 doc
: /* Return t if two strings have identical contents.
229 Case is significant, but text properties are ignored.
230 Symbols are also allowed; their print names are used instead. */)
232 register Lisp_Object s1
, s2
;
235 s1
= SYMBOL_NAME (s1
);
237 s2
= SYMBOL_NAME (s2
);
241 if (SCHARS (s1
) != SCHARS (s2
)
242 || SBYTES (s1
) != SBYTES (s2
)
243 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
248 DEFUN ("compare-strings", Fcompare_strings
,
249 Scompare_strings
, 6, 7, 0,
250 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
251 In string STR1, skip the first START1 characters and stop at END1.
252 In string STR2, skip the first START2 characters and stop at END2.
253 END1 and END2 default to the full lengths of the respective strings.
255 Case is significant in this comparison if IGNORE-CASE is nil.
256 Unibyte strings are converted to multibyte for comparison.
258 The value is t if the strings (or specified portions) match.
259 If string STR1 is less, the value is a negative number N;
260 - 1 - N is the number of characters that match at the beginning.
261 If string STR1 is greater, the value is a positive number N;
262 N - 1 is the number of characters that match at the beginning. */)
263 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
264 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
266 register int end1_char
, end2_char
;
267 register int i1
, i1_byte
, i2
, i2_byte
;
272 start1
= make_number (0);
274 start2
= make_number (0);
275 CHECK_NATNUM (start1
);
276 CHECK_NATNUM (start2
);
285 i1_byte
= string_char_to_byte (str1
, i1
);
286 i2_byte
= string_char_to_byte (str2
, i2
);
288 end1_char
= SCHARS (str1
);
289 if (! NILP (end1
) && end1_char
> XINT (end1
))
290 end1_char
= XINT (end1
);
292 end2_char
= SCHARS (str2
);
293 if (! NILP (end2
) && end2_char
> XINT (end2
))
294 end2_char
= XINT (end2
);
296 while (i1
< end1_char
&& i2
< end2_char
)
298 /* When we find a mismatch, we must compare the
299 characters, not just the bytes. */
302 if (STRING_MULTIBYTE (str1
))
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
306 c1
= SREF (str1
, i1
++);
307 c1
= unibyte_char_to_multibyte (c1
);
310 if (STRING_MULTIBYTE (str2
))
311 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
314 c2
= SREF (str2
, i2
++);
315 c2
= unibyte_char_to_multibyte (c2
);
321 if (! NILP (ignore_case
))
325 tem
= Fupcase (make_number (c1
));
327 tem
= Fupcase (make_number (c2
));
334 /* Note that I1 has already been incremented
335 past the character that we are comparing;
336 hence we don't add or subtract 1 here. */
338 return make_number (- i1
+ XINT (start1
));
340 return make_number (i1
- XINT (start1
));
344 return make_number (i1
- XINT (start1
) + 1);
346 return make_number (- i1
+ XINT (start1
) - 1);
351 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
352 doc
: /* Return t if first arg string is less than second in lexicographic order.
354 Symbols are also allowed; their print names are used instead. */)
356 register Lisp_Object s1
, s2
;
359 register int i1
, i1_byte
, i2
, i2_byte
;
362 s1
= SYMBOL_NAME (s1
);
364 s2
= SYMBOL_NAME (s2
);
368 i1
= i1_byte
= i2
= i2_byte
= 0;
371 if (end
> SCHARS (s2
))
376 /* When we find a mismatch, we must compare the
377 characters, not just the bytes. */
380 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
381 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
384 return c1
< c2
? Qt
: Qnil
;
386 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
389 static Lisp_Object
concat ();
400 return concat (2, args
, Lisp_String
, 0);
402 return concat (2, &s1
, Lisp_String
, 0);
403 #endif /* NO_ARG_ARRAY */
409 Lisp_Object s1
, s2
, s3
;
416 return concat (3, args
, Lisp_String
, 0);
418 return concat (3, &s1
, Lisp_String
, 0);
419 #endif /* NO_ARG_ARRAY */
422 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
423 doc
: /* Concatenate all the arguments and make the result a list.
424 The result is a list whose elements are the elements of all the arguments.
425 Each argument may be a list, vector or string.
426 The last argument is not copied, just used as the tail of the new list.
427 usage: (append &rest SEQUENCES) */)
432 return concat (nargs
, args
, Lisp_Cons
, 1);
435 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
436 doc
: /* Concatenate all the arguments and make the result a string.
437 The result is a string whose elements are the elements of all the arguments.
438 Each argument may be a string or a list or vector of characters (integers).
439 usage: (concat &rest SEQUENCES) */)
444 return concat (nargs
, args
, Lisp_String
, 0);
447 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
448 doc
: /* Concatenate all the arguments and make the result a vector.
449 The result is a vector whose elements are the elements of all the arguments.
450 Each argument may be a list, vector or string.
451 usage: (vconcat &rest SEQUENCES) */)
456 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
459 /* Return a copy of a sub char table ARG. The elements except for a
460 nested sub char table are not copied. */
462 copy_sub_char_table (arg
)
465 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
468 /* Copy all the contents. */
469 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
470 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
471 /* Recursively copy any sub char-tables in the ordinary slots. */
472 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
473 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
474 XCHAR_TABLE (copy
)->contents
[i
]
475 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
481 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
482 doc
: /* Return a copy of a list, vector, string or char-table.
483 The elements of a list or vector are not copied; they are shared
484 with the original. */)
488 if (NILP (arg
)) return arg
;
490 if (CHAR_TABLE_P (arg
))
495 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
496 /* Copy all the slots, including the extra ones. */
497 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
498 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
499 * sizeof (Lisp_Object
)));
501 /* Recursively copy any sub char tables in the ordinary slots
502 for multibyte characters. */
503 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
504 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
505 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
506 XCHAR_TABLE (copy
)->contents
[i
]
507 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
512 if (BOOL_VECTOR_P (arg
))
516 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
517 / BOOL_VECTOR_BITS_PER_CHAR
);
519 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
520 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
525 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
526 arg
= wrong_type_argument (Qsequencep
, arg
);
527 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
530 /* This structure holds information of an argument of `concat' that is
531 a string and has text properties to be copied. */
534 int argnum
; /* refer to ARGS (arguments of `concat') */
535 int from
; /* refer to ARGS[argnum] (argument string) */
536 int to
; /* refer to VAL (the target string) */
540 concat (nargs
, args
, target_type
, last_special
)
543 enum Lisp_Type target_type
;
547 register Lisp_Object tail
;
548 register Lisp_Object
this;
550 int toindex_byte
= 0;
551 register int result_len
;
552 register int result_len_byte
;
554 Lisp_Object last_tail
;
557 /* When we make a multibyte string, we can't copy text properties
558 while concatinating each string because the length of resulting
559 string can't be decided until we finish the whole concatination.
560 So, we record strings that have text properties to be copied
561 here, and copy the text properties after the concatination. */
562 struct textprop_rec
*textprops
= NULL
;
563 /* Number of elments in textprops. */
564 int num_textprops
= 0;
568 /* In append, the last arg isn't treated like the others */
569 if (last_special
&& nargs
> 0)
572 last_tail
= args
[nargs
];
577 /* Canonicalize each argument. */
578 for (argnum
= 0; argnum
< nargs
; argnum
++)
581 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
582 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
584 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
588 /* Compute total length in chars of arguments in RESULT_LEN.
589 If desired output is a string, also compute length in bytes
590 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
591 whether the result should be a multibyte string. */
595 for (argnum
= 0; argnum
< nargs
; argnum
++)
599 len
= XFASTINT (Flength (this));
600 if (target_type
== Lisp_String
)
602 /* We must count the number of bytes needed in the string
603 as well as the number of characters. */
609 for (i
= 0; i
< len
; i
++)
611 ch
= XVECTOR (this)->contents
[i
];
613 wrong_type_argument (Qintegerp
, ch
);
614 this_len_byte
= CHAR_BYTES (XINT (ch
));
615 result_len_byte
+= this_len_byte
;
616 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
619 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
620 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
621 else if (CONSP (this))
622 for (; CONSP (this); this = XCDR (this))
626 wrong_type_argument (Qintegerp
, ch
);
627 this_len_byte
= CHAR_BYTES (XINT (ch
));
628 result_len_byte
+= this_len_byte
;
629 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
632 else if (STRINGP (this))
634 if (STRING_MULTIBYTE (this))
637 result_len_byte
+= SBYTES (this);
640 result_len_byte
+= count_size_as_multibyte (SDATA (this),
648 if (! some_multibyte
)
649 result_len_byte
= result_len
;
651 /* Create the output object. */
652 if (target_type
== Lisp_Cons
)
653 val
= Fmake_list (make_number (result_len
), Qnil
);
654 else if (target_type
== Lisp_Vectorlike
)
655 val
= Fmake_vector (make_number (result_len
), Qnil
);
656 else if (some_multibyte
)
657 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
659 val
= make_uninit_string (result_len
);
661 /* In `append', if all but last arg are nil, return last arg. */
662 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
665 /* Copy the contents of the args into the result. */
667 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
669 toindex
= 0, toindex_byte
= 0;
674 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
676 for (argnum
= 0; argnum
< nargs
; argnum
++)
680 register unsigned int thisindex
= 0;
681 register unsigned int thisindex_byte
= 0;
685 thislen
= Flength (this), thisleni
= XINT (thislen
);
687 /* Between strings of the same kind, copy fast. */
688 if (STRINGP (this) && STRINGP (val
)
689 && STRING_MULTIBYTE (this) == some_multibyte
)
691 int thislen_byte
= SBYTES (this);
693 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
695 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
697 textprops
[num_textprops
].argnum
= argnum
;
698 textprops
[num_textprops
].from
= 0;
699 textprops
[num_textprops
++].to
= toindex
;
701 toindex_byte
+= thislen_byte
;
703 STRING_SET_CHARS (val
, SCHARS (val
));
705 /* Copy a single-byte string to a multibyte string. */
706 else if (STRINGP (this) && STRINGP (val
))
708 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
710 textprops
[num_textprops
].argnum
= argnum
;
711 textprops
[num_textprops
].from
= 0;
712 textprops
[num_textprops
++].to
= toindex
;
714 toindex_byte
+= copy_text (SDATA (this),
715 SDATA (val
) + toindex_byte
,
716 SCHARS (this), 0, 1);
720 /* Copy element by element. */
723 register Lisp_Object elt
;
725 /* Fetch next element of `this' arg into `elt', or break if
726 `this' is exhausted. */
727 if (NILP (this)) break;
729 elt
= XCAR (this), this = XCDR (this);
730 else if (thisindex
>= thisleni
)
732 else if (STRINGP (this))
735 if (STRING_MULTIBYTE (this))
737 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
740 XSETFASTINT (elt
, c
);
744 XSETFASTINT (elt
, SREF (this, thisindex
++));
746 && (XINT (elt
) >= 0240
747 || (XINT (elt
) >= 0200
748 && ! NILP (Vnonascii_translation_table
)))
749 && XINT (elt
) < 0400)
751 c
= unibyte_char_to_multibyte (XINT (elt
));
756 else if (BOOL_VECTOR_P (this))
759 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
760 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
767 elt
= XVECTOR (this)->contents
[thisindex
++];
769 /* Store this element into the result. */
776 else if (VECTORP (val
))
777 XVECTOR (val
)->contents
[toindex
++] = elt
;
781 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
785 += CHAR_STRING (XINT (elt
),
786 SDATA (val
) + toindex_byte
);
788 SSET (val
, toindex_byte
++, XINT (elt
));
792 /* If we have any multibyte characters,
793 we already decided to make a multibyte string. */
796 /* P exists as a variable
797 to avoid a bug on the Masscomp C compiler. */
798 unsigned char *p
= SDATA (val
) + toindex_byte
;
800 toindex_byte
+= CHAR_STRING (c
, p
);
807 XSETCDR (prev
, last_tail
);
809 if (num_textprops
> 0)
812 int last_to_end
= -1;
814 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
816 this = args
[textprops
[argnum
].argnum
];
817 props
= text_property_list (this,
819 make_number (SCHARS (this)),
821 /* If successive arguments have properites, be sure that the
822 value of `composition' property be the copy. */
823 if (last_to_end
== textprops
[argnum
].to
)
824 make_composition_value_copy (props
);
825 add_text_properties_from_list (val
, props
,
826 make_number (textprops
[argnum
].to
));
827 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
833 static Lisp_Object string_char_byte_cache_string
;
834 static int string_char_byte_cache_charpos
;
835 static int string_char_byte_cache_bytepos
;
838 clear_string_char_byte_cache ()
840 string_char_byte_cache_string
= Qnil
;
843 /* Return the character index corresponding to CHAR_INDEX in STRING. */
846 string_char_to_byte (string
, char_index
)
851 int best_below
, best_below_byte
;
852 int best_above
, best_above_byte
;
854 best_below
= best_below_byte
= 0;
855 best_above
= SCHARS (string
);
856 best_above_byte
= SBYTES (string
);
857 if (best_above
== best_above_byte
)
860 if (EQ (string
, string_char_byte_cache_string
))
862 if (string_char_byte_cache_charpos
< char_index
)
864 best_below
= string_char_byte_cache_charpos
;
865 best_below_byte
= string_char_byte_cache_bytepos
;
869 best_above
= string_char_byte_cache_charpos
;
870 best_above_byte
= string_char_byte_cache_bytepos
;
874 if (char_index
- best_below
< best_above
- char_index
)
876 while (best_below
< char_index
)
879 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
880 best_below
, best_below_byte
);
883 i_byte
= best_below_byte
;
887 while (best_above
> char_index
)
889 unsigned char *pend
= SDATA (string
) + best_above_byte
;
890 unsigned char *pbeg
= pend
- best_above_byte
;
891 unsigned char *p
= pend
- 1;
894 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
895 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
896 if (bytes
== pend
- p
)
897 best_above_byte
-= bytes
;
898 else if (bytes
> pend
- p
)
899 best_above_byte
-= (pend
- p
);
905 i_byte
= best_above_byte
;
908 string_char_byte_cache_bytepos
= i_byte
;
909 string_char_byte_cache_charpos
= i
;
910 string_char_byte_cache_string
= string
;
915 /* Return the character index corresponding to BYTE_INDEX in STRING. */
918 string_byte_to_char (string
, byte_index
)
923 int best_below
, best_below_byte
;
924 int best_above
, best_above_byte
;
926 best_below
= best_below_byte
= 0;
927 best_above
= SCHARS (string
);
928 best_above_byte
= SBYTES (string
);
929 if (best_above
== best_above_byte
)
932 if (EQ (string
, string_char_byte_cache_string
))
934 if (string_char_byte_cache_bytepos
< byte_index
)
936 best_below
= string_char_byte_cache_charpos
;
937 best_below_byte
= string_char_byte_cache_bytepos
;
941 best_above
= string_char_byte_cache_charpos
;
942 best_above_byte
= string_char_byte_cache_bytepos
;
946 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
948 while (best_below_byte
< byte_index
)
951 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
952 best_below
, best_below_byte
);
955 i_byte
= best_below_byte
;
959 while (best_above_byte
> byte_index
)
961 unsigned char *pend
= SDATA (string
) + best_above_byte
;
962 unsigned char *pbeg
= pend
- best_above_byte
;
963 unsigned char *p
= pend
- 1;
966 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
967 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
968 if (bytes
== pend
- p
)
969 best_above_byte
-= bytes
;
970 else if (bytes
> pend
- p
)
971 best_above_byte
-= (pend
- p
);
977 i_byte
= best_above_byte
;
980 string_char_byte_cache_bytepos
= i_byte
;
981 string_char_byte_cache_charpos
= i
;
982 string_char_byte_cache_string
= string
;
987 /* Convert STRING to a multibyte string.
988 Single-byte characters 0240 through 0377 are converted
989 by adding nonascii_insert_offset to each. */
992 string_make_multibyte (string
)
1000 if (STRING_MULTIBYTE (string
))
1003 nbytes
= count_size_as_multibyte (SDATA (string
),
1005 /* If all the chars are ASCII, they won't need any more bytes
1006 once converted. In that case, we can return STRING itself. */
1007 if (nbytes
== SBYTES (string
))
1010 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1011 copy_text (SDATA (string
), buf
, SBYTES (string
),
1014 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1021 /* Convert STRING to a multibyte string without changing each
1022 character codes. Thus, characters 0200 trough 0237 are converted
1023 to eight-bit-control characters, and characters 0240 through 0377
1024 are converted eight-bit-graphic characters. */
1027 string_to_multibyte (string
)
1035 if (STRING_MULTIBYTE (string
))
1038 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1039 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1040 any more bytes once converted. */
1041 if (nbytes
== SBYTES (string
))
1042 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1044 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1045 bcopy (SDATA (string
), buf
, SBYTES (string
));
1046 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1048 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1055 /* Convert STRING to a single-byte string. */
1058 string_make_unibyte (string
)
1066 if (! STRING_MULTIBYTE (string
))
1069 nchars
= SCHARS (string
);
1071 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1072 copy_text (SDATA (string
), buf
, SBYTES (string
),
1075 ret
= make_unibyte_string (buf
, nchars
);
1081 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1083 doc
: /* Return the multibyte equivalent of STRING.
1084 If STRING is unibyte and contains non-ASCII characters, the function
1085 `unibyte-char-to-multibyte' is used to convert each unibyte character
1086 to a multibyte character. In this case, the returned string is a
1087 newly created string with no text properties. If STRING is multibyte
1088 or entirely ASCII, it is returned unchanged. In particular, when
1089 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1090 \(When the characters are all ASCII, Emacs primitives will treat the
1091 string the same way whether it is unibyte or multibyte.) */)
1095 CHECK_STRING (string
);
1097 return string_make_multibyte (string
);
1100 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1102 doc
: /* Return the unibyte equivalent of STRING.
1103 Multibyte character codes are converted to unibyte according to
1104 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1105 If the lookup in the translation table fails, this function takes just
1106 the low 8 bits of each character. */)
1110 CHECK_STRING (string
);
1112 return string_make_unibyte (string
);
1115 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1117 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1118 If STRING is unibyte, the result is STRING itself.
1119 Otherwise it is a newly created string, with no text properties.
1120 If STRING is multibyte and contains a character of charset
1121 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1122 corresponding single byte. */)
1126 CHECK_STRING (string
);
1128 if (STRING_MULTIBYTE (string
))
1130 int bytes
= SBYTES (string
);
1131 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1133 bcopy (SDATA (string
), str
, bytes
);
1134 bytes
= str_as_unibyte (str
, bytes
);
1135 string
= make_unibyte_string (str
, bytes
);
1141 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1143 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1144 If STRING is multibyte, the result is STRING itself.
1145 Otherwise it is a newly created string, with no text properties.
1146 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1147 part of a multibyte form), it is converted to the corresponding
1148 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1152 CHECK_STRING (string
);
1154 if (! STRING_MULTIBYTE (string
))
1156 Lisp_Object new_string
;
1159 parse_str_as_multibyte (SDATA (string
),
1162 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1163 bcopy (SDATA (string
), SDATA (new_string
),
1165 if (nbytes
!= SBYTES (string
))
1166 str_as_multibyte (SDATA (new_string
), nbytes
,
1167 SBYTES (string
), NULL
);
1168 string
= new_string
;
1169 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1174 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1176 doc
: /* Return a multibyte string with the same individual chars as STRING.
1177 If STRING is multibyte, the result is STRING itself.
1178 Otherwise it is a newly created string, with no text properties.
1179 Characters 0200 through 0237 are converted to eight-bit-control
1180 characters of the same character code. Characters 0240 through 0377
1181 are converted to eight-bit-graphic characters of the same character
1186 CHECK_STRING (string
);
1188 return string_to_multibyte (string
);
1192 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1193 doc
: /* Return a copy of ALIST.
1194 This is an alist which represents the same mapping from objects to objects,
1195 but does not share the alist structure with ALIST.
1196 The objects mapped (cars and cdrs of elements of the alist)
1197 are shared, however.
1198 Elements of ALIST that are not conses are also shared. */)
1202 register Lisp_Object tem
;
1207 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1208 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1210 register Lisp_Object car
;
1214 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1219 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1220 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1221 TO may be nil or omitted; then the substring runs to the end of STRING.
1222 FROM and TO start at 0. If either is negative, it counts from the end.
1224 This function allows vectors as well as strings. */)
1227 register Lisp_Object from
, to
;
1232 int from_char
, to_char
;
1233 int from_byte
= 0, to_byte
= 0;
1235 if (! (STRINGP (string
) || VECTORP (string
)))
1236 wrong_type_argument (Qarrayp
, string
);
1238 CHECK_NUMBER (from
);
1240 if (STRINGP (string
))
1242 size
= SCHARS (string
);
1243 size_byte
= SBYTES (string
);
1246 size
= XVECTOR (string
)->size
;
1251 to_byte
= size_byte
;
1257 to_char
= XINT (to
);
1261 if (STRINGP (string
))
1262 to_byte
= string_char_to_byte (string
, to_char
);
1265 from_char
= XINT (from
);
1268 if (STRINGP (string
))
1269 from_byte
= string_char_to_byte (string
, from_char
);
1271 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1272 args_out_of_range_3 (string
, make_number (from_char
),
1273 make_number (to_char
));
1275 if (STRINGP (string
))
1277 res
= make_specified_string (SDATA (string
) + from_byte
,
1278 to_char
- from_char
, to_byte
- from_byte
,
1279 STRING_MULTIBYTE (string
));
1280 copy_text_properties (make_number (from_char
), make_number (to_char
),
1281 string
, make_number (0), res
, Qnil
);
1284 res
= Fvector (to_char
- from_char
,
1285 XVECTOR (string
)->contents
+ from_char
);
1291 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1292 doc
: /* Return a substring of STRING, without text properties.
1293 It starts at index FROM and ending before TO.
1294 TO may be nil or omitted; then the substring runs to the end of STRING.
1295 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1296 If FROM or TO is negative, it counts from the end.
1298 With one argument, just copy STRING without its properties. */)
1301 register Lisp_Object from
, to
;
1303 int size
, size_byte
;
1304 int from_char
, to_char
;
1305 int from_byte
, to_byte
;
1307 CHECK_STRING (string
);
1309 size
= SCHARS (string
);
1310 size_byte
= SBYTES (string
);
1313 from_char
= from_byte
= 0;
1316 CHECK_NUMBER (from
);
1317 from_char
= XINT (from
);
1321 from_byte
= string_char_to_byte (string
, from_char
);
1327 to_byte
= size_byte
;
1333 to_char
= XINT (to
);
1337 to_byte
= string_char_to_byte (string
, to_char
);
1340 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1341 args_out_of_range_3 (string
, make_number (from_char
),
1342 make_number (to_char
));
1344 return make_specified_string (SDATA (string
) + from_byte
,
1345 to_char
- from_char
, to_byte
- from_byte
,
1346 STRING_MULTIBYTE (string
));
1349 /* Extract a substring of STRING, giving start and end positions
1350 both in characters and in bytes. */
1353 substring_both (string
, from
, from_byte
, to
, to_byte
)
1355 int from
, from_byte
, to
, to_byte
;
1361 if (! (STRINGP (string
) || VECTORP (string
)))
1362 wrong_type_argument (Qarrayp
, string
);
1364 if (STRINGP (string
))
1366 size
= SCHARS (string
);
1367 size_byte
= SBYTES (string
);
1370 size
= XVECTOR (string
)->size
;
1372 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1373 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1375 if (STRINGP (string
))
1377 res
= make_specified_string (SDATA (string
) + from_byte
,
1378 to
- from
, to_byte
- from_byte
,
1379 STRING_MULTIBYTE (string
));
1380 copy_text_properties (make_number (from
), make_number (to
),
1381 string
, make_number (0), res
, Qnil
);
1384 res
= Fvector (to
- from
,
1385 XVECTOR (string
)->contents
+ from
);
1390 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1391 doc
: /* Take cdr N times on LIST, returns the result. */)
1394 register Lisp_Object list
;
1396 register int i
, num
;
1399 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1403 wrong_type_argument (Qlistp
, list
);
1409 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1410 doc
: /* Return the Nth element of LIST.
1411 N counts from zero. If LIST is not that long, nil is returned. */)
1413 Lisp_Object n
, list
;
1415 return Fcar (Fnthcdr (n
, list
));
1418 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1419 doc
: /* Return element of SEQUENCE at index N. */)
1421 register Lisp_Object sequence
, n
;
1426 if (CONSP (sequence
) || NILP (sequence
))
1427 return Fcar (Fnthcdr (n
, sequence
));
1428 else if (STRINGP (sequence
) || VECTORP (sequence
)
1429 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1430 return Faref (sequence
, n
);
1432 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1436 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1437 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1438 The value is actually the tail of LIST whose car is ELT. */)
1440 register Lisp_Object elt
;
1443 register Lisp_Object tail
;
1444 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1446 register Lisp_Object tem
;
1448 wrong_type_argument (Qlistp
, list
);
1450 if (! NILP (Fequal (elt
, tem
)))
1457 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1458 doc
: /* Return non-nil if ELT is an element of LIST.
1459 Comparison done with EQ. The value is actually the tail of LIST
1460 whose car is ELT. */)
1462 Lisp_Object elt
, list
;
1466 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1470 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1474 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1481 if (!CONSP (list
) && !NILP (list
))
1482 list
= wrong_type_argument (Qlistp
, list
);
1487 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1488 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1489 The value is actually the first element of LIST whose car is KEY.
1490 Elements of LIST that are not conses are ignored. */)
1492 Lisp_Object key
, list
;
1499 || (CONSP (XCAR (list
))
1500 && EQ (XCAR (XCAR (list
)), key
)))
1505 || (CONSP (XCAR (list
))
1506 && EQ (XCAR (XCAR (list
)), key
)))
1511 || (CONSP (XCAR (list
))
1512 && EQ (XCAR (XCAR (list
)), key
)))
1520 result
= XCAR (list
);
1521 else if (NILP (list
))
1524 result
= wrong_type_argument (Qlistp
, list
);
1529 /* Like Fassq but never report an error and do not allow quits.
1530 Use only on lists known never to be circular. */
1533 assq_no_quit (key
, list
)
1534 Lisp_Object key
, list
;
1537 && (!CONSP (XCAR (list
))
1538 || !EQ (XCAR (XCAR (list
)), key
)))
1541 return CONSP (list
) ? XCAR (list
) : Qnil
;
1544 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1545 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1546 The value is actually the first element of LIST whose car equals KEY. */)
1548 Lisp_Object key
, list
;
1550 Lisp_Object result
, car
;
1555 || (CONSP (XCAR (list
))
1556 && (car
= XCAR (XCAR (list
)),
1557 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1562 || (CONSP (XCAR (list
))
1563 && (car
= XCAR (XCAR (list
)),
1564 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1569 || (CONSP (XCAR (list
))
1570 && (car
= XCAR (XCAR (list
)),
1571 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1579 result
= XCAR (list
);
1580 else if (NILP (list
))
1583 result
= wrong_type_argument (Qlistp
, list
);
1588 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1589 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1590 The value is actually the first element of LIST whose cdr is KEY. */)
1592 register Lisp_Object key
;
1600 || (CONSP (XCAR (list
))
1601 && EQ (XCDR (XCAR (list
)), key
)))
1606 || (CONSP (XCAR (list
))
1607 && EQ (XCDR (XCAR (list
)), key
)))
1612 || (CONSP (XCAR (list
))
1613 && EQ (XCDR (XCAR (list
)), key
)))
1622 else if (CONSP (list
))
1623 result
= XCAR (list
);
1625 result
= wrong_type_argument (Qlistp
, list
);
1630 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1631 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1632 The value is actually the first element of LIST whose cdr equals KEY. */)
1634 Lisp_Object key
, list
;
1636 Lisp_Object result
, cdr
;
1641 || (CONSP (XCAR (list
))
1642 && (cdr
= XCDR (XCAR (list
)),
1643 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1648 || (CONSP (XCAR (list
))
1649 && (cdr
= XCDR (XCAR (list
)),
1650 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1655 || (CONSP (XCAR (list
))
1656 && (cdr
= XCDR (XCAR (list
)),
1657 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1665 result
= XCAR (list
);
1666 else if (NILP (list
))
1669 result
= wrong_type_argument (Qlistp
, list
);
1674 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1675 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1676 The modified LIST is returned. Comparison is done with `eq'.
1677 If the first member of LIST is ELT, there is no way to remove it by side effect;
1678 therefore, write `(setq foo (delq element foo))'
1679 to be sure of changing the value of `foo'. */)
1681 register Lisp_Object elt
;
1684 register Lisp_Object tail
, prev
;
1685 register Lisp_Object tem
;
1689 while (!NILP (tail
))
1692 wrong_type_argument (Qlistp
, list
);
1699 Fsetcdr (prev
, XCDR (tail
));
1709 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1710 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1711 SEQ must be a list, a vector, or a string.
1712 The modified SEQ is returned. Comparison is done with `equal'.
1713 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1714 is not a side effect; it is simply using a different sequence.
1715 Therefore, write `(setq foo (delete element foo))'
1716 to be sure of changing the value of `foo'. */)
1718 Lisp_Object elt
, seq
;
1724 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1725 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1728 if (n
!= ASIZE (seq
))
1730 struct Lisp_Vector
*p
= allocate_vector (n
);
1732 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1733 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1734 p
->contents
[n
++] = AREF (seq
, i
);
1736 XSETVECTOR (seq
, p
);
1739 else if (STRINGP (seq
))
1741 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1744 for (i
= nchars
= nbytes
= ibyte
= 0;
1746 ++i
, ibyte
+= cbytes
)
1748 if (STRING_MULTIBYTE (seq
))
1750 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1751 SBYTES (seq
) - ibyte
);
1752 cbytes
= CHAR_BYTES (c
);
1760 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1767 if (nchars
!= SCHARS (seq
))
1771 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1772 if (!STRING_MULTIBYTE (seq
))
1773 STRING_SET_UNIBYTE (tem
);
1775 for (i
= nchars
= nbytes
= ibyte
= 0;
1777 ++i
, ibyte
+= cbytes
)
1779 if (STRING_MULTIBYTE (seq
))
1781 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1782 SBYTES (seq
) - ibyte
);
1783 cbytes
= CHAR_BYTES (c
);
1791 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1793 unsigned char *from
= SDATA (seq
) + ibyte
;
1794 unsigned char *to
= SDATA (tem
) + nbytes
;
1800 for (n
= cbytes
; n
--; )
1810 Lisp_Object tail
, prev
;
1812 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1815 wrong_type_argument (Qlistp
, seq
);
1817 if (!NILP (Fequal (elt
, XCAR (tail
))))
1822 Fsetcdr (prev
, XCDR (tail
));
1833 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1834 doc
: /* Reverse LIST by modifying cdr pointers.
1835 Return the reversed list. */)
1839 register Lisp_Object prev
, tail
, next
;
1841 if (NILP (list
)) return list
;
1844 while (!NILP (tail
))
1848 wrong_type_argument (Qlistp
, list
);
1850 Fsetcdr (tail
, prev
);
1857 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1858 doc
: /* Reverse LIST, copying. Return the reversed list.
1859 See also the function `nreverse', which is used more often. */)
1865 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1868 new = Fcons (XCAR (list
), new);
1871 wrong_type_argument (Qconsp
, list
);
1875 Lisp_Object
merge ();
1877 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1878 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1879 Returns the sorted list. LIST is modified by side effects.
1880 PREDICATE is called with two elements of LIST, and should return t
1881 if the first element is "less" than the second. */)
1883 Lisp_Object list
, predicate
;
1885 Lisp_Object front
, back
;
1886 register Lisp_Object len
, tem
;
1887 struct gcpro gcpro1
, gcpro2
;
1888 register int length
;
1891 len
= Flength (list
);
1892 length
= XINT (len
);
1896 XSETINT (len
, (length
/ 2) - 1);
1897 tem
= Fnthcdr (len
, list
);
1899 Fsetcdr (tem
, Qnil
);
1901 GCPRO2 (front
, back
);
1902 front
= Fsort (front
, predicate
);
1903 back
= Fsort (back
, predicate
);
1905 return merge (front
, back
, predicate
);
1909 merge (org_l1
, org_l2
, pred
)
1910 Lisp_Object org_l1
, org_l2
;
1914 register Lisp_Object tail
;
1916 register Lisp_Object l1
, l2
;
1917 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1924 /* It is sufficient to protect org_l1 and org_l2.
1925 When l1 and l2 are updated, we copy the new values
1926 back into the org_ vars. */
1927 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1947 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1963 Fsetcdr (tail
, tem
);
1969 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1970 doc
: /* Extract a value from a property list.
1971 PLIST is a property list, which is a list of the form
1972 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1973 corresponding to the given PROP, or nil if PROP is not
1974 one of the properties on the list. */)
1982 CONSP (tail
) && CONSP (XCDR (tail
));
1983 tail
= XCDR (XCDR (tail
)))
1985 if (EQ (prop
, XCAR (tail
)))
1986 return XCAR (XCDR (tail
));
1988 /* This function can be called asynchronously
1989 (setup_coding_system). Don't QUIT in that case. */
1990 if (!interrupt_input_blocked
)
1995 wrong_type_argument (Qlistp
, prop
);
2000 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2001 doc
: /* Return the value of SYMBOL's PROPNAME property.
2002 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2004 Lisp_Object symbol
, propname
;
2006 CHECK_SYMBOL (symbol
);
2007 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2010 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2011 doc
: /* Change value in PLIST of PROP to VAL.
2012 PLIST is a property list, which is a list of the form
2013 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2014 If PROP is already a property on the list, its value is set to VAL,
2015 otherwise the new PROP VAL pair is added. The new plist is returned;
2016 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2017 The PLIST is modified by side effects. */)
2020 register Lisp_Object prop
;
2023 register Lisp_Object tail
, prev
;
2024 Lisp_Object newcell
;
2026 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2027 tail
= XCDR (XCDR (tail
)))
2029 if (EQ (prop
, XCAR (tail
)))
2031 Fsetcar (XCDR (tail
), val
);
2038 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2042 Fsetcdr (XCDR (prev
), newcell
);
2046 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2047 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2048 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2049 (symbol
, propname
, value
)
2050 Lisp_Object symbol
, propname
, value
;
2052 CHECK_SYMBOL (symbol
);
2053 XSYMBOL (symbol
)->plist
2054 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2058 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2059 doc
: /* Extract a value from a property list, comparing with `equal'.
2060 PLIST is a property list, which is a list of the form
2061 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2062 corresponding to the given PROP, or nil if PROP is not
2063 one of the properties on the list. */)
2071 CONSP (tail
) && CONSP (XCDR (tail
));
2072 tail
= XCDR (XCDR (tail
)))
2074 if (! NILP (Fequal (prop
, XCAR (tail
))))
2075 return XCAR (XCDR (tail
));
2081 wrong_type_argument (Qlistp
, prop
);
2086 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2087 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2088 PLIST is a property list, which is a list of the form
2089 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2090 If PROP is already a property on the list, its value is set to VAL,
2091 otherwise the new PROP VAL pair is added. The new plist is returned;
2092 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2093 The PLIST is modified by side effects. */)
2096 register Lisp_Object prop
;
2099 register Lisp_Object tail
, prev
;
2100 Lisp_Object newcell
;
2102 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2103 tail
= XCDR (XCDR (tail
)))
2105 if (! NILP (Fequal (prop
, XCAR (tail
))))
2107 Fsetcar (XCDR (tail
), val
);
2114 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2118 Fsetcdr (XCDR (prev
), newcell
);
2122 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2123 doc
: /* Return t if the two args are the same Lisp object.
2124 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2126 Lisp_Object obj1
, obj2
;
2129 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2131 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2134 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2135 doc
: /* Return t if two Lisp objects have similar structure and contents.
2136 They must have the same data type.
2137 Conses are compared by comparing the cars and the cdrs.
2138 Vectors and strings are compared element by element.
2139 Numbers are compared by value, but integers cannot equal floats.
2140 (Use `=' if you want integers and floats to be able to be equal.)
2141 Symbols must match exactly. */)
2143 register Lisp_Object o1
, o2
;
2145 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2148 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2149 doc
: /* Return t if two Lisp objects have similar structure and contents.
2150 This is like `equal' except that it compares the text properties
2151 of strings. (`equal' ignores text properties.) */)
2153 register Lisp_Object o1
, o2
;
2155 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2158 /* DEPTH is current depth of recursion. Signal an error if it
2160 PROPS, if non-nil, means compare string text properties too. */
2163 internal_equal (o1
, o2
, depth
, props
)
2164 register Lisp_Object o1
, o2
;
2168 error ("Stack overflow in equal");
2174 if (XTYPE (o1
) != XTYPE (o2
))
2183 d1
= extract_float (o1
);
2184 d2
= extract_float (o2
);
2185 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2186 though they are not =. */
2187 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2191 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2198 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2202 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2204 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2207 o1
= XOVERLAY (o1
)->plist
;
2208 o2
= XOVERLAY (o2
)->plist
;
2213 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2214 && (XMARKER (o1
)->buffer
== 0
2215 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2219 case Lisp_Vectorlike
:
2222 EMACS_INT size
= XVECTOR (o1
)->size
;
2223 /* Pseudovectors have the type encoded in the size field, so this test
2224 actually checks that the objects have the same type as well as the
2226 if (XVECTOR (o2
)->size
!= size
)
2228 /* Boolvectors are compared much like strings. */
2229 if (BOOL_VECTOR_P (o1
))
2232 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2233 / BOOL_VECTOR_BITS_PER_CHAR
);
2235 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2237 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2242 if (WINDOW_CONFIGURATIONP (o1
))
2243 return compare_window_configurations (o1
, o2
, 0);
2245 /* Aside from them, only true vectors, char-tables, and compiled
2246 functions are sensible to compare, so eliminate the others now. */
2247 if (size
& PSEUDOVECTOR_FLAG
)
2249 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2251 size
&= PSEUDOVECTOR_SIZE_MASK
;
2253 for (i
= 0; i
< size
; i
++)
2256 v1
= XVECTOR (o1
)->contents
[i
];
2257 v2
= XVECTOR (o2
)->contents
[i
];
2258 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2266 if (SCHARS (o1
) != SCHARS (o2
))
2268 if (SBYTES (o1
) != SBYTES (o2
))
2270 if (bcmp (SDATA (o1
), SDATA (o2
),
2273 if (props
&& !compare_string_intervals (o1
, o2
))
2279 case Lisp_Type_Limit
:
2286 extern Lisp_Object
Fmake_char_internal ();
2288 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2289 doc
: /* Store each element of ARRAY with ITEM.
2290 ARRAY is a vector, string, char-table, or bool-vector. */)
2292 Lisp_Object array
, item
;
2294 register int size
, index
, charval
;
2296 if (VECTORP (array
))
2298 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2299 size
= XVECTOR (array
)->size
;
2300 for (index
= 0; index
< size
; index
++)
2303 else if (CHAR_TABLE_P (array
))
2305 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2306 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2307 for (index
= 0; index
< size
; index
++)
2309 XCHAR_TABLE (array
)->defalt
= Qnil
;
2311 else if (STRINGP (array
))
2313 register unsigned char *p
= SDATA (array
);
2314 CHECK_NUMBER (item
);
2315 charval
= XINT (item
);
2316 size
= SCHARS (array
);
2317 if (STRING_MULTIBYTE (array
))
2319 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2320 int len
= CHAR_STRING (charval
, str
);
2321 int size_byte
= SBYTES (array
);
2322 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2325 if (size
!= size_byte
)
2328 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2329 if (len
!= this_len
)
2330 error ("Attempt to change byte length of a string");
2333 for (i
= 0; i
< size_byte
; i
++)
2334 *p
++ = str
[i
% len
];
2337 for (index
= 0; index
< size
; index
++)
2340 else if (BOOL_VECTOR_P (array
))
2342 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2344 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2345 / BOOL_VECTOR_BITS_PER_CHAR
);
2347 charval
= (! NILP (item
) ? -1 : 0);
2348 for (index
= 0; index
< size_in_chars
- 1; index
++)
2350 if (index
< size_in_chars
)
2352 /* Mask out bits beyond the vector size. */
2353 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2354 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2360 array
= wrong_type_argument (Qarrayp
, array
);
2366 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2368 doc
: /* Clear the contents of STRING.
2369 This makes STRING unibyte and may change its length. */)
2373 int len
= SBYTES (string
);
2374 CHECK_STRING (string
);
2375 bzero (SDATA (string
), len
);
2376 STRING_SET_CHARS (string
, len
);
2377 STRING_SET_UNIBYTE (string
);
2381 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2383 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2385 Lisp_Object char_table
;
2387 CHECK_CHAR_TABLE (char_table
);
2389 return XCHAR_TABLE (char_table
)->purpose
;
2392 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2394 doc
: /* Return the parent char-table of CHAR-TABLE.
2395 The value is either nil or another char-table.
2396 If CHAR-TABLE holds nil for a given character,
2397 then the actual applicable value is inherited from the parent char-table
2398 \(or from its parents, if necessary). */)
2400 Lisp_Object char_table
;
2402 CHECK_CHAR_TABLE (char_table
);
2404 return XCHAR_TABLE (char_table
)->parent
;
2407 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2409 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2410 Return PARENT. PARENT must be either nil or another char-table. */)
2411 (char_table
, parent
)
2412 Lisp_Object char_table
, parent
;
2416 CHECK_CHAR_TABLE (char_table
);
2420 CHECK_CHAR_TABLE (parent
);
2422 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2423 if (EQ (temp
, char_table
))
2424 error ("Attempt to make a chartable be its own parent");
2427 XCHAR_TABLE (char_table
)->parent
= parent
;
2432 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2434 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2436 Lisp_Object char_table
, n
;
2438 CHECK_CHAR_TABLE (char_table
);
2441 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2442 args_out_of_range (char_table
, n
);
2444 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2447 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2448 Sset_char_table_extra_slot
,
2450 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2451 (char_table
, n
, value
)
2452 Lisp_Object char_table
, n
, value
;
2454 CHECK_CHAR_TABLE (char_table
);
2457 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2458 args_out_of_range (char_table
, n
);
2460 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2463 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2465 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2466 RANGE should be nil (for the default value)
2467 a vector which identifies a character set or a row of a character set,
2468 a character set name, or a character code. */)
2470 Lisp_Object char_table
, range
;
2472 CHECK_CHAR_TABLE (char_table
);
2474 if (EQ (range
, Qnil
))
2475 return XCHAR_TABLE (char_table
)->defalt
;
2476 else if (INTEGERP (range
))
2477 return Faref (char_table
, range
);
2478 else if (SYMBOLP (range
))
2480 Lisp_Object charset_info
;
2482 charset_info
= Fget (range
, Qcharset
);
2483 CHECK_VECTOR (charset_info
);
2485 return Faref (char_table
,
2486 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2489 else if (VECTORP (range
))
2491 if (XVECTOR (range
)->size
== 1)
2492 return Faref (char_table
,
2493 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2496 int size
= XVECTOR (range
)->size
;
2497 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2498 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2499 size
<= 1 ? Qnil
: val
[1],
2500 size
<= 2 ? Qnil
: val
[2]);
2501 return Faref (char_table
, ch
);
2505 error ("Invalid RANGE argument to `char-table-range'");
2509 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2511 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2512 RANGE should be t (for all characters), nil (for the default value),
2513 a character set, a vector which identifies a character set, a row of a
2514 character set, or a character code. Return VALUE. */)
2515 (char_table
, range
, value
)
2516 Lisp_Object char_table
, range
, value
;
2520 CHECK_CHAR_TABLE (char_table
);
2523 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2524 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2525 else if (EQ (range
, Qnil
))
2526 XCHAR_TABLE (char_table
)->defalt
= value
;
2527 else if (SYMBOLP (range
))
2529 Lisp_Object charset_info
;
2532 charset_info
= Fget (range
, Qcharset
);
2533 if (! VECTORP (charset_info
)
2534 || ! NATNUMP (AREF (charset_info
, 0))
2535 || (charset_id
= XINT (AREF (charset_info
, 0)),
2536 ! CHARSET_DEFINED_P (charset_id
)))
2537 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2539 if (charset_id
== CHARSET_ASCII
)
2540 for (i
= 0; i
< 128; i
++)
2541 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2542 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2543 for (i
= 128; i
< 160; i
++)
2544 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2545 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2546 for (i
= 160; i
< 256; i
++)
2547 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2549 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2551 else if (INTEGERP (range
))
2552 Faset (char_table
, range
, value
);
2553 else if (VECTORP (range
))
2555 if (XVECTOR (range
)->size
== 1)
2556 return Faset (char_table
,
2557 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2561 int size
= XVECTOR (range
)->size
;
2562 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2563 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2564 size
<= 1 ? Qnil
: val
[1],
2565 size
<= 2 ? Qnil
: val
[2]);
2566 return Faset (char_table
, ch
, value
);
2570 error ("Invalid RANGE argument to `set-char-table-range'");
2575 DEFUN ("set-char-table-default", Fset_char_table_default
,
2576 Sset_char_table_default
, 3, 3, 0,
2577 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2578 The generic character specifies the group of characters.
2579 See also the documentation of `make-char'. */)
2580 (char_table
, ch
, value
)
2581 Lisp_Object char_table
, ch
, value
;
2583 int c
, charset
, code1
, code2
;
2586 CHECK_CHAR_TABLE (char_table
);
2590 SPLIT_CHAR (c
, charset
, code1
, code2
);
2592 /* Since we may want to set the default value for a character set
2593 not yet defined, we check only if the character set is in the
2594 valid range or not, instead of it is already defined or not. */
2595 if (! CHARSET_VALID_P (charset
))
2596 invalid_character (c
);
2598 if (charset
== CHARSET_ASCII
)
2599 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2601 /* Even if C is not a generic char, we had better behave as if a
2602 generic char is specified. */
2603 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2605 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2608 if (SUB_CHAR_TABLE_P (temp
))
2609 XCHAR_TABLE (temp
)->defalt
= value
;
2611 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2614 if (SUB_CHAR_TABLE_P (temp
))
2617 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2618 = make_sub_char_table (temp
));
2619 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2620 if (SUB_CHAR_TABLE_P (temp
))
2621 XCHAR_TABLE (temp
)->defalt
= value
;
2623 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2627 /* Look up the element in TABLE at index CH,
2628 and return it as an integer.
2629 If the element is nil, return CH itself.
2630 (Actually we do that for any non-integer.) */
2633 char_table_translate (table
, ch
)
2638 value
= Faref (table
, make_number (ch
));
2639 if (! INTEGERP (value
))
2641 return XINT (value
);
2645 optimize_sub_char_table (table
, chars
)
2653 from
= 33, to
= 127;
2655 from
= 32, to
= 128;
2657 if (!SUB_CHAR_TABLE_P (*table
))
2659 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2660 for (; from
< to
; from
++)
2661 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2666 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2667 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2675 CHECK_CHAR_TABLE (table
);
2677 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2679 elt
= XCHAR_TABLE (table
)->contents
[i
];
2680 if (!SUB_CHAR_TABLE_P (elt
))
2682 dim
= CHARSET_DIMENSION (i
- 128);
2684 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2685 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2686 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2692 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2693 character or group of characters that share a value.
2694 DEPTH is the current depth in the originally specified
2695 chartable, and INDICES contains the vector indices
2696 for the levels our callers have descended.
2698 ARG is passed to C_FUNCTION when that is called. */
2701 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2702 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2703 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2710 /* At first, handle ASCII and 8-bit European characters. */
2711 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2713 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2715 elt
= XCHAR_TABLE (subtable
)->defalt
;
2717 elt
= Faref (subtable
, make_number (i
));
2719 (*c_function
) (arg
, make_number (i
), elt
);
2721 call2 (function
, make_number (i
), elt
);
2723 #if 0 /* If the char table has entries for higher characters,
2724 we should report them. */
2725 if (NILP (current_buffer
->enable_multibyte_characters
))
2728 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2732 int charset
= XFASTINT (indices
[0]) - 128;
2735 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2736 if (CHARSET_CHARS (charset
) == 94)
2745 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2746 XSETFASTINT (indices
[depth
], i
);
2747 charset
= XFASTINT (indices
[0]) - 128;
2749 && (!CHARSET_DEFINED_P (charset
)
2750 || charset
== CHARSET_8_BIT_CONTROL
2751 || charset
== CHARSET_8_BIT_GRAPHIC
))
2754 if (SUB_CHAR_TABLE_P (elt
))
2757 error ("Too deep char table");
2758 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2764 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2765 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2766 c
= MAKE_CHAR (charset
, c1
, c2
);
2769 elt
= XCHAR_TABLE (subtable
)->defalt
;
2771 elt
= Faref (table
, make_number (c
));
2774 (*c_function
) (arg
, make_number (c
), elt
);
2776 call2 (function
, make_number (c
), elt
);
2781 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2783 void_call2 (a
, b
, c
)
2784 Lisp_Object a
, b
, c
;
2789 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2791 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2792 FUNCTION is called with two arguments--a key and a value.
2793 The key is always a possible IDX argument to `aref'. */)
2794 (function
, char_table
)
2795 Lisp_Object function
, char_table
;
2797 /* The depth of char table is at most 3. */
2798 Lisp_Object indices
[3];
2800 CHECK_CHAR_TABLE (char_table
);
2802 /* When Lisp_Object is represented as a union, `call2' cannot directly
2803 be passed to map_char_table because it returns a Lisp_Object rather
2804 than returning nothing.
2805 Casting leads to crashes on some architectures. -stef */
2806 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2810 /* Return a value for character C in char-table TABLE. Store the
2811 actual index for that value in *IDX. Ignore the default value of
2815 char_table_ref_and_index (table
, c
, idx
)
2819 int charset
, c1
, c2
;
2822 if (SINGLE_BYTE_CHAR_P (c
))
2825 return XCHAR_TABLE (table
)->contents
[c
];
2827 SPLIT_CHAR (c
, charset
, c1
, c2
);
2828 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2829 *idx
= MAKE_CHAR (charset
, 0, 0);
2830 if (!SUB_CHAR_TABLE_P (elt
))
2832 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2833 return XCHAR_TABLE (elt
)->defalt
;
2834 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2835 *idx
= MAKE_CHAR (charset
, c1
, 0);
2836 if (!SUB_CHAR_TABLE_P (elt
))
2838 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2839 return XCHAR_TABLE (elt
)->defalt
;
2841 return XCHAR_TABLE (elt
)->contents
[c2
];
2851 Lisp_Object args
[2];
2854 return Fnconc (2, args
);
2856 return Fnconc (2, &s1
);
2857 #endif /* NO_ARG_ARRAY */
2860 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2861 doc
: /* Concatenate any number of lists by altering them.
2862 Only the last argument is not altered, and need not be a list.
2863 usage: (nconc &rest LISTS) */)
2868 register int argnum
;
2869 register Lisp_Object tail
, tem
, val
;
2873 for (argnum
= 0; argnum
< nargs
; argnum
++)
2876 if (NILP (tem
)) continue;
2881 if (argnum
+ 1 == nargs
) break;
2884 tem
= wrong_type_argument (Qlistp
, tem
);
2893 tem
= args
[argnum
+ 1];
2894 Fsetcdr (tail
, tem
);
2896 args
[argnum
+ 1] = tail
;
2902 /* This is the guts of all mapping functions.
2903 Apply FN to each element of SEQ, one by one,
2904 storing the results into elements of VALS, a C vector of Lisp_Objects.
2905 LENI is the length of VALS, which should also be the length of SEQ. */
2908 mapcar1 (leni
, vals
, fn
, seq
)
2911 Lisp_Object fn
, seq
;
2913 register Lisp_Object tail
;
2916 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2920 /* Don't let vals contain any garbage when GC happens. */
2921 for (i
= 0; i
< leni
; i
++)
2924 GCPRO3 (dummy
, fn
, seq
);
2926 gcpro1
.nvars
= leni
;
2930 /* We need not explicitly protect `tail' because it is used only on lists, and
2931 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2935 for (i
= 0; i
< leni
; i
++)
2937 dummy
= XVECTOR (seq
)->contents
[i
];
2938 dummy
= call1 (fn
, dummy
);
2943 else if (BOOL_VECTOR_P (seq
))
2945 for (i
= 0; i
< leni
; i
++)
2948 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2949 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
2954 dummy
= call1 (fn
, dummy
);
2959 else if (STRINGP (seq
))
2963 for (i
= 0, i_byte
= 0; i
< leni
;)
2968 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2969 XSETFASTINT (dummy
, c
);
2970 dummy
= call1 (fn
, dummy
);
2972 vals
[i_before
] = dummy
;
2975 else /* Must be a list, since Flength did not get an error */
2978 for (i
= 0; i
< leni
; i
++)
2980 dummy
= call1 (fn
, Fcar (tail
));
2990 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2991 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2992 In between each pair of results, stick in SEPARATOR. Thus, " " as
2993 SEPARATOR results in spaces between the values returned by FUNCTION.
2994 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2995 (function
, sequence
, separator
)
2996 Lisp_Object function
, sequence
, separator
;
3001 register Lisp_Object
*args
;
3003 struct gcpro gcpro1
;
3007 len
= Flength (sequence
);
3009 nargs
= leni
+ leni
- 1;
3010 if (nargs
< 0) return build_string ("");
3012 SAFE_ALLOCA_LISP (args
, nargs
);
3015 mapcar1 (leni
, args
, function
, sequence
);
3018 for (i
= leni
- 1; i
>= 0; i
--)
3019 args
[i
+ i
] = args
[i
];
3021 for (i
= 1; i
< nargs
; i
+= 2)
3022 args
[i
] = separator
;
3024 ret
= Fconcat (nargs
, args
);
3025 SAFE_FREE_LISP (nargs
);
3030 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3031 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3032 The result is a list just as long as SEQUENCE.
3033 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3034 (function
, sequence
)
3035 Lisp_Object function
, sequence
;
3037 register Lisp_Object len
;
3039 register Lisp_Object
*args
;
3043 len
= Flength (sequence
);
3044 leni
= XFASTINT (len
);
3046 SAFE_ALLOCA_LISP (args
, leni
);
3048 mapcar1 (leni
, args
, function
, sequence
);
3050 ret
= Flist (leni
, args
);
3051 SAFE_FREE_LISP (leni
);
3056 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3057 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3058 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3059 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3060 (function
, sequence
)
3061 Lisp_Object function
, sequence
;
3065 leni
= XFASTINT (Flength (sequence
));
3066 mapcar1 (leni
, 0, function
, sequence
);
3071 /* Anything that calls this function must protect from GC! */
3073 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3074 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3075 Takes one argument, which is the string to display to ask the question.
3076 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3077 No confirmation of the answer is requested; a single character is enough.
3078 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3079 the bindings in `query-replace-map'; see the documentation of that variable
3080 for more information. In this case, the useful bindings are `act', `skip',
3081 `recenter', and `quit'.\)
3083 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3084 is nil and `use-dialog-box' is non-nil. */)
3088 register Lisp_Object obj
, key
, def
, map
;
3089 register int answer
;
3090 Lisp_Object xprompt
;
3091 Lisp_Object args
[2];
3092 struct gcpro gcpro1
, gcpro2
;
3093 int count
= SPECPDL_INDEX ();
3095 specbind (Qcursor_in_echo_area
, Qt
);
3097 map
= Fsymbol_value (intern ("query-replace-map"));
3099 CHECK_STRING (prompt
);
3101 GCPRO2 (prompt
, xprompt
);
3103 #ifdef HAVE_X_WINDOWS
3104 if (display_hourglass_p
)
3105 cancel_hourglass ();
3112 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3116 Lisp_Object pane
, menu
;
3117 redisplay_preserve_echo_area (3);
3118 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3119 Fcons (Fcons (build_string ("No"), Qnil
),
3121 menu
= Fcons (prompt
, pane
);
3122 obj
= Fx_popup_dialog (Qt
, menu
);
3123 answer
= !NILP (obj
);
3126 #endif /* HAVE_MENUS */
3127 cursor_in_echo_area
= 1;
3128 choose_minibuf_frame ();
3131 Lisp_Object pargs
[3];
3133 /* Colorize prompt according to `minibuffer-prompt' face. */
3134 pargs
[0] = build_string ("%s(y or n) ");
3135 pargs
[1] = intern ("face");
3136 pargs
[2] = intern ("minibuffer-prompt");
3137 args
[0] = Fpropertize (3, pargs
);
3142 if (minibuffer_auto_raise
)
3144 Lisp_Object mini_frame
;
3146 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3148 Fraise_frame (mini_frame
);
3151 obj
= read_filtered_event (1, 0, 0, 0);
3152 cursor_in_echo_area
= 0;
3153 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3156 key
= Fmake_vector (make_number (1), obj
);
3157 def
= Flookup_key (map
, key
, Qt
);
3159 if (EQ (def
, intern ("skip")))
3164 else if (EQ (def
, intern ("act")))
3169 else if (EQ (def
, intern ("recenter")))
3175 else if (EQ (def
, intern ("quit")))
3177 /* We want to exit this command for exit-prefix,
3178 and this is the only way to do it. */
3179 else if (EQ (def
, intern ("exit-prefix")))
3184 /* If we don't clear this, then the next call to read_char will
3185 return quit_char again, and we'll enter an infinite loop. */
3190 if (EQ (xprompt
, prompt
))
3192 args
[0] = build_string ("Please answer y or n. ");
3194 xprompt
= Fconcat (2, args
);
3199 if (! noninteractive
)
3201 cursor_in_echo_area
= -1;
3202 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3206 unbind_to (count
, Qnil
);
3207 return answer
? Qt
: Qnil
;
3210 /* This is how C code calls `yes-or-no-p' and allows the user
3213 Anything that calls this function must protect from GC! */
3216 do_yes_or_no_p (prompt
)
3219 return call1 (intern ("yes-or-no-p"), prompt
);
3222 /* Anything that calls this function must protect from GC! */
3224 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3225 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3226 Takes one argument, which is the string to display to ask the question.
3227 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3228 The user must confirm the answer with RET,
3229 and can edit it until it has been confirmed.
3231 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3232 is nil, and `use-dialog-box' is non-nil. */)
3236 register Lisp_Object ans
;
3237 Lisp_Object args
[2];
3238 struct gcpro gcpro1
;
3240 CHECK_STRING (prompt
);
3243 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3247 Lisp_Object pane
, menu
, obj
;
3248 redisplay_preserve_echo_area (4);
3249 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3250 Fcons (Fcons (build_string ("No"), Qnil
),
3253 menu
= Fcons (prompt
, pane
);
3254 obj
= Fx_popup_dialog (Qt
, menu
);
3258 #endif /* HAVE_MENUS */
3261 args
[1] = build_string ("(yes or no) ");
3262 prompt
= Fconcat (2, args
);
3268 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3269 Qyes_or_no_p_history
, Qnil
,
3271 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3276 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3284 message ("Please answer yes or no.");
3285 Fsleep_for (make_number (2), Qnil
);
3289 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3290 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3292 Each of the three load averages is multiplied by 100, then converted
3295 When USE-FLOATS is non-nil, floats will be used instead of integers.
3296 These floats are not multiplied by 100.
3298 If the 5-minute or 15-minute load averages are not available, return a
3299 shortened list, containing only those averages which are available.
3301 An error is thrown if the load average can't be obtained. In some
3302 cases making it work would require Emacs being installed setuid or
3303 setgid so that it can read kernel information, and that usually isn't
3306 Lisp_Object use_floats
;
3309 int loads
= getloadavg (load_ave
, 3);
3310 Lisp_Object ret
= Qnil
;
3313 error ("load-average not implemented for this operating system");
3317 Lisp_Object load
= (NILP (use_floats
) ?
3318 make_number ((int) (100.0 * load_ave
[loads
]))
3319 : make_float (load_ave
[loads
]));
3320 ret
= Fcons (load
, ret
);
3326 Lisp_Object Vfeatures
, Qsubfeatures
;
3327 extern Lisp_Object Vafter_load_alist
;
3329 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3330 doc
: /* Returns t if FEATURE is present in this Emacs.
3332 Use this to conditionalize execution of lisp code based on the
3333 presence or absence of emacs or environment extensions.
3334 Use `provide' to declare that a feature is available. This function
3335 looks at the value of the variable `features'. The optional argument
3336 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3337 (feature
, subfeature
)
3338 Lisp_Object feature
, subfeature
;
3340 register Lisp_Object tem
;
3341 CHECK_SYMBOL (feature
);
3342 tem
= Fmemq (feature
, Vfeatures
);
3343 if (!NILP (tem
) && !NILP (subfeature
))
3344 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3345 return (NILP (tem
)) ? Qnil
: Qt
;
3348 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3349 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3350 The optional argument SUBFEATURES should be a list of symbols listing
3351 particular subfeatures supported in this version of FEATURE. */)
3352 (feature
, subfeatures
)
3353 Lisp_Object feature
, subfeatures
;
3355 register Lisp_Object tem
;
3356 CHECK_SYMBOL (feature
);
3357 CHECK_LIST (subfeatures
);
3358 if (!NILP (Vautoload_queue
))
3359 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3360 tem
= Fmemq (feature
, Vfeatures
);
3362 Vfeatures
= Fcons (feature
, Vfeatures
);
3363 if (!NILP (subfeatures
))
3364 Fput (feature
, Qsubfeatures
, subfeatures
);
3365 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3367 /* Run any load-hooks for this file. */
3368 tem
= Fassq (feature
, Vafter_load_alist
);
3370 Fprogn (XCDR (tem
));
3375 /* `require' and its subroutines. */
3377 /* List of features currently being require'd, innermost first. */
3379 Lisp_Object require_nesting_list
;
3382 require_unwind (old_value
)
3383 Lisp_Object old_value
;
3385 return require_nesting_list
= old_value
;
3388 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3389 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3390 If FEATURE is not a member of the list `features', then the feature
3391 is not loaded; so load the file FILENAME.
3392 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3393 and `load' will try to load this name appended with the suffix `.elc' or
3394 `.el', in that order. The name without appended suffix will not be used.
3395 If the optional third argument NOERROR is non-nil,
3396 then return nil if the file is not found instead of signaling an error.
3397 Normally the return value is FEATURE.
3398 The normal messages at start and end of loading FILENAME are suppressed. */)
3399 (feature
, filename
, noerror
)
3400 Lisp_Object feature
, filename
, noerror
;
3402 register Lisp_Object tem
;
3403 struct gcpro gcpro1
, gcpro2
;
3405 CHECK_SYMBOL (feature
);
3407 tem
= Fmemq (feature
, Vfeatures
);
3411 int count
= SPECPDL_INDEX ();
3414 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3416 /* This is to make sure that loadup.el gives a clear picture
3417 of what files are preloaded and when. */
3418 if (! NILP (Vpurify_flag
))
3419 error ("(require %s) while preparing to dump",
3420 SDATA (SYMBOL_NAME (feature
)));
3422 /* A certain amount of recursive `require' is legitimate,
3423 but if we require the same feature recursively 3 times,
3425 tem
= require_nesting_list
;
3426 while (! NILP (tem
))
3428 if (! NILP (Fequal (feature
, XCAR (tem
))))
3433 error ("Recursive `require' for feature `%s'",
3434 SDATA (SYMBOL_NAME (feature
)));
3436 /* Update the list for any nested `require's that occur. */
3437 record_unwind_protect (require_unwind
, require_nesting_list
);
3438 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3440 /* Value saved here is to be restored into Vautoload_queue */
3441 record_unwind_protect (un_autoload
, Vautoload_queue
);
3442 Vautoload_queue
= Qt
;
3444 /* Load the file. */
3445 GCPRO2 (feature
, filename
);
3446 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3447 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3450 /* If load failed entirely, return nil. */
3452 return unbind_to (count
, Qnil
);
3454 tem
= Fmemq (feature
, Vfeatures
);
3456 error ("Required feature `%s' was not provided",
3457 SDATA (SYMBOL_NAME (feature
)));
3459 /* Once loading finishes, don't undo it. */
3460 Vautoload_queue
= Qt
;
3461 feature
= unbind_to (count
, feature
);
3467 /* Primitives for work of the "widget" library.
3468 In an ideal world, this section would not have been necessary.
3469 However, lisp function calls being as slow as they are, it turns
3470 out that some functions in the widget library (wid-edit.el) are the
3471 bottleneck of Widget operation. Here is their translation to C,
3472 for the sole reason of efficiency. */
3474 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3475 doc
: /* Return non-nil if PLIST has the property PROP.
3476 PLIST is a property list, which is a list of the form
3477 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3478 Unlike `plist-get', this allows you to distinguish between a missing
3479 property and a property with the value nil.
3480 The value is actually the tail of PLIST whose car is PROP. */)
3482 Lisp_Object plist
, prop
;
3484 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3487 plist
= XCDR (plist
);
3488 plist
= CDR (plist
);
3493 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3494 doc
: /* In WIDGET, set PROPERTY to VALUE.
3495 The value can later be retrieved with `widget-get'. */)
3496 (widget
, property
, value
)
3497 Lisp_Object widget
, property
, value
;
3499 CHECK_CONS (widget
);
3500 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3504 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3505 doc
: /* In WIDGET, get the value of PROPERTY.
3506 The value could either be specified when the widget was created, or
3507 later with `widget-put'. */)
3509 Lisp_Object widget
, property
;
3517 CHECK_CONS (widget
);
3518 tmp
= Fplist_member (XCDR (widget
), property
);
3524 tmp
= XCAR (widget
);
3527 widget
= Fget (tmp
, Qwidget_type
);
3531 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3532 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3533 ARGS are passed as extra arguments to the function.
3534 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3539 /* This function can GC. */
3540 Lisp_Object newargs
[3];
3541 struct gcpro gcpro1
, gcpro2
;
3544 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3545 newargs
[1] = args
[0];
3546 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3547 GCPRO2 (newargs
[0], newargs
[2]);
3548 result
= Fapply (3, newargs
);
3553 #ifdef HAVE_LANGINFO_CODESET
3554 #include <langinfo.h>
3557 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3558 doc
: /* Access locale data ITEM for the current C locale, if available.
3559 ITEM should be one of the following:
3561 `codeset', returning the character set as a string (locale item CODESET);
3563 `days', returning a 7-element vector of day names (locale items DAY_n);
3565 `months', returning a 12-element vector of month names (locale items MON_n);
3567 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3568 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3570 If the system can't provide such information through a call to
3571 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3573 See also Info node `(libc)Locales'.
3575 The data read from the system are decoded using `locale-coding-system'. */)
3580 #ifdef HAVE_LANGINFO_CODESET
3582 if (EQ (item
, Qcodeset
))
3584 str
= nl_langinfo (CODESET
);
3585 return build_string (str
);
3588 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3590 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3591 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3593 synchronize_system_time_locale ();
3594 for (i
= 0; i
< 7; i
++)
3596 str
= nl_langinfo (days
[i
]);
3597 val
= make_unibyte_string (str
, strlen (str
));
3598 /* Fixme: Is this coding system necessarily right, even if
3599 it is consistent with CODESET? If not, what to do? */
3600 Faset (v
, make_number (i
),
3601 code_convert_string_norecord (val
, Vlocale_coding_system
,
3608 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3610 struct Lisp_Vector
*p
= allocate_vector (12);
3611 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3612 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3614 synchronize_system_time_locale ();
3615 for (i
= 0; i
< 12; i
++)
3617 str
= nl_langinfo (months
[i
]);
3618 val
= make_unibyte_string (str
, strlen (str
));
3620 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3622 XSETVECTOR (val
, p
);
3626 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3627 but is in the locale files. This could be used by ps-print. */
3629 else if (EQ (item
, Qpaper
))
3631 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3632 make_number (nl_langinfo (PAPER_HEIGHT
)));
3634 #endif /* PAPER_WIDTH */
3635 #endif /* HAVE_LANGINFO_CODESET*/
3639 /* base64 encode/decode functions (RFC 2045).
3640 Based on code from GNU recode. */
3642 #define MIME_LINE_LENGTH 76
3644 #define IS_ASCII(Character) \
3646 #define IS_BASE64(Character) \
3647 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3648 #define IS_BASE64_IGNORABLE(Character) \
3649 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3650 || (Character) == '\f' || (Character) == '\r')
3652 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3653 character or return retval if there are no characters left to
3655 #define READ_QUADRUPLET_BYTE(retval) \
3660 if (nchars_return) \
3661 *nchars_return = nchars; \
3666 while (IS_BASE64_IGNORABLE (c))
3668 /* Table of characters coding the 64 values. */
3669 static char base64_value_to_char
[64] =
3671 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3672 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3673 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3674 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3675 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3676 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3677 '8', '9', '+', '/' /* 60-63 */
3680 /* Table of base64 values for first 128 characters. */
3681 static short base64_char_to_value
[128] =
3683 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3684 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3685 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3686 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3687 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3688 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3689 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3690 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3691 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3692 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3693 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3694 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3695 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3698 /* The following diagram shows the logical steps by which three octets
3699 get transformed into four base64 characters.
3701 .--------. .--------. .--------.
3702 |aaaaaabb| |bbbbcccc| |ccdddddd|
3703 `--------' `--------' `--------'
3705 .--------+--------+--------+--------.
3706 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3707 `--------+--------+--------+--------'
3709 .--------+--------+--------+--------.
3710 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3711 `--------+--------+--------+--------'
3713 The octets are divided into 6 bit chunks, which are then encoded into
3714 base64 characters. */
3717 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3718 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3720 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3722 doc
: /* Base64-encode the region between BEG and END.
3723 Return the length of the encoded text.
3724 Optional third argument NO-LINE-BREAK means do not break long lines
3725 into shorter lines. */)
3726 (beg
, end
, no_line_break
)
3727 Lisp_Object beg
, end
, no_line_break
;
3730 int allength
, length
;
3731 int ibeg
, iend
, encoded_length
;
3735 validate_region (&beg
, &end
);
3737 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3738 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3739 move_gap_both (XFASTINT (beg
), ibeg
);
3741 /* We need to allocate enough room for encoding the text.
3742 We need 33 1/3% more space, plus a newline every 76
3743 characters, and then we round up. */
3744 length
= iend
- ibeg
;
3745 allength
= length
+ length
/3 + 1;
3746 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3748 SAFE_ALLOCA (encoded
, char *, allength
);
3749 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3750 NILP (no_line_break
),
3751 !NILP (current_buffer
->enable_multibyte_characters
));
3752 if (encoded_length
> allength
)
3755 if (encoded_length
< 0)
3757 /* The encoding wasn't possible. */
3758 SAFE_FREE (allength
);
3759 error ("Multibyte character in data for base64 encoding");
3762 /* Now we have encoded the region, so we insert the new contents
3763 and delete the old. (Insert first in order to preserve markers.) */
3764 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3765 insert (encoded
, encoded_length
);
3766 SAFE_FREE (allength
);
3767 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3769 /* If point was outside of the region, restore it exactly; else just
3770 move to the beginning of the region. */
3771 if (old_pos
>= XFASTINT (end
))
3772 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3773 else if (old_pos
> XFASTINT (beg
))
3774 old_pos
= XFASTINT (beg
);
3777 /* We return the length of the encoded text. */
3778 return make_number (encoded_length
);
3781 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3783 doc
: /* Base64-encode STRING and return the result.
3784 Optional second argument NO-LINE-BREAK means do not break long lines
3785 into shorter lines. */)
3786 (string
, no_line_break
)
3787 Lisp_Object string
, no_line_break
;
3789 int allength
, length
, encoded_length
;
3791 Lisp_Object encoded_string
;
3794 CHECK_STRING (string
);
3796 /* We need to allocate enough room for encoding the text.
3797 We need 33 1/3% more space, plus a newline every 76
3798 characters, and then we round up. */
3799 length
= SBYTES (string
);
3800 allength
= length
+ length
/3 + 1;
3801 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3803 /* We need to allocate enough room for decoding the text. */
3804 SAFE_ALLOCA (encoded
, char *, allength
);
3806 encoded_length
= base64_encode_1 (SDATA (string
),
3807 encoded
, length
, NILP (no_line_break
),
3808 STRING_MULTIBYTE (string
));
3809 if (encoded_length
> allength
)
3812 if (encoded_length
< 0)
3814 /* The encoding wasn't possible. */
3815 SAFE_FREE (allength
);
3816 error ("Multibyte character in data for base64 encoding");
3819 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3820 SAFE_FREE (allength
);
3822 return encoded_string
;
3826 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3833 int counter
= 0, i
= 0;
3843 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3851 /* Wrap line every 76 characters. */
3855 if (counter
< MIME_LINE_LENGTH
/ 4)
3864 /* Process first byte of a triplet. */
3866 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3867 value
= (0x03 & c
) << 4;
3869 /* Process second byte of a triplet. */
3873 *e
++ = base64_value_to_char
[value
];
3881 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3889 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3890 value
= (0x0f & c
) << 2;
3892 /* Process third byte of a triplet. */
3896 *e
++ = base64_value_to_char
[value
];
3903 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3911 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3912 *e
++ = base64_value_to_char
[0x3f & c
];
3919 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3921 doc
: /* Base64-decode the region between BEG and END.
3922 Return the length of the decoded text.
3923 If the region can't be decoded, signal an error and don't modify the buffer. */)
3925 Lisp_Object beg
, end
;
3927 int ibeg
, iend
, length
, allength
;
3932 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3935 validate_region (&beg
, &end
);
3937 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3938 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3940 length
= iend
- ibeg
;
3942 /* We need to allocate enough room for decoding the text. If we are
3943 working on a multibyte buffer, each decoded code may occupy at
3945 allength
= multibyte
? length
* 2 : length
;
3946 SAFE_ALLOCA (decoded
, char *, allength
);
3948 move_gap_both (XFASTINT (beg
), ibeg
);
3949 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3950 multibyte
, &inserted_chars
);
3951 if (decoded_length
> allength
)
3954 if (decoded_length
< 0)
3956 /* The decoding wasn't possible. */
3957 SAFE_FREE (allength
);
3958 error ("Invalid base64 data");
3961 /* Now we have decoded the region, so we insert the new contents
3962 and delete the old. (Insert first in order to preserve markers.) */
3963 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3964 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3965 SAFE_FREE (allength
);
3967 /* Delete the original text. */
3968 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3969 iend
+ decoded_length
, 1);
3971 /* If point was outside of the region, restore it exactly; else just
3972 move to the beginning of the region. */
3973 if (old_pos
>= XFASTINT (end
))
3974 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3975 else if (old_pos
> XFASTINT (beg
))
3976 old_pos
= XFASTINT (beg
);
3977 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3979 return make_number (inserted_chars
);
3982 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3984 doc
: /* Base64-decode STRING and return the result. */)
3989 int length
, decoded_length
;
3990 Lisp_Object decoded_string
;
3993 CHECK_STRING (string
);
3995 length
= SBYTES (string
);
3996 /* We need to allocate enough room for decoding the text. */
3997 SAFE_ALLOCA (decoded
, char *, length
);
3999 /* The decoded result should be unibyte. */
4000 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4002 if (decoded_length
> length
)
4004 else if (decoded_length
>= 0)
4005 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4007 decoded_string
= Qnil
;
4010 if (!STRINGP (decoded_string
))
4011 error ("Invalid base64 data");
4013 return decoded_string
;
4016 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4017 MULTIBYTE is nonzero, the decoded result should be in multibyte
4018 form. If NCHARS_RETRUN is not NULL, store the number of produced
4019 characters in *NCHARS_RETURN. */
4022 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4032 unsigned long value
;
4037 /* Process first byte of a quadruplet. */
4039 READ_QUADRUPLET_BYTE (e
-to
);
4043 value
= base64_char_to_value
[c
] << 18;
4045 /* Process second byte of a quadruplet. */
4047 READ_QUADRUPLET_BYTE (-1);
4051 value
|= base64_char_to_value
[c
] << 12;
4053 c
= (unsigned char) (value
>> 16);
4055 e
+= CHAR_STRING (c
, e
);
4060 /* Process third byte of a quadruplet. */
4062 READ_QUADRUPLET_BYTE (-1);
4066 READ_QUADRUPLET_BYTE (-1);
4075 value
|= base64_char_to_value
[c
] << 6;
4077 c
= (unsigned char) (0xff & value
>> 8);
4079 e
+= CHAR_STRING (c
, e
);
4084 /* Process fourth byte of a quadruplet. */
4086 READ_QUADRUPLET_BYTE (-1);
4093 value
|= base64_char_to_value
[c
];
4095 c
= (unsigned char) (0xff & value
);
4097 e
+= CHAR_STRING (c
, e
);
4106 /***********************************************************************
4108 ***** Hash Tables *****
4110 ***********************************************************************/
4112 /* Implemented by gerd@gnu.org. This hash table implementation was
4113 inspired by CMUCL hash tables. */
4117 1. For small tables, association lists are probably faster than
4118 hash tables because they have lower overhead.
4120 For uses of hash tables where the O(1) behavior of table
4121 operations is not a requirement, it might therefore be a good idea
4122 not to hash. Instead, we could just do a linear search in the
4123 key_and_value vector of the hash table. This could be done
4124 if a `:linear-search t' argument is given to make-hash-table. */
4127 /* The list of all weak hash tables. Don't staticpro this one. */
4129 Lisp_Object Vweak_hash_tables
;
4131 /* Various symbols. */
4133 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4134 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4135 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4137 /* Function prototypes. */
4139 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4140 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4141 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4142 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4143 Lisp_Object
, unsigned));
4144 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4145 Lisp_Object
, unsigned));
4146 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4147 unsigned, Lisp_Object
, unsigned));
4148 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4149 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4150 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4151 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4153 static unsigned sxhash_string
P_ ((unsigned char *, int));
4154 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4155 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4156 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4157 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4161 /***********************************************************************
4163 ***********************************************************************/
4165 /* If OBJ is a Lisp hash table, return a pointer to its struct
4166 Lisp_Hash_Table. Otherwise, signal an error. */
4168 static struct Lisp_Hash_Table
*
4169 check_hash_table (obj
)
4172 CHECK_HASH_TABLE (obj
);
4173 return XHASH_TABLE (obj
);
4177 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4181 next_almost_prime (n
)
4194 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4195 which USED[I] is non-zero. If found at index I in ARGS, set
4196 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4197 -1. This function is used to extract a keyword/argument pair from
4198 a DEFUN parameter list. */
4201 get_key_arg (key
, nargs
, args
, used
)
4209 for (i
= 0; i
< nargs
- 1; ++i
)
4210 if (!used
[i
] && EQ (args
[i
], key
))
4225 /* Return a Lisp vector which has the same contents as VEC but has
4226 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4227 vector that are not copied from VEC are set to INIT. */
4230 larger_vector (vec
, new_size
, init
)
4235 struct Lisp_Vector
*v
;
4238 xassert (VECTORP (vec
));
4239 old_size
= XVECTOR (vec
)->size
;
4240 xassert (new_size
>= old_size
);
4242 v
= allocate_vector (new_size
);
4243 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4244 old_size
* sizeof *v
->contents
);
4245 for (i
= old_size
; i
< new_size
; ++i
)
4246 v
->contents
[i
] = init
;
4247 XSETVECTOR (vec
, v
);
4252 /***********************************************************************
4254 ***********************************************************************/
4256 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4257 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4258 KEY2 are the same. */
4261 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4262 struct Lisp_Hash_Table
*h
;
4263 Lisp_Object key1
, key2
;
4264 unsigned hash1
, hash2
;
4266 return (FLOATP (key1
)
4268 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4272 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4273 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4274 KEY2 are the same. */
4277 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4278 struct Lisp_Hash_Table
*h
;
4279 Lisp_Object key1
, key2
;
4280 unsigned hash1
, hash2
;
4282 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4286 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4287 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4288 if KEY1 and KEY2 are the same. */
4291 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4292 struct Lisp_Hash_Table
*h
;
4293 Lisp_Object key1
, key2
;
4294 unsigned hash1
, hash2
;
4298 Lisp_Object args
[3];
4300 args
[0] = h
->user_cmp_function
;
4303 return !NILP (Ffuncall (3, args
));
4310 /* Value is a hash code for KEY for use in hash table H which uses
4311 `eq' to compare keys. The hash code returned is guaranteed to fit
4312 in a Lisp integer. */
4316 struct Lisp_Hash_Table
*h
;
4319 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4320 xassert ((hash
& ~INTMASK
) == 0);
4325 /* Value is a hash code for KEY for use in hash table H which uses
4326 `eql' to compare keys. The hash code returned is guaranteed to fit
4327 in a Lisp integer. */
4331 struct Lisp_Hash_Table
*h
;
4336 hash
= sxhash (key
, 0);
4338 hash
= XUINT (key
) ^ XGCTYPE (key
);
4339 xassert ((hash
& ~INTMASK
) == 0);
4344 /* Value is a hash code for KEY for use in hash table H which uses
4345 `equal' to compare keys. The hash code returned is guaranteed to fit
4346 in a Lisp integer. */
4349 hashfn_equal (h
, key
)
4350 struct Lisp_Hash_Table
*h
;
4353 unsigned hash
= sxhash (key
, 0);
4354 xassert ((hash
& ~INTMASK
) == 0);
4359 /* Value is a hash code for KEY for use in hash table H which uses as
4360 user-defined function to compare keys. The hash code returned is
4361 guaranteed to fit in a Lisp integer. */
4364 hashfn_user_defined (h
, key
)
4365 struct Lisp_Hash_Table
*h
;
4368 Lisp_Object args
[2], hash
;
4370 args
[0] = h
->user_hash_function
;
4372 hash
= Ffuncall (2, args
);
4373 if (!INTEGERP (hash
))
4375 list2 (build_string ("Invalid hash code returned from \
4376 user-supplied hash function"),
4378 return XUINT (hash
);
4382 /* Create and initialize a new hash table.
4384 TEST specifies the test the hash table will use to compare keys.
4385 It must be either one of the predefined tests `eq', `eql' or
4386 `equal' or a symbol denoting a user-defined test named TEST with
4387 test and hash functions USER_TEST and USER_HASH.
4389 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4391 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4392 new size when it becomes full is computed by adding REHASH_SIZE to
4393 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4394 table's new size is computed by multiplying its old size with
4397 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4398 be resized when the ratio of (number of entries in the table) /
4399 (table size) is >= REHASH_THRESHOLD.
4401 WEAK specifies the weakness of the table. If non-nil, it must be
4402 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4405 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4406 user_test
, user_hash
)
4407 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4408 Lisp_Object user_test
, user_hash
;
4410 struct Lisp_Hash_Table
*h
;
4412 int index_size
, i
, sz
;
4414 /* Preconditions. */
4415 xassert (SYMBOLP (test
));
4416 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4417 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4418 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4419 xassert (FLOATP (rehash_threshold
)
4420 && XFLOATINT (rehash_threshold
) > 0
4421 && XFLOATINT (rehash_threshold
) <= 1.0);
4423 if (XFASTINT (size
) == 0)
4424 size
= make_number (1);
4426 /* Allocate a table and initialize it. */
4427 h
= allocate_hash_table ();
4429 /* Initialize hash table slots. */
4430 sz
= XFASTINT (size
);
4433 if (EQ (test
, Qeql
))
4435 h
->cmpfn
= cmpfn_eql
;
4436 h
->hashfn
= hashfn_eql
;
4438 else if (EQ (test
, Qeq
))
4441 h
->hashfn
= hashfn_eq
;
4443 else if (EQ (test
, Qequal
))
4445 h
->cmpfn
= cmpfn_equal
;
4446 h
->hashfn
= hashfn_equal
;
4450 h
->user_cmp_function
= user_test
;
4451 h
->user_hash_function
= user_hash
;
4452 h
->cmpfn
= cmpfn_user_defined
;
4453 h
->hashfn
= hashfn_user_defined
;
4457 h
->rehash_threshold
= rehash_threshold
;
4458 h
->rehash_size
= rehash_size
;
4459 h
->count
= make_number (0);
4460 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4461 h
->hash
= Fmake_vector (size
, Qnil
);
4462 h
->next
= Fmake_vector (size
, Qnil
);
4463 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4464 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4465 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4467 /* Set up the free list. */
4468 for (i
= 0; i
< sz
- 1; ++i
)
4469 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4470 h
->next_free
= make_number (0);
4472 XSET_HASH_TABLE (table
, h
);
4473 xassert (HASH_TABLE_P (table
));
4474 xassert (XHASH_TABLE (table
) == h
);
4476 /* Maybe add this hash table to the list of all weak hash tables. */
4478 h
->next_weak
= Qnil
;
4481 h
->next_weak
= Vweak_hash_tables
;
4482 Vweak_hash_tables
= table
;
4489 /* Return a copy of hash table H1. Keys and values are not copied,
4490 only the table itself is. */
4493 copy_hash_table (h1
)
4494 struct Lisp_Hash_Table
*h1
;
4497 struct Lisp_Hash_Table
*h2
;
4498 struct Lisp_Vector
*next
;
4500 h2
= allocate_hash_table ();
4501 next
= h2
->vec_next
;
4502 bcopy (h1
, h2
, sizeof *h2
);
4503 h2
->vec_next
= next
;
4504 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4505 h2
->hash
= Fcopy_sequence (h1
->hash
);
4506 h2
->next
= Fcopy_sequence (h1
->next
);
4507 h2
->index
= Fcopy_sequence (h1
->index
);
4508 XSET_HASH_TABLE (table
, h2
);
4510 /* Maybe add this hash table to the list of all weak hash tables. */
4511 if (!NILP (h2
->weak
))
4513 h2
->next_weak
= Vweak_hash_tables
;
4514 Vweak_hash_tables
= table
;
4521 /* Resize hash table H if it's too full. If H cannot be resized
4522 because it's already too large, throw an error. */
4525 maybe_resize_hash_table (h
)
4526 struct Lisp_Hash_Table
*h
;
4528 if (NILP (h
->next_free
))
4530 int old_size
= HASH_TABLE_SIZE (h
);
4531 int i
, new_size
, index_size
;
4533 if (INTEGERP (h
->rehash_size
))
4534 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4536 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4537 new_size
= max (old_size
+ 1, new_size
);
4538 index_size
= next_almost_prime ((int)
4540 / XFLOATINT (h
->rehash_threshold
)));
4541 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4542 error ("Hash table too large to resize");
4544 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4545 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4546 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4547 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4549 /* Update the free list. Do it so that new entries are added at
4550 the end of the free list. This makes some operations like
4552 for (i
= old_size
; i
< new_size
- 1; ++i
)
4553 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4555 if (!NILP (h
->next_free
))
4557 Lisp_Object last
, next
;
4559 last
= h
->next_free
;
4560 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4564 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4567 XSETFASTINT (h
->next_free
, old_size
);
4570 for (i
= 0; i
< old_size
; ++i
)
4571 if (!NILP (HASH_HASH (h
, i
)))
4573 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4574 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4575 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4576 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4582 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4583 the hash code of KEY. Value is the index of the entry in H
4584 matching KEY, or -1 if not found. */
4587 hash_lookup (h
, key
, hash
)
4588 struct Lisp_Hash_Table
*h
;
4593 int start_of_bucket
;
4596 hash_code
= h
->hashfn (h
, key
);
4600 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4601 idx
= HASH_INDEX (h
, start_of_bucket
);
4603 /* We need not gcpro idx since it's either an integer or nil. */
4606 int i
= XFASTINT (idx
);
4607 if (EQ (key
, HASH_KEY (h
, i
))
4609 && h
->cmpfn (h
, key
, hash_code
,
4610 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4612 idx
= HASH_NEXT (h
, i
);
4615 return NILP (idx
) ? -1 : XFASTINT (idx
);
4619 /* Put an entry into hash table H that associates KEY with VALUE.
4620 HASH is a previously computed hash code of KEY.
4621 Value is the index of the entry in H matching KEY. */
4624 hash_put (h
, key
, value
, hash
)
4625 struct Lisp_Hash_Table
*h
;
4626 Lisp_Object key
, value
;
4629 int start_of_bucket
, i
;
4631 xassert ((hash
& ~INTMASK
) == 0);
4633 /* Increment count after resizing because resizing may fail. */
4634 maybe_resize_hash_table (h
);
4635 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4637 /* Store key/value in the key_and_value vector. */
4638 i
= XFASTINT (h
->next_free
);
4639 h
->next_free
= HASH_NEXT (h
, i
);
4640 HASH_KEY (h
, i
) = key
;
4641 HASH_VALUE (h
, i
) = value
;
4643 /* Remember its hash code. */
4644 HASH_HASH (h
, i
) = make_number (hash
);
4646 /* Add new entry to its collision chain. */
4647 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4648 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4649 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4654 /* Remove the entry matching KEY from hash table H, if there is one. */
4657 hash_remove (h
, key
)
4658 struct Lisp_Hash_Table
*h
;
4662 int start_of_bucket
;
4663 Lisp_Object idx
, prev
;
4665 hash_code
= h
->hashfn (h
, key
);
4666 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4667 idx
= HASH_INDEX (h
, start_of_bucket
);
4670 /* We need not gcpro idx, prev since they're either integers or nil. */
4673 int i
= XFASTINT (idx
);
4675 if (EQ (key
, HASH_KEY (h
, i
))
4677 && h
->cmpfn (h
, key
, hash_code
,
4678 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4680 /* Take entry out of collision chain. */
4682 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4684 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4686 /* Clear slots in key_and_value and add the slots to
4688 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4689 HASH_NEXT (h
, i
) = h
->next_free
;
4690 h
->next_free
= make_number (i
);
4691 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4692 xassert (XINT (h
->count
) >= 0);
4698 idx
= HASH_NEXT (h
, i
);
4704 /* Clear hash table H. */
4708 struct Lisp_Hash_Table
*h
;
4710 if (XFASTINT (h
->count
) > 0)
4712 int i
, size
= HASH_TABLE_SIZE (h
);
4714 for (i
= 0; i
< size
; ++i
)
4716 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4717 HASH_KEY (h
, i
) = Qnil
;
4718 HASH_VALUE (h
, i
) = Qnil
;
4719 HASH_HASH (h
, i
) = Qnil
;
4722 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4723 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4725 h
->next_free
= make_number (0);
4726 h
->count
= make_number (0);
4732 /************************************************************************
4734 ************************************************************************/
4736 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4737 entries from the table that don't survive the current GC.
4738 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4739 non-zero if anything was marked. */
4742 sweep_weak_table (h
, remove_entries_p
)
4743 struct Lisp_Hash_Table
*h
;
4744 int remove_entries_p
;
4746 int bucket
, n
, marked
;
4748 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4751 for (bucket
= 0; bucket
< n
; ++bucket
)
4753 Lisp_Object idx
, next
, prev
;
4755 /* Follow collision chain, removing entries that
4756 don't survive this garbage collection. */
4758 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4760 int i
= XFASTINT (idx
);
4761 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4762 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4765 if (EQ (h
->weak
, Qkey
))
4766 remove_p
= !key_known_to_survive_p
;
4767 else if (EQ (h
->weak
, Qvalue
))
4768 remove_p
= !value_known_to_survive_p
;
4769 else if (EQ (h
->weak
, Qkey_or_value
))
4770 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4771 else if (EQ (h
->weak
, Qkey_and_value
))
4772 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4776 next
= HASH_NEXT (h
, i
);
4778 if (remove_entries_p
)
4782 /* Take out of collision chain. */
4784 HASH_INDEX (h
, bucket
) = next
;
4786 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4788 /* Add to free list. */
4789 HASH_NEXT (h
, i
) = h
->next_free
;
4792 /* Clear key, value, and hash. */
4793 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4794 HASH_HASH (h
, i
) = Qnil
;
4796 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4803 /* Make sure key and value survive. */
4804 if (!key_known_to_survive_p
)
4806 mark_object (HASH_KEY (h
, i
));
4810 if (!value_known_to_survive_p
)
4812 mark_object (HASH_VALUE (h
, i
));
4823 /* Remove elements from weak hash tables that don't survive the
4824 current garbage collection. Remove weak tables that don't survive
4825 from Vweak_hash_tables. Called from gc_sweep. */
4828 sweep_weak_hash_tables ()
4830 Lisp_Object table
, used
, next
;
4831 struct Lisp_Hash_Table
*h
;
4834 /* Mark all keys and values that are in use. Keep on marking until
4835 there is no more change. This is necessary for cases like
4836 value-weak table A containing an entry X -> Y, where Y is used in a
4837 key-weak table B, Z -> Y. If B comes after A in the list of weak
4838 tables, X -> Y might be removed from A, although when looking at B
4839 one finds that it shouldn't. */
4843 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4845 h
= XHASH_TABLE (table
);
4846 if (h
->size
& ARRAY_MARK_FLAG
)
4847 marked
|= sweep_weak_table (h
, 0);
4852 /* Remove tables and entries that aren't used. */
4853 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4855 h
= XHASH_TABLE (table
);
4856 next
= h
->next_weak
;
4858 if (h
->size
& ARRAY_MARK_FLAG
)
4860 /* TABLE is marked as used. Sweep its contents. */
4861 if (XFASTINT (h
->count
) > 0)
4862 sweep_weak_table (h
, 1);
4864 /* Add table to the list of used weak hash tables. */
4865 h
->next_weak
= used
;
4870 Vweak_hash_tables
= used
;
4875 /***********************************************************************
4876 Hash Code Computation
4877 ***********************************************************************/
4879 /* Maximum depth up to which to dive into Lisp structures. */
4881 #define SXHASH_MAX_DEPTH 3
4883 /* Maximum length up to which to take list and vector elements into
4886 #define SXHASH_MAX_LEN 7
4888 /* Combine two integers X and Y for hashing. */
4890 #define SXHASH_COMBINE(X, Y) \
4891 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4895 /* Return a hash for string PTR which has length LEN. The hash
4896 code returned is guaranteed to fit in a Lisp integer. */
4899 sxhash_string (ptr
, len
)
4903 unsigned char *p
= ptr
;
4904 unsigned char *end
= p
+ len
;
4913 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4916 return hash
& INTMASK
;
4920 /* Return a hash for list LIST. DEPTH is the current depth in the
4921 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4924 sxhash_list (list
, depth
)
4931 if (depth
< SXHASH_MAX_DEPTH
)
4933 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4934 list
= XCDR (list
), ++i
)
4936 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4937 hash
= SXHASH_COMBINE (hash
, hash2
);
4944 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4945 the Lisp structure. */
4948 sxhash_vector (vec
, depth
)
4952 unsigned hash
= XVECTOR (vec
)->size
;
4955 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4956 for (i
= 0; i
< n
; ++i
)
4958 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4959 hash
= SXHASH_COMBINE (hash
, hash2
);
4966 /* Return a hash for bool-vector VECTOR. */
4969 sxhash_bool_vector (vec
)
4972 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4975 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4976 for (i
= 0; i
< n
; ++i
)
4977 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4983 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4984 structure. Value is an unsigned integer clipped to INTMASK. */
4993 if (depth
> SXHASH_MAX_DEPTH
)
4996 switch (XTYPE (obj
))
5003 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
5004 SCHARS (SYMBOL_NAME (obj
)));
5012 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5015 /* This can be everything from a vector to an overlay. */
5016 case Lisp_Vectorlike
:
5018 /* According to the CL HyperSpec, two arrays are equal only if
5019 they are `eq', except for strings and bit-vectors. In
5020 Emacs, this works differently. We have to compare element
5022 hash
= sxhash_vector (obj
, depth
);
5023 else if (BOOL_VECTOR_P (obj
))
5024 hash
= sxhash_bool_vector (obj
);
5026 /* Others are `equal' if they are `eq', so let's take their
5032 hash
= sxhash_list (obj
, depth
);
5037 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5038 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5039 for (hash
= 0; p
< e
; ++p
)
5040 hash
= SXHASH_COMBINE (hash
, *p
);
5048 return hash
& INTMASK
;
5053 /***********************************************************************
5055 ***********************************************************************/
5058 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5059 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5063 unsigned hash
= sxhash (obj
, 0);;
5064 return make_number (hash
);
5068 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5069 doc
: /* Create and return a new hash table.
5071 Arguments are specified as keyword/argument pairs. The following
5072 arguments are defined:
5074 :test TEST -- TEST must be a symbol that specifies how to compare
5075 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5076 `equal'. User-supplied test and hash functions can be specified via
5077 `define-hash-table-test'.
5079 :size SIZE -- A hint as to how many elements will be put in the table.
5082 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5083 fills up. If REHASH-SIZE is an integer, add that many space. If it
5084 is a float, it must be > 1.0, and the new size is computed by
5085 multiplying the old size with that factor. Default is 1.5.
5087 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5088 Resize the hash table when ratio of the number of entries in the
5089 table. Default is 0.8.
5091 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5092 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5093 returned is a weak table. Key/value pairs are removed from a weak
5094 hash table when there are no non-weak references pointing to their
5095 key, value, one of key or value, or both key and value, depending on
5096 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5099 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5104 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5105 Lisp_Object user_test
, user_hash
;
5109 /* The vector `used' is used to keep track of arguments that
5110 have been consumed. */
5111 used
= (char *) alloca (nargs
* sizeof *used
);
5112 bzero (used
, nargs
* sizeof *used
);
5114 /* See if there's a `:test TEST' among the arguments. */
5115 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5116 test
= i
< 0 ? Qeql
: args
[i
];
5117 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5119 /* See if it is a user-defined test. */
5122 prop
= Fget (test
, Qhash_table_test
);
5123 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5124 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5126 user_test
= XCAR (prop
);
5127 user_hash
= XCAR (XCDR (prop
));
5130 user_test
= user_hash
= Qnil
;
5132 /* See if there's a `:size SIZE' argument. */
5133 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5134 size
= i
< 0 ? Qnil
: args
[i
];
5136 size
= make_number (DEFAULT_HASH_SIZE
);
5137 else if (!INTEGERP (size
) || XINT (size
) < 0)
5139 list2 (build_string ("Invalid hash table size"),
5142 /* Look for `:rehash-size SIZE'. */
5143 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5144 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5145 if (!NUMBERP (rehash_size
)
5146 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5147 || XFLOATINT (rehash_size
) <= 1.0)
5149 list2 (build_string ("Invalid hash table rehash size"),
5152 /* Look for `:rehash-threshold THRESHOLD'. */
5153 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5154 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5155 if (!FLOATP (rehash_threshold
)
5156 || XFLOATINT (rehash_threshold
) <= 0.0
5157 || XFLOATINT (rehash_threshold
) > 1.0)
5159 list2 (build_string ("Invalid hash table rehash threshold"),
5162 /* Look for `:weakness WEAK'. */
5163 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5164 weak
= i
< 0 ? Qnil
: args
[i
];
5166 weak
= Qkey_and_value
;
5169 && !EQ (weak
, Qvalue
)
5170 && !EQ (weak
, Qkey_or_value
)
5171 && !EQ (weak
, Qkey_and_value
))
5172 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5175 /* Now, all args should have been used up, or there's a problem. */
5176 for (i
= 0; i
< nargs
; ++i
)
5179 list2 (build_string ("Invalid argument list"), args
[i
]));
5181 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5182 user_test
, user_hash
);
5186 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5187 doc
: /* Return a copy of hash table TABLE. */)
5191 return copy_hash_table (check_hash_table (table
));
5195 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5196 doc
: /* Return the number of elements in TABLE. */)
5200 return check_hash_table (table
)->count
;
5204 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5205 Shash_table_rehash_size
, 1, 1, 0,
5206 doc
: /* Return the current rehash size of TABLE. */)
5210 return check_hash_table (table
)->rehash_size
;
5214 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5215 Shash_table_rehash_threshold
, 1, 1, 0,
5216 doc
: /* Return the current rehash threshold of TABLE. */)
5220 return check_hash_table (table
)->rehash_threshold
;
5224 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5225 doc
: /* Return the size of TABLE.
5226 The size can be used as an argument to `make-hash-table' to create
5227 a hash table than can hold as many elements of TABLE holds
5228 without need for resizing. */)
5232 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5233 return make_number (HASH_TABLE_SIZE (h
));
5237 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5238 doc
: /* Return the test TABLE uses. */)
5242 return check_hash_table (table
)->test
;
5246 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5248 doc
: /* Return the weakness of TABLE. */)
5252 return check_hash_table (table
)->weak
;
5256 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5257 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5261 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5265 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5266 doc
: /* Clear hash table TABLE. */)
5270 hash_clear (check_hash_table (table
));
5275 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5276 doc
: /* Look up KEY in TABLE and return its associated value.
5277 If KEY is not found, return DFLT which defaults to nil. */)
5279 Lisp_Object key
, table
, dflt
;
5281 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5282 int i
= hash_lookup (h
, key
, NULL
);
5283 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5287 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5288 doc
: /* Associate KEY with VALUE in hash table TABLE.
5289 If KEY is already present in table, replace its current value with
5292 Lisp_Object key
, value
, table
;
5294 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5298 i
= hash_lookup (h
, key
, &hash
);
5300 HASH_VALUE (h
, i
) = value
;
5302 hash_put (h
, key
, value
, hash
);
5308 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5309 doc
: /* Remove KEY from TABLE. */)
5311 Lisp_Object key
, table
;
5313 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5314 hash_remove (h
, key
);
5319 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5320 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5321 FUNCTION is called with 2 arguments KEY and VALUE. */)
5323 Lisp_Object function
, table
;
5325 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5326 Lisp_Object args
[3];
5329 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5330 if (!NILP (HASH_HASH (h
, i
)))
5333 args
[1] = HASH_KEY (h
, i
);
5334 args
[2] = HASH_VALUE (h
, i
);
5342 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5343 Sdefine_hash_table_test
, 3, 3, 0,
5344 doc
: /* Define a new hash table test with name NAME, a symbol.
5346 In hash tables created with NAME specified as test, use TEST to
5347 compare keys, and HASH for computing hash codes of keys.
5349 TEST must be a function taking two arguments and returning non-nil if
5350 both arguments are the same. HASH must be a function taking one
5351 argument and return an integer that is the hash code of the argument.
5352 Hash code computation should use the whole value range of integers,
5353 including negative integers. */)
5355 Lisp_Object name
, test
, hash
;
5357 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5362 /************************************************************************
5364 ************************************************************************/
5369 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5370 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5372 A message digest is a cryptographic checksum of a document, and the
5373 algorithm to calculate it is defined in RFC 1321.
5375 The two optional arguments START and END are character positions
5376 specifying for which part of OBJECT the message digest should be
5377 computed. If nil or omitted, the digest is computed for the whole
5380 The MD5 message digest is computed from the result of encoding the
5381 text in a coding system, not directly from the internal Emacs form of
5382 the text. The optional fourth argument CODING-SYSTEM specifies which
5383 coding system to encode the text with. It should be the same coding
5384 system that you used or will use when actually writing the text into a
5387 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5388 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5389 system would be chosen by default for writing this text into a file.
5391 If OBJECT is a string, the most preferred coding system (see the
5392 command `prefer-coding-system') is used.
5394 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5395 guesswork fails. Normally, an error is signaled in such case. */)
5396 (object
, start
, end
, coding_system
, noerror
)
5397 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5399 unsigned char digest
[16];
5400 unsigned char value
[33];
5404 int start_char
= 0, end_char
= 0;
5405 int start_byte
= 0, end_byte
= 0;
5407 register struct buffer
*bp
;
5410 if (STRINGP (object
))
5412 if (NILP (coding_system
))
5414 /* Decide the coding-system to encode the data with. */
5416 if (STRING_MULTIBYTE (object
))
5417 /* use default, we can't guess correct value */
5418 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5420 coding_system
= Qraw_text
;
5423 if (NILP (Fcoding_system_p (coding_system
)))
5425 /* Invalid coding system. */
5427 if (!NILP (noerror
))
5428 coding_system
= Qraw_text
;
5431 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5434 if (STRING_MULTIBYTE (object
))
5435 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5437 size
= SCHARS (object
);
5438 size_byte
= SBYTES (object
);
5442 CHECK_NUMBER (start
);
5444 start_char
= XINT (start
);
5449 start_byte
= string_char_to_byte (object
, start_char
);
5455 end_byte
= size_byte
;
5461 end_char
= XINT (end
);
5466 end_byte
= string_char_to_byte (object
, end_char
);
5469 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5470 args_out_of_range_3 (object
, make_number (start_char
),
5471 make_number (end_char
));
5475 struct buffer
*prev
= current_buffer
;
5477 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5479 CHECK_BUFFER (object
);
5481 bp
= XBUFFER (object
);
5482 if (bp
!= current_buffer
)
5483 set_buffer_internal (bp
);
5489 CHECK_NUMBER_COERCE_MARKER (start
);
5497 CHECK_NUMBER_COERCE_MARKER (end
);
5502 temp
= b
, b
= e
, e
= temp
;
5504 if (!(BEGV
<= b
&& e
<= ZV
))
5505 args_out_of_range (start
, end
);
5507 if (NILP (coding_system
))
5509 /* Decide the coding-system to encode the data with.
5510 See fileio.c:Fwrite-region */
5512 if (!NILP (Vcoding_system_for_write
))
5513 coding_system
= Vcoding_system_for_write
;
5516 int force_raw_text
= 0;
5518 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5519 if (NILP (coding_system
)
5520 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5522 coding_system
= Qnil
;
5523 if (NILP (current_buffer
->enable_multibyte_characters
))
5527 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5529 /* Check file-coding-system-alist. */
5530 Lisp_Object args
[4], val
;
5532 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5533 args
[3] = Fbuffer_file_name(object
);
5534 val
= Ffind_operation_coding_system (4, args
);
5535 if (CONSP (val
) && !NILP (XCDR (val
)))
5536 coding_system
= XCDR (val
);
5539 if (NILP (coding_system
)
5540 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5542 /* If we still have not decided a coding system, use the
5543 default value of buffer-file-coding-system. */
5544 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5548 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5549 /* Confirm that VAL can surely encode the current region. */
5550 coding_system
= call4 (Vselect_safe_coding_system_function
,
5551 make_number (b
), make_number (e
),
5552 coding_system
, Qnil
);
5555 coding_system
= Qraw_text
;
5558 if (NILP (Fcoding_system_p (coding_system
)))
5560 /* Invalid coding system. */
5562 if (!NILP (noerror
))
5563 coding_system
= Qraw_text
;
5566 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5570 object
= make_buffer_string (b
, e
, 0);
5571 if (prev
!= current_buffer
)
5572 set_buffer_internal (prev
);
5573 /* Discard the unwind protect for recovering the current
5577 if (STRING_MULTIBYTE (object
))
5578 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5581 md5_buffer (SDATA (object
) + start_byte
,
5582 SBYTES (object
) - (size_byte
- end_byte
),
5585 for (i
= 0; i
< 16; i
++)
5586 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5589 return make_string (value
, 32);
5596 /* Hash table stuff. */
5597 Qhash_table_p
= intern ("hash-table-p");
5598 staticpro (&Qhash_table_p
);
5599 Qeq
= intern ("eq");
5601 Qeql
= intern ("eql");
5603 Qequal
= intern ("equal");
5604 staticpro (&Qequal
);
5605 QCtest
= intern (":test");
5606 staticpro (&QCtest
);
5607 QCsize
= intern (":size");
5608 staticpro (&QCsize
);
5609 QCrehash_size
= intern (":rehash-size");
5610 staticpro (&QCrehash_size
);
5611 QCrehash_threshold
= intern (":rehash-threshold");
5612 staticpro (&QCrehash_threshold
);
5613 QCweakness
= intern (":weakness");
5614 staticpro (&QCweakness
);
5615 Qkey
= intern ("key");
5617 Qvalue
= intern ("value");
5618 staticpro (&Qvalue
);
5619 Qhash_table_test
= intern ("hash-table-test");
5620 staticpro (&Qhash_table_test
);
5621 Qkey_or_value
= intern ("key-or-value");
5622 staticpro (&Qkey_or_value
);
5623 Qkey_and_value
= intern ("key-and-value");
5624 staticpro (&Qkey_and_value
);
5627 defsubr (&Smake_hash_table
);
5628 defsubr (&Scopy_hash_table
);
5629 defsubr (&Shash_table_count
);
5630 defsubr (&Shash_table_rehash_size
);
5631 defsubr (&Shash_table_rehash_threshold
);
5632 defsubr (&Shash_table_size
);
5633 defsubr (&Shash_table_test
);
5634 defsubr (&Shash_table_weakness
);
5635 defsubr (&Shash_table_p
);
5636 defsubr (&Sclrhash
);
5637 defsubr (&Sgethash
);
5638 defsubr (&Sputhash
);
5639 defsubr (&Sremhash
);
5640 defsubr (&Smaphash
);
5641 defsubr (&Sdefine_hash_table_test
);
5643 Qstring_lessp
= intern ("string-lessp");
5644 staticpro (&Qstring_lessp
);
5645 Qprovide
= intern ("provide");
5646 staticpro (&Qprovide
);
5647 Qrequire
= intern ("require");
5648 staticpro (&Qrequire
);
5649 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5650 staticpro (&Qyes_or_no_p_history
);
5651 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5652 staticpro (&Qcursor_in_echo_area
);
5653 Qwidget_type
= intern ("widget-type");
5654 staticpro (&Qwidget_type
);
5656 staticpro (&string_char_byte_cache_string
);
5657 string_char_byte_cache_string
= Qnil
;
5659 require_nesting_list
= Qnil
;
5660 staticpro (&require_nesting_list
);
5662 Fset (Qyes_or_no_p_history
, Qnil
);
5664 DEFVAR_LISP ("features", &Vfeatures
,
5665 doc
: /* A list of symbols which are the features of the executing emacs.
5666 Used by `featurep' and `require', and altered by `provide'. */);
5668 Qsubfeatures
= intern ("subfeatures");
5669 staticpro (&Qsubfeatures
);
5671 #ifdef HAVE_LANGINFO_CODESET
5672 Qcodeset
= intern ("codeset");
5673 staticpro (&Qcodeset
);
5674 Qdays
= intern ("days");
5676 Qmonths
= intern ("months");
5677 staticpro (&Qmonths
);
5678 Qpaper
= intern ("paper");
5679 staticpro (&Qpaper
);
5680 #endif /* HAVE_LANGINFO_CODESET */
5682 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5683 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5684 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5685 invoked by mouse clicks and mouse menu items. */);
5688 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5689 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5690 This applies to commands from menus and tool bar buttons. The value of
5691 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5692 used if both `use-dialog-box' and this variable are non-nil. */);
5693 use_file_dialog
= 1;
5695 defsubr (&Sidentity
);
5698 defsubr (&Ssafe_length
);
5699 defsubr (&Sstring_bytes
);
5700 defsubr (&Sstring_equal
);
5701 defsubr (&Scompare_strings
);
5702 defsubr (&Sstring_lessp
);
5705 defsubr (&Svconcat
);
5706 defsubr (&Scopy_sequence
);
5707 defsubr (&Sstring_make_multibyte
);
5708 defsubr (&Sstring_make_unibyte
);
5709 defsubr (&Sstring_as_multibyte
);
5710 defsubr (&Sstring_as_unibyte
);
5711 defsubr (&Sstring_to_multibyte
);
5712 defsubr (&Scopy_alist
);
5713 defsubr (&Ssubstring
);
5714 defsubr (&Ssubstring_no_properties
);
5726 defsubr (&Snreverse
);
5727 defsubr (&Sreverse
);
5729 defsubr (&Splist_get
);
5731 defsubr (&Splist_put
);
5733 defsubr (&Slax_plist_get
);
5734 defsubr (&Slax_plist_put
);
5737 defsubr (&Sequal_including_properties
);
5738 defsubr (&Sfillarray
);
5739 defsubr (&Sclear_string
);
5740 defsubr (&Schar_table_subtype
);
5741 defsubr (&Schar_table_parent
);
5742 defsubr (&Sset_char_table_parent
);
5743 defsubr (&Schar_table_extra_slot
);
5744 defsubr (&Sset_char_table_extra_slot
);
5745 defsubr (&Schar_table_range
);
5746 defsubr (&Sset_char_table_range
);
5747 defsubr (&Sset_char_table_default
);
5748 defsubr (&Soptimize_char_table
);
5749 defsubr (&Smap_char_table
);
5753 defsubr (&Smapconcat
);
5754 defsubr (&Sy_or_n_p
);
5755 defsubr (&Syes_or_no_p
);
5756 defsubr (&Sload_average
);
5757 defsubr (&Sfeaturep
);
5758 defsubr (&Srequire
);
5759 defsubr (&Sprovide
);
5760 defsubr (&Splist_member
);
5761 defsubr (&Swidget_put
);
5762 defsubr (&Swidget_get
);
5763 defsubr (&Swidget_apply
);
5764 defsubr (&Sbase64_encode_region
);
5765 defsubr (&Sbase64_decode_region
);
5766 defsubr (&Sbase64_encode_string
);
5767 defsubr (&Sbase64_decode_string
);
5769 defsubr (&Slocale_info
);
5776 Vweak_hash_tables
= Qnil
;
5779 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5780 (do not change this comment) */