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 bzero (SDATA (string
), len
);
2375 STRING_SET_CHARS (string
, len
);
2376 STRING_SET_UNIBYTE (string
);
2380 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2382 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2384 Lisp_Object char_table
;
2386 CHECK_CHAR_TABLE (char_table
);
2388 return XCHAR_TABLE (char_table
)->purpose
;
2391 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2393 doc
: /* Return the parent char-table of CHAR-TABLE.
2394 The value is either nil or another char-table.
2395 If CHAR-TABLE holds nil for a given character,
2396 then the actual applicable value is inherited from the parent char-table
2397 \(or from its parents, if necessary). */)
2399 Lisp_Object char_table
;
2401 CHECK_CHAR_TABLE (char_table
);
2403 return XCHAR_TABLE (char_table
)->parent
;
2406 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2408 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2409 Return PARENT. PARENT must be either nil or another char-table. */)
2410 (char_table
, parent
)
2411 Lisp_Object char_table
, parent
;
2415 CHECK_CHAR_TABLE (char_table
);
2419 CHECK_CHAR_TABLE (parent
);
2421 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2422 if (EQ (temp
, char_table
))
2423 error ("Attempt to make a chartable be its own parent");
2426 XCHAR_TABLE (char_table
)->parent
= parent
;
2431 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2433 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2435 Lisp_Object char_table
, n
;
2437 CHECK_CHAR_TABLE (char_table
);
2440 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2441 args_out_of_range (char_table
, n
);
2443 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2446 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2447 Sset_char_table_extra_slot
,
2449 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2450 (char_table
, n
, value
)
2451 Lisp_Object char_table
, n
, value
;
2453 CHECK_CHAR_TABLE (char_table
);
2456 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2457 args_out_of_range (char_table
, n
);
2459 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2462 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2464 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2465 RANGE should be nil (for the default value)
2466 a vector which identifies a character set or a row of a character set,
2467 a character set name, or a character code. */)
2469 Lisp_Object char_table
, range
;
2471 CHECK_CHAR_TABLE (char_table
);
2473 if (EQ (range
, Qnil
))
2474 return XCHAR_TABLE (char_table
)->defalt
;
2475 else if (INTEGERP (range
))
2476 return Faref (char_table
, range
);
2477 else if (SYMBOLP (range
))
2479 Lisp_Object charset_info
;
2481 charset_info
= Fget (range
, Qcharset
);
2482 CHECK_VECTOR (charset_info
);
2484 return Faref (char_table
,
2485 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2488 else if (VECTORP (range
))
2490 if (XVECTOR (range
)->size
== 1)
2491 return Faref (char_table
,
2492 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2495 int size
= XVECTOR (range
)->size
;
2496 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2497 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2498 size
<= 1 ? Qnil
: val
[1],
2499 size
<= 2 ? Qnil
: val
[2]);
2500 return Faref (char_table
, ch
);
2504 error ("Invalid RANGE argument to `char-table-range'");
2508 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2510 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2511 RANGE should be t (for all characters), nil (for the default value),
2512 a character set, a vector which identifies a character set, a row of a
2513 character set, or a character code. Return VALUE. */)
2514 (char_table
, range
, value
)
2515 Lisp_Object char_table
, range
, value
;
2519 CHECK_CHAR_TABLE (char_table
);
2522 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2523 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2524 else if (EQ (range
, Qnil
))
2525 XCHAR_TABLE (char_table
)->defalt
= value
;
2526 else if (SYMBOLP (range
))
2528 Lisp_Object charset_info
;
2531 charset_info
= Fget (range
, Qcharset
);
2532 if (! VECTORP (charset_info
)
2533 || ! NATNUMP (AREF (charset_info
, 0))
2534 || (charset_id
= XINT (AREF (charset_info
, 0)),
2535 ! CHARSET_DEFINED_P (charset_id
)))
2536 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2538 if (charset_id
== CHARSET_ASCII
)
2539 for (i
= 0; i
< 128; i
++)
2540 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2541 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2542 for (i
= 128; i
< 160; i
++)
2543 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2544 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2545 for (i
= 160; i
< 256; i
++)
2546 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2548 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2550 else if (INTEGERP (range
))
2551 Faset (char_table
, range
, value
);
2552 else if (VECTORP (range
))
2554 if (XVECTOR (range
)->size
== 1)
2555 return Faset (char_table
,
2556 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2560 int size
= XVECTOR (range
)->size
;
2561 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2562 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2563 size
<= 1 ? Qnil
: val
[1],
2564 size
<= 2 ? Qnil
: val
[2]);
2565 return Faset (char_table
, ch
, value
);
2569 error ("Invalid RANGE argument to `set-char-table-range'");
2574 DEFUN ("set-char-table-default", Fset_char_table_default
,
2575 Sset_char_table_default
, 3, 3, 0,
2576 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2577 The generic character specifies the group of characters.
2578 See also the documentation of `make-char'. */)
2579 (char_table
, ch
, value
)
2580 Lisp_Object char_table
, ch
, value
;
2582 int c
, charset
, code1
, code2
;
2585 CHECK_CHAR_TABLE (char_table
);
2589 SPLIT_CHAR (c
, charset
, code1
, code2
);
2591 /* Since we may want to set the default value for a character set
2592 not yet defined, we check only if the character set is in the
2593 valid range or not, instead of it is already defined or not. */
2594 if (! CHARSET_VALID_P (charset
))
2595 invalid_character (c
);
2597 if (charset
== CHARSET_ASCII
)
2598 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2600 /* Even if C is not a generic char, we had better behave as if a
2601 generic char is specified. */
2602 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2604 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2607 if (SUB_CHAR_TABLE_P (temp
))
2608 XCHAR_TABLE (temp
)->defalt
= value
;
2610 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2613 if (SUB_CHAR_TABLE_P (temp
))
2616 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2617 = make_sub_char_table (temp
));
2618 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2619 if (SUB_CHAR_TABLE_P (temp
))
2620 XCHAR_TABLE (temp
)->defalt
= value
;
2622 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2626 /* Look up the element in TABLE at index CH,
2627 and return it as an integer.
2628 If the element is nil, return CH itself.
2629 (Actually we do that for any non-integer.) */
2632 char_table_translate (table
, ch
)
2637 value
= Faref (table
, make_number (ch
));
2638 if (! INTEGERP (value
))
2640 return XINT (value
);
2644 optimize_sub_char_table (table
, chars
)
2652 from
= 33, to
= 127;
2654 from
= 32, to
= 128;
2656 if (!SUB_CHAR_TABLE_P (*table
))
2658 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2659 for (; from
< to
; from
++)
2660 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2665 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2666 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2674 CHECK_CHAR_TABLE (table
);
2676 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2678 elt
= XCHAR_TABLE (table
)->contents
[i
];
2679 if (!SUB_CHAR_TABLE_P (elt
))
2681 dim
= CHARSET_DIMENSION (i
- 128);
2683 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2684 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2685 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2691 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2692 character or group of characters that share a value.
2693 DEPTH is the current depth in the originally specified
2694 chartable, and INDICES contains the vector indices
2695 for the levels our callers have descended.
2697 ARG is passed to C_FUNCTION when that is called. */
2700 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2701 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2702 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2709 /* At first, handle ASCII and 8-bit European characters. */
2710 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2712 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2714 elt
= XCHAR_TABLE (subtable
)->defalt
;
2716 elt
= Faref (subtable
, make_number (i
));
2718 (*c_function
) (arg
, make_number (i
), elt
);
2720 call2 (function
, make_number (i
), elt
);
2722 #if 0 /* If the char table has entries for higher characters,
2723 we should report them. */
2724 if (NILP (current_buffer
->enable_multibyte_characters
))
2727 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2731 int charset
= XFASTINT (indices
[0]) - 128;
2734 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2735 if (CHARSET_CHARS (charset
) == 94)
2744 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2745 XSETFASTINT (indices
[depth
], i
);
2746 charset
= XFASTINT (indices
[0]) - 128;
2748 && (!CHARSET_DEFINED_P (charset
)
2749 || charset
== CHARSET_8_BIT_CONTROL
2750 || charset
== CHARSET_8_BIT_GRAPHIC
))
2753 if (SUB_CHAR_TABLE_P (elt
))
2756 error ("Too deep char table");
2757 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2763 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2764 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2765 c
= MAKE_CHAR (charset
, c1
, c2
);
2768 elt
= XCHAR_TABLE (subtable
)->defalt
;
2770 elt
= Faref (table
, make_number (c
));
2773 (*c_function
) (arg
, make_number (c
), elt
);
2775 call2 (function
, make_number (c
), elt
);
2780 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2782 void_call2 (a
, b
, c
)
2783 Lisp_Object a
, b
, c
;
2788 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2790 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2791 FUNCTION is called with two arguments--a key and a value.
2792 The key is always a possible IDX argument to `aref'. */)
2793 (function
, char_table
)
2794 Lisp_Object function
, char_table
;
2796 /* The depth of char table is at most 3. */
2797 Lisp_Object indices
[3];
2799 CHECK_CHAR_TABLE (char_table
);
2801 /* When Lisp_Object is represented as a union, `call2' cannot directly
2802 be passed to map_char_table because it returns a Lisp_Object rather
2803 than returning nothing.
2804 Casting leads to crashes on some architectures. -stef */
2805 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2809 /* Return a value for character C in char-table TABLE. Store the
2810 actual index for that value in *IDX. Ignore the default value of
2814 char_table_ref_and_index (table
, c
, idx
)
2818 int charset
, c1
, c2
;
2821 if (SINGLE_BYTE_CHAR_P (c
))
2824 return XCHAR_TABLE (table
)->contents
[c
];
2826 SPLIT_CHAR (c
, charset
, c1
, c2
);
2827 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2828 *idx
= MAKE_CHAR (charset
, 0, 0);
2829 if (!SUB_CHAR_TABLE_P (elt
))
2831 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2832 return XCHAR_TABLE (elt
)->defalt
;
2833 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2834 *idx
= MAKE_CHAR (charset
, c1
, 0);
2835 if (!SUB_CHAR_TABLE_P (elt
))
2837 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2838 return XCHAR_TABLE (elt
)->defalt
;
2840 return XCHAR_TABLE (elt
)->contents
[c2
];
2850 Lisp_Object args
[2];
2853 return Fnconc (2, args
);
2855 return Fnconc (2, &s1
);
2856 #endif /* NO_ARG_ARRAY */
2859 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2860 doc
: /* Concatenate any number of lists by altering them.
2861 Only the last argument is not altered, and need not be a list.
2862 usage: (nconc &rest LISTS) */)
2867 register int argnum
;
2868 register Lisp_Object tail
, tem
, val
;
2872 for (argnum
= 0; argnum
< nargs
; argnum
++)
2875 if (NILP (tem
)) continue;
2880 if (argnum
+ 1 == nargs
) break;
2883 tem
= wrong_type_argument (Qlistp
, tem
);
2892 tem
= args
[argnum
+ 1];
2893 Fsetcdr (tail
, tem
);
2895 args
[argnum
+ 1] = tail
;
2901 /* This is the guts of all mapping functions.
2902 Apply FN to each element of SEQ, one by one,
2903 storing the results into elements of VALS, a C vector of Lisp_Objects.
2904 LENI is the length of VALS, which should also be the length of SEQ. */
2907 mapcar1 (leni
, vals
, fn
, seq
)
2910 Lisp_Object fn
, seq
;
2912 register Lisp_Object tail
;
2915 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2919 /* Don't let vals contain any garbage when GC happens. */
2920 for (i
= 0; i
< leni
; i
++)
2923 GCPRO3 (dummy
, fn
, seq
);
2925 gcpro1
.nvars
= leni
;
2929 /* We need not explicitly protect `tail' because it is used only on lists, and
2930 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2934 for (i
= 0; i
< leni
; i
++)
2936 dummy
= XVECTOR (seq
)->contents
[i
];
2937 dummy
= call1 (fn
, dummy
);
2942 else if (BOOL_VECTOR_P (seq
))
2944 for (i
= 0; i
< leni
; i
++)
2947 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2948 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
2953 dummy
= call1 (fn
, dummy
);
2958 else if (STRINGP (seq
))
2962 for (i
= 0, i_byte
= 0; i
< leni
;)
2967 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2968 XSETFASTINT (dummy
, c
);
2969 dummy
= call1 (fn
, dummy
);
2971 vals
[i_before
] = dummy
;
2974 else /* Must be a list, since Flength did not get an error */
2977 for (i
= 0; i
< leni
; i
++)
2979 dummy
= call1 (fn
, Fcar (tail
));
2989 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2990 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2991 In between each pair of results, stick in SEPARATOR. Thus, " " as
2992 SEPARATOR results in spaces between the values returned by FUNCTION.
2993 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2994 (function
, sequence
, separator
)
2995 Lisp_Object function
, sequence
, separator
;
3000 register Lisp_Object
*args
;
3002 struct gcpro gcpro1
;
3007 len
= Flength (sequence
);
3009 nargs
= leni
+ leni
- 1;
3010 if (nargs
< 0) return build_string ("");
3012 nbytes
= nargs
* sizeof (Lisp_Object
);
3013 SAFE_ALLOCA (args
, Lisp_Object
*, nbytes
);
3016 mapcar1 (leni
, args
, function
, sequence
);
3019 for (i
= leni
- 1; i
>= 0; i
--)
3020 args
[i
+ i
] = args
[i
];
3022 for (i
= 1; i
< nargs
; i
+= 2)
3023 args
[i
] = separator
;
3025 ret
= Fconcat (nargs
, args
);
3031 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3032 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3033 The result is a list just as long as SEQUENCE.
3034 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3035 (function
, sequence
)
3036 Lisp_Object function
, sequence
;
3038 register Lisp_Object len
;
3040 register Lisp_Object
*args
;
3045 len
= Flength (sequence
);
3046 leni
= XFASTINT (len
);
3048 nbytes
= leni
* sizeof (Lisp_Object
);
3049 SAFE_ALLOCA (args
, Lisp_Object
*, nbytes
);
3051 mapcar1 (leni
, args
, function
, sequence
);
3053 ret
= Flist (leni
, args
);
3059 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3060 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3061 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3062 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3063 (function
, sequence
)
3064 Lisp_Object function
, sequence
;
3068 leni
= XFASTINT (Flength (sequence
));
3069 mapcar1 (leni
, 0, function
, sequence
);
3074 /* Anything that calls this function must protect from GC! */
3076 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3077 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3078 Takes one argument, which is the string to display to ask the question.
3079 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3080 No confirmation of the answer is requested; a single character is enough.
3081 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3082 the bindings in `query-replace-map'; see the documentation of that variable
3083 for more information. In this case, the useful bindings are `act', `skip',
3084 `recenter', and `quit'.\)
3086 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3087 is nil and `use-dialog-box' is non-nil. */)
3091 register Lisp_Object obj
, key
, def
, map
;
3092 register int answer
;
3093 Lisp_Object xprompt
;
3094 Lisp_Object args
[2];
3095 struct gcpro gcpro1
, gcpro2
;
3096 int count
= SPECPDL_INDEX ();
3098 specbind (Qcursor_in_echo_area
, Qt
);
3100 map
= Fsymbol_value (intern ("query-replace-map"));
3102 CHECK_STRING (prompt
);
3104 GCPRO2 (prompt
, xprompt
);
3106 #ifdef HAVE_X_WINDOWS
3107 if (display_hourglass_p
)
3108 cancel_hourglass ();
3115 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3119 Lisp_Object pane
, menu
;
3120 redisplay_preserve_echo_area (3);
3121 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3122 Fcons (Fcons (build_string ("No"), Qnil
),
3124 menu
= Fcons (prompt
, pane
);
3125 obj
= Fx_popup_dialog (Qt
, menu
);
3126 answer
= !NILP (obj
);
3129 #endif /* HAVE_MENUS */
3130 cursor_in_echo_area
= 1;
3131 choose_minibuf_frame ();
3134 Lisp_Object pargs
[3];
3136 /* Colorize prompt according to `minibuffer-prompt' face. */
3137 pargs
[0] = build_string ("%s(y or n) ");
3138 pargs
[1] = intern ("face");
3139 pargs
[2] = intern ("minibuffer-prompt");
3140 args
[0] = Fpropertize (3, pargs
);
3145 if (minibuffer_auto_raise
)
3147 Lisp_Object mini_frame
;
3149 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3151 Fraise_frame (mini_frame
);
3154 obj
= read_filtered_event (1, 0, 0, 0);
3155 cursor_in_echo_area
= 0;
3156 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3159 key
= Fmake_vector (make_number (1), obj
);
3160 def
= Flookup_key (map
, key
, Qt
);
3162 if (EQ (def
, intern ("skip")))
3167 else if (EQ (def
, intern ("act")))
3172 else if (EQ (def
, intern ("recenter")))
3178 else if (EQ (def
, intern ("quit")))
3180 /* We want to exit this command for exit-prefix,
3181 and this is the only way to do it. */
3182 else if (EQ (def
, intern ("exit-prefix")))
3187 /* If we don't clear this, then the next call to read_char will
3188 return quit_char again, and we'll enter an infinite loop. */
3193 if (EQ (xprompt
, prompt
))
3195 args
[0] = build_string ("Please answer y or n. ");
3197 xprompt
= Fconcat (2, args
);
3202 if (! noninteractive
)
3204 cursor_in_echo_area
= -1;
3205 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3209 unbind_to (count
, Qnil
);
3210 return answer
? Qt
: Qnil
;
3213 /* This is how C code calls `yes-or-no-p' and allows the user
3216 Anything that calls this function must protect from GC! */
3219 do_yes_or_no_p (prompt
)
3222 return call1 (intern ("yes-or-no-p"), prompt
);
3225 /* Anything that calls this function must protect from GC! */
3227 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3228 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3229 Takes one argument, which is the string to display to ask the question.
3230 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3231 The user must confirm the answer with RET,
3232 and can edit it until it has been confirmed.
3234 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3235 is nil, and `use-dialog-box' is non-nil. */)
3239 register Lisp_Object ans
;
3240 Lisp_Object args
[2];
3241 struct gcpro gcpro1
;
3243 CHECK_STRING (prompt
);
3246 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3250 Lisp_Object pane
, menu
, obj
;
3251 redisplay_preserve_echo_area (4);
3252 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3253 Fcons (Fcons (build_string ("No"), Qnil
),
3256 menu
= Fcons (prompt
, pane
);
3257 obj
= Fx_popup_dialog (Qt
, menu
);
3261 #endif /* HAVE_MENUS */
3264 args
[1] = build_string ("(yes or no) ");
3265 prompt
= Fconcat (2, args
);
3271 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3272 Qyes_or_no_p_history
, Qnil
,
3274 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3279 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3287 message ("Please answer yes or no.");
3288 Fsleep_for (make_number (2), Qnil
);
3292 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3293 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3295 Each of the three load averages is multiplied by 100, then converted
3298 When USE-FLOATS is non-nil, floats will be used instead of integers.
3299 These floats are not multiplied by 100.
3301 If the 5-minute or 15-minute load averages are not available, return a
3302 shortened list, containing only those averages which are available.
3304 An error is thrown if the load average can't be obtained. In some
3305 cases making it work would require Emacs being installed setuid or
3306 setgid so that it can read kernel information, and that usually isn't
3309 Lisp_Object use_floats
;
3312 int loads
= getloadavg (load_ave
, 3);
3313 Lisp_Object ret
= Qnil
;
3316 error ("load-average not implemented for this operating system");
3320 Lisp_Object load
= (NILP (use_floats
) ?
3321 make_number ((int) (100.0 * load_ave
[loads
]))
3322 : make_float (load_ave
[loads
]));
3323 ret
= Fcons (load
, ret
);
3329 Lisp_Object Vfeatures
, Qsubfeatures
;
3330 extern Lisp_Object Vafter_load_alist
;
3332 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3333 doc
: /* Returns t if FEATURE is present in this Emacs.
3335 Use this to conditionalize execution of lisp code based on the
3336 presence or absence of emacs or environment extensions.
3337 Use `provide' to declare that a feature is available. This function
3338 looks at the value of the variable `features'. The optional argument
3339 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3340 (feature
, subfeature
)
3341 Lisp_Object feature
, subfeature
;
3343 register Lisp_Object tem
;
3344 CHECK_SYMBOL (feature
);
3345 tem
= Fmemq (feature
, Vfeatures
);
3346 if (!NILP (tem
) && !NILP (subfeature
))
3347 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3348 return (NILP (tem
)) ? Qnil
: Qt
;
3351 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3352 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3353 The optional argument SUBFEATURES should be a list of symbols listing
3354 particular subfeatures supported in this version of FEATURE. */)
3355 (feature
, subfeatures
)
3356 Lisp_Object feature
, subfeatures
;
3358 register Lisp_Object tem
;
3359 CHECK_SYMBOL (feature
);
3360 CHECK_LIST (subfeatures
);
3361 if (!NILP (Vautoload_queue
))
3362 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3363 tem
= Fmemq (feature
, Vfeatures
);
3365 Vfeatures
= Fcons (feature
, Vfeatures
);
3366 if (!NILP (subfeatures
))
3367 Fput (feature
, Qsubfeatures
, subfeatures
);
3368 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3370 /* Run any load-hooks for this file. */
3371 tem
= Fassq (feature
, Vafter_load_alist
);
3373 Fprogn (XCDR (tem
));
3378 /* `require' and its subroutines. */
3380 /* List of features currently being require'd, innermost first. */
3382 Lisp_Object require_nesting_list
;
3385 require_unwind (old_value
)
3386 Lisp_Object old_value
;
3388 return require_nesting_list
= old_value
;
3391 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3392 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3393 If FEATURE is not a member of the list `features', then the feature
3394 is not loaded; so load the file FILENAME.
3395 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3396 and `load' will try to load this name appended with the suffix `.elc' or
3397 `.el', in that order. The name without appended suffix will not be used.
3398 If the optional third argument NOERROR is non-nil,
3399 then return nil if the file is not found instead of signaling an error.
3400 Normally the return value is FEATURE.
3401 The normal messages at start and end of loading FILENAME are suppressed. */)
3402 (feature
, filename
, noerror
)
3403 Lisp_Object feature
, filename
, noerror
;
3405 register Lisp_Object tem
;
3406 struct gcpro gcpro1
, gcpro2
;
3408 CHECK_SYMBOL (feature
);
3410 tem
= Fmemq (feature
, Vfeatures
);
3414 int count
= SPECPDL_INDEX ();
3417 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3419 /* This is to make sure that loadup.el gives a clear picture
3420 of what files are preloaded and when. */
3421 if (! NILP (Vpurify_flag
))
3422 error ("(require %s) while preparing to dump",
3423 SDATA (SYMBOL_NAME (feature
)));
3425 /* A certain amount of recursive `require' is legitimate,
3426 but if we require the same feature recursively 3 times,
3428 tem
= require_nesting_list
;
3429 while (! NILP (tem
))
3431 if (! NILP (Fequal (feature
, XCAR (tem
))))
3436 error ("Recursive `require' for feature `%s'",
3437 SDATA (SYMBOL_NAME (feature
)));
3439 /* Update the list for any nested `require's that occur. */
3440 record_unwind_protect (require_unwind
, require_nesting_list
);
3441 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3443 /* Value saved here is to be restored into Vautoload_queue */
3444 record_unwind_protect (un_autoload
, Vautoload_queue
);
3445 Vautoload_queue
= Qt
;
3447 /* Load the file. */
3448 GCPRO2 (feature
, filename
);
3449 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3450 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3453 /* If load failed entirely, return nil. */
3455 return unbind_to (count
, Qnil
);
3457 tem
= Fmemq (feature
, Vfeatures
);
3459 error ("Required feature `%s' was not provided",
3460 SDATA (SYMBOL_NAME (feature
)));
3462 /* Once loading finishes, don't undo it. */
3463 Vautoload_queue
= Qt
;
3464 feature
= unbind_to (count
, feature
);
3470 /* Primitives for work of the "widget" library.
3471 In an ideal world, this section would not have been necessary.
3472 However, lisp function calls being as slow as they are, it turns
3473 out that some functions in the widget library (wid-edit.el) are the
3474 bottleneck of Widget operation. Here is their translation to C,
3475 for the sole reason of efficiency. */
3477 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3478 doc
: /* Return non-nil if PLIST has the property PROP.
3479 PLIST is a property list, which is a list of the form
3480 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3481 Unlike `plist-get', this allows you to distinguish between a missing
3482 property and a property with the value nil.
3483 The value is actually the tail of PLIST whose car is PROP. */)
3485 Lisp_Object plist
, prop
;
3487 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3490 plist
= XCDR (plist
);
3491 plist
= CDR (plist
);
3496 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3497 doc
: /* In WIDGET, set PROPERTY to VALUE.
3498 The value can later be retrieved with `widget-get'. */)
3499 (widget
, property
, value
)
3500 Lisp_Object widget
, property
, value
;
3502 CHECK_CONS (widget
);
3503 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3507 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3508 doc
: /* In WIDGET, get the value of PROPERTY.
3509 The value could either be specified when the widget was created, or
3510 later with `widget-put'. */)
3512 Lisp_Object widget
, property
;
3520 CHECK_CONS (widget
);
3521 tmp
= Fplist_member (XCDR (widget
), property
);
3527 tmp
= XCAR (widget
);
3530 widget
= Fget (tmp
, Qwidget_type
);
3534 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3535 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3536 ARGS are passed as extra arguments to the function.
3537 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3542 /* This function can GC. */
3543 Lisp_Object newargs
[3];
3544 struct gcpro gcpro1
, gcpro2
;
3547 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3548 newargs
[1] = args
[0];
3549 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3550 GCPRO2 (newargs
[0], newargs
[2]);
3551 result
= Fapply (3, newargs
);
3556 #ifdef HAVE_LANGINFO_CODESET
3557 #include <langinfo.h>
3560 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3561 doc
: /* Access locale data ITEM for the current C locale, if available.
3562 ITEM should be one of the following:
3564 `codeset', returning the character set as a string (locale item CODESET);
3566 `days', returning a 7-element vector of day names (locale items DAY_n);
3568 `months', returning a 12-element vector of month names (locale items MON_n);
3570 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3571 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3573 If the system can't provide such information through a call to
3574 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3576 See also Info node `(libc)Locales'.
3578 The data read from the system are decoded using `locale-coding-system'. */)
3583 #ifdef HAVE_LANGINFO_CODESET
3585 if (EQ (item
, Qcodeset
))
3587 str
= nl_langinfo (CODESET
);
3588 return build_string (str
);
3591 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3593 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3594 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3596 synchronize_system_time_locale ();
3597 for (i
= 0; i
< 7; i
++)
3599 str
= nl_langinfo (days
[i
]);
3600 val
= make_unibyte_string (str
, strlen (str
));
3601 /* Fixme: Is this coding system necessarily right, even if
3602 it is consistent with CODESET? If not, what to do? */
3603 Faset (v
, make_number (i
),
3604 code_convert_string_norecord (val
, Vlocale_coding_system
,
3611 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3613 struct Lisp_Vector
*p
= allocate_vector (12);
3614 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3615 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3617 synchronize_system_time_locale ();
3618 for (i
= 0; i
< 12; i
++)
3620 str
= nl_langinfo (months
[i
]);
3621 val
= make_unibyte_string (str
, strlen (str
));
3623 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3625 XSETVECTOR (val
, p
);
3629 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3630 but is in the locale files. This could be used by ps-print. */
3632 else if (EQ (item
, Qpaper
))
3634 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3635 make_number (nl_langinfo (PAPER_HEIGHT
)));
3637 #endif /* PAPER_WIDTH */
3638 #endif /* HAVE_LANGINFO_CODESET*/
3642 /* base64 encode/decode functions (RFC 2045).
3643 Based on code from GNU recode. */
3645 #define MIME_LINE_LENGTH 76
3647 #define IS_ASCII(Character) \
3649 #define IS_BASE64(Character) \
3650 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3651 #define IS_BASE64_IGNORABLE(Character) \
3652 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3653 || (Character) == '\f' || (Character) == '\r')
3655 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3656 character or return retval if there are no characters left to
3658 #define READ_QUADRUPLET_BYTE(retval) \
3663 if (nchars_return) \
3664 *nchars_return = nchars; \
3669 while (IS_BASE64_IGNORABLE (c))
3671 /* Table of characters coding the 64 values. */
3672 static char base64_value_to_char
[64] =
3674 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3675 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3676 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3677 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3678 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3679 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3680 '8', '9', '+', '/' /* 60-63 */
3683 /* Table of base64 values for first 128 characters. */
3684 static short base64_char_to_value
[128] =
3686 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3687 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3688 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3689 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3690 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3691 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3692 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3693 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3694 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3695 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3696 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3697 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3698 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3701 /* The following diagram shows the logical steps by which three octets
3702 get transformed into four base64 characters.
3704 .--------. .--------. .--------.
3705 |aaaaaabb| |bbbbcccc| |ccdddddd|
3706 `--------' `--------' `--------'
3708 .--------+--------+--------+--------.
3709 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3710 `--------+--------+--------+--------'
3712 .--------+--------+--------+--------.
3713 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3714 `--------+--------+--------+--------'
3716 The octets are divided into 6 bit chunks, which are then encoded into
3717 base64 characters. */
3720 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3721 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3723 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3725 doc
: /* Base64-encode the region between BEG and END.
3726 Return the length of the encoded text.
3727 Optional third argument NO-LINE-BREAK means do not break long lines
3728 into shorter lines. */)
3729 (beg
, end
, no_line_break
)
3730 Lisp_Object beg
, end
, no_line_break
;
3733 int allength
, length
;
3734 int ibeg
, iend
, encoded_length
;
3738 validate_region (&beg
, &end
);
3740 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3741 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3742 move_gap_both (XFASTINT (beg
), ibeg
);
3744 /* We need to allocate enough room for encoding the text.
3745 We need 33 1/3% more space, plus a newline every 76
3746 characters, and then we round up. */
3747 length
= iend
- ibeg
;
3748 allength
= length
+ length
/3 + 1;
3749 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3751 SAFE_ALLOCA (encoded
, char *, allength
);
3752 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3753 NILP (no_line_break
),
3754 !NILP (current_buffer
->enable_multibyte_characters
));
3755 if (encoded_length
> allength
)
3758 if (encoded_length
< 0)
3760 /* The encoding wasn't possible. */
3761 SAFE_FREE (allength
);
3762 error ("Multibyte character in data for base64 encoding");
3765 /* Now we have encoded the region, so we insert the new contents
3766 and delete the old. (Insert first in order to preserve markers.) */
3767 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3768 insert (encoded
, encoded_length
);
3769 SAFE_FREE (allength
);
3770 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3772 /* If point was outside of the region, restore it exactly; else just
3773 move to the beginning of the region. */
3774 if (old_pos
>= XFASTINT (end
))
3775 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3776 else if (old_pos
> XFASTINT (beg
))
3777 old_pos
= XFASTINT (beg
);
3780 /* We return the length of the encoded text. */
3781 return make_number (encoded_length
);
3784 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3786 doc
: /* Base64-encode STRING and return the result.
3787 Optional second argument NO-LINE-BREAK means do not break long lines
3788 into shorter lines. */)
3789 (string
, no_line_break
)
3790 Lisp_Object string
, no_line_break
;
3792 int allength
, length
, encoded_length
;
3794 Lisp_Object encoded_string
;
3797 CHECK_STRING (string
);
3799 /* We need to allocate enough room for encoding the text.
3800 We need 33 1/3% more space, plus a newline every 76
3801 characters, and then we round up. */
3802 length
= SBYTES (string
);
3803 allength
= length
+ length
/3 + 1;
3804 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3806 /* We need to allocate enough room for decoding the text. */
3807 SAFE_ALLOCA (encoded
, char *, allength
);
3809 encoded_length
= base64_encode_1 (SDATA (string
),
3810 encoded
, length
, NILP (no_line_break
),
3811 STRING_MULTIBYTE (string
));
3812 if (encoded_length
> allength
)
3815 if (encoded_length
< 0)
3817 /* The encoding wasn't possible. */
3818 SAFE_FREE (allength
);
3819 error ("Multibyte character in data for base64 encoding");
3822 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3823 SAFE_FREE (allength
);
3825 return encoded_string
;
3829 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3836 int counter
= 0, i
= 0;
3846 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3854 /* Wrap line every 76 characters. */
3858 if (counter
< MIME_LINE_LENGTH
/ 4)
3867 /* Process first byte of a triplet. */
3869 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3870 value
= (0x03 & c
) << 4;
3872 /* Process second byte of a triplet. */
3876 *e
++ = base64_value_to_char
[value
];
3884 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3892 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3893 value
= (0x0f & c
) << 2;
3895 /* Process third byte of a triplet. */
3899 *e
++ = base64_value_to_char
[value
];
3906 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3914 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3915 *e
++ = base64_value_to_char
[0x3f & c
];
3922 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3924 doc
: /* Base64-decode the region between BEG and END.
3925 Return the length of the decoded text.
3926 If the region can't be decoded, signal an error and don't modify the buffer. */)
3928 Lisp_Object beg
, end
;
3930 int ibeg
, iend
, length
, allength
;
3935 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3938 validate_region (&beg
, &end
);
3940 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3941 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3943 length
= iend
- ibeg
;
3945 /* We need to allocate enough room for decoding the text. If we are
3946 working on a multibyte buffer, each decoded code may occupy at
3948 allength
= multibyte
? length
* 2 : length
;
3949 SAFE_ALLOCA (decoded
, char *, allength
);
3951 move_gap_both (XFASTINT (beg
), ibeg
);
3952 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3953 multibyte
, &inserted_chars
);
3954 if (decoded_length
> allength
)
3957 if (decoded_length
< 0)
3959 /* The decoding wasn't possible. */
3960 SAFE_FREE (allength
);
3961 error ("Invalid base64 data");
3964 /* Now we have decoded the region, so we insert the new contents
3965 and delete the old. (Insert first in order to preserve markers.) */
3966 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3967 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3968 SAFE_FREE (allength
);
3970 /* Delete the original text. */
3971 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3972 iend
+ decoded_length
, 1);
3974 /* If point was outside of the region, restore it exactly; else just
3975 move to the beginning of the region. */
3976 if (old_pos
>= XFASTINT (end
))
3977 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3978 else if (old_pos
> XFASTINT (beg
))
3979 old_pos
= XFASTINT (beg
);
3980 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3982 return make_number (inserted_chars
);
3985 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3987 doc
: /* Base64-decode STRING and return the result. */)
3992 int length
, decoded_length
;
3993 Lisp_Object decoded_string
;
3996 CHECK_STRING (string
);
3998 length
= SBYTES (string
);
3999 /* We need to allocate enough room for decoding the text. */
4000 SAFE_ALLOCA (decoded
, char *, length
);
4002 /* The decoded result should be unibyte. */
4003 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4005 if (decoded_length
> length
)
4007 else if (decoded_length
>= 0)
4008 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4010 decoded_string
= Qnil
;
4013 if (!STRINGP (decoded_string
))
4014 error ("Invalid base64 data");
4016 return decoded_string
;
4019 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4020 MULTIBYTE is nonzero, the decoded result should be in multibyte
4021 form. If NCHARS_RETRUN is not NULL, store the number of produced
4022 characters in *NCHARS_RETURN. */
4025 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4035 unsigned long value
;
4040 /* Process first byte of a quadruplet. */
4042 READ_QUADRUPLET_BYTE (e
-to
);
4046 value
= base64_char_to_value
[c
] << 18;
4048 /* Process second byte of a quadruplet. */
4050 READ_QUADRUPLET_BYTE (-1);
4054 value
|= base64_char_to_value
[c
] << 12;
4056 c
= (unsigned char) (value
>> 16);
4058 e
+= CHAR_STRING (c
, e
);
4063 /* Process third byte of a quadruplet. */
4065 READ_QUADRUPLET_BYTE (-1);
4069 READ_QUADRUPLET_BYTE (-1);
4078 value
|= base64_char_to_value
[c
] << 6;
4080 c
= (unsigned char) (0xff & value
>> 8);
4082 e
+= CHAR_STRING (c
, e
);
4087 /* Process fourth byte of a quadruplet. */
4089 READ_QUADRUPLET_BYTE (-1);
4096 value
|= base64_char_to_value
[c
];
4098 c
= (unsigned char) (0xff & value
);
4100 e
+= CHAR_STRING (c
, e
);
4109 /***********************************************************************
4111 ***** Hash Tables *****
4113 ***********************************************************************/
4115 /* Implemented by gerd@gnu.org. This hash table implementation was
4116 inspired by CMUCL hash tables. */
4120 1. For small tables, association lists are probably faster than
4121 hash tables because they have lower overhead.
4123 For uses of hash tables where the O(1) behavior of table
4124 operations is not a requirement, it might therefore be a good idea
4125 not to hash. Instead, we could just do a linear search in the
4126 key_and_value vector of the hash table. This could be done
4127 if a `:linear-search t' argument is given to make-hash-table. */
4130 /* The list of all weak hash tables. Don't staticpro this one. */
4132 Lisp_Object Vweak_hash_tables
;
4134 /* Various symbols. */
4136 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4137 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4138 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4140 /* Function prototypes. */
4142 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4143 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4144 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4145 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4146 Lisp_Object
, unsigned));
4147 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4148 Lisp_Object
, unsigned));
4149 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4150 unsigned, Lisp_Object
, unsigned));
4151 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4152 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4153 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4154 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4156 static unsigned sxhash_string
P_ ((unsigned char *, int));
4157 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4158 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4159 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4160 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4164 /***********************************************************************
4166 ***********************************************************************/
4168 /* If OBJ is a Lisp hash table, return a pointer to its struct
4169 Lisp_Hash_Table. Otherwise, signal an error. */
4171 static struct Lisp_Hash_Table
*
4172 check_hash_table (obj
)
4175 CHECK_HASH_TABLE (obj
);
4176 return XHASH_TABLE (obj
);
4180 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4184 next_almost_prime (n
)
4197 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4198 which USED[I] is non-zero. If found at index I in ARGS, set
4199 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4200 -1. This function is used to extract a keyword/argument pair from
4201 a DEFUN parameter list. */
4204 get_key_arg (key
, nargs
, args
, used
)
4212 for (i
= 0; i
< nargs
- 1; ++i
)
4213 if (!used
[i
] && EQ (args
[i
], key
))
4228 /* Return a Lisp vector which has the same contents as VEC but has
4229 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4230 vector that are not copied from VEC are set to INIT. */
4233 larger_vector (vec
, new_size
, init
)
4238 struct Lisp_Vector
*v
;
4241 xassert (VECTORP (vec
));
4242 old_size
= XVECTOR (vec
)->size
;
4243 xassert (new_size
>= old_size
);
4245 v
= allocate_vector (new_size
);
4246 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4247 old_size
* sizeof *v
->contents
);
4248 for (i
= old_size
; i
< new_size
; ++i
)
4249 v
->contents
[i
] = init
;
4250 XSETVECTOR (vec
, v
);
4255 /***********************************************************************
4257 ***********************************************************************/
4259 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4260 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4261 KEY2 are the same. */
4264 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4265 struct Lisp_Hash_Table
*h
;
4266 Lisp_Object key1
, key2
;
4267 unsigned hash1
, hash2
;
4269 return (FLOATP (key1
)
4271 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4275 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4276 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4277 KEY2 are the same. */
4280 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4281 struct Lisp_Hash_Table
*h
;
4282 Lisp_Object key1
, key2
;
4283 unsigned hash1
, hash2
;
4285 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4289 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4290 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4291 if KEY1 and KEY2 are the same. */
4294 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4295 struct Lisp_Hash_Table
*h
;
4296 Lisp_Object key1
, key2
;
4297 unsigned hash1
, hash2
;
4301 Lisp_Object args
[3];
4303 args
[0] = h
->user_cmp_function
;
4306 return !NILP (Ffuncall (3, args
));
4313 /* Value is a hash code for KEY for use in hash table H which uses
4314 `eq' to compare keys. The hash code returned is guaranteed to fit
4315 in a Lisp integer. */
4319 struct Lisp_Hash_Table
*h
;
4322 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4323 xassert ((hash
& ~INTMASK
) == 0);
4328 /* Value is a hash code for KEY for use in hash table H which uses
4329 `eql' to compare keys. The hash code returned is guaranteed to fit
4330 in a Lisp integer. */
4334 struct Lisp_Hash_Table
*h
;
4339 hash
= sxhash (key
, 0);
4341 hash
= XUINT (key
) ^ XGCTYPE (key
);
4342 xassert ((hash
& ~INTMASK
) == 0);
4347 /* Value is a hash code for KEY for use in hash table H which uses
4348 `equal' to compare keys. The hash code returned is guaranteed to fit
4349 in a Lisp integer. */
4352 hashfn_equal (h
, key
)
4353 struct Lisp_Hash_Table
*h
;
4356 unsigned hash
= sxhash (key
, 0);
4357 xassert ((hash
& ~INTMASK
) == 0);
4362 /* Value is a hash code for KEY for use in hash table H which uses as
4363 user-defined function to compare keys. The hash code returned is
4364 guaranteed to fit in a Lisp integer. */
4367 hashfn_user_defined (h
, key
)
4368 struct Lisp_Hash_Table
*h
;
4371 Lisp_Object args
[2], hash
;
4373 args
[0] = h
->user_hash_function
;
4375 hash
= Ffuncall (2, args
);
4376 if (!INTEGERP (hash
))
4378 list2 (build_string ("Invalid hash code returned from \
4379 user-supplied hash function"),
4381 return XUINT (hash
);
4385 /* Create and initialize a new hash table.
4387 TEST specifies the test the hash table will use to compare keys.
4388 It must be either one of the predefined tests `eq', `eql' or
4389 `equal' or a symbol denoting a user-defined test named TEST with
4390 test and hash functions USER_TEST and USER_HASH.
4392 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4394 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4395 new size when it becomes full is computed by adding REHASH_SIZE to
4396 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4397 table's new size is computed by multiplying its old size with
4400 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4401 be resized when the ratio of (number of entries in the table) /
4402 (table size) is >= REHASH_THRESHOLD.
4404 WEAK specifies the weakness of the table. If non-nil, it must be
4405 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4408 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4409 user_test
, user_hash
)
4410 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4411 Lisp_Object user_test
, user_hash
;
4413 struct Lisp_Hash_Table
*h
;
4415 int index_size
, i
, sz
;
4417 /* Preconditions. */
4418 xassert (SYMBOLP (test
));
4419 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4420 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4421 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4422 xassert (FLOATP (rehash_threshold
)
4423 && XFLOATINT (rehash_threshold
) > 0
4424 && XFLOATINT (rehash_threshold
) <= 1.0);
4426 if (XFASTINT (size
) == 0)
4427 size
= make_number (1);
4429 /* Allocate a table and initialize it. */
4430 h
= allocate_hash_table ();
4432 /* Initialize hash table slots. */
4433 sz
= XFASTINT (size
);
4436 if (EQ (test
, Qeql
))
4438 h
->cmpfn
= cmpfn_eql
;
4439 h
->hashfn
= hashfn_eql
;
4441 else if (EQ (test
, Qeq
))
4444 h
->hashfn
= hashfn_eq
;
4446 else if (EQ (test
, Qequal
))
4448 h
->cmpfn
= cmpfn_equal
;
4449 h
->hashfn
= hashfn_equal
;
4453 h
->user_cmp_function
= user_test
;
4454 h
->user_hash_function
= user_hash
;
4455 h
->cmpfn
= cmpfn_user_defined
;
4456 h
->hashfn
= hashfn_user_defined
;
4460 h
->rehash_threshold
= rehash_threshold
;
4461 h
->rehash_size
= rehash_size
;
4462 h
->count
= make_number (0);
4463 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4464 h
->hash
= Fmake_vector (size
, Qnil
);
4465 h
->next
= Fmake_vector (size
, Qnil
);
4466 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4467 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4468 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4470 /* Set up the free list. */
4471 for (i
= 0; i
< sz
- 1; ++i
)
4472 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4473 h
->next_free
= make_number (0);
4475 XSET_HASH_TABLE (table
, h
);
4476 xassert (HASH_TABLE_P (table
));
4477 xassert (XHASH_TABLE (table
) == h
);
4479 /* Maybe add this hash table to the list of all weak hash tables. */
4481 h
->next_weak
= Qnil
;
4484 h
->next_weak
= Vweak_hash_tables
;
4485 Vweak_hash_tables
= table
;
4492 /* Return a copy of hash table H1. Keys and values are not copied,
4493 only the table itself is. */
4496 copy_hash_table (h1
)
4497 struct Lisp_Hash_Table
*h1
;
4500 struct Lisp_Hash_Table
*h2
;
4501 struct Lisp_Vector
*next
;
4503 h2
= allocate_hash_table ();
4504 next
= h2
->vec_next
;
4505 bcopy (h1
, h2
, sizeof *h2
);
4506 h2
->vec_next
= next
;
4507 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4508 h2
->hash
= Fcopy_sequence (h1
->hash
);
4509 h2
->next
= Fcopy_sequence (h1
->next
);
4510 h2
->index
= Fcopy_sequence (h1
->index
);
4511 XSET_HASH_TABLE (table
, h2
);
4513 /* Maybe add this hash table to the list of all weak hash tables. */
4514 if (!NILP (h2
->weak
))
4516 h2
->next_weak
= Vweak_hash_tables
;
4517 Vweak_hash_tables
= table
;
4524 /* Resize hash table H if it's too full. If H cannot be resized
4525 because it's already too large, throw an error. */
4528 maybe_resize_hash_table (h
)
4529 struct Lisp_Hash_Table
*h
;
4531 if (NILP (h
->next_free
))
4533 int old_size
= HASH_TABLE_SIZE (h
);
4534 int i
, new_size
, index_size
;
4536 if (INTEGERP (h
->rehash_size
))
4537 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4539 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4540 new_size
= max (old_size
+ 1, new_size
);
4541 index_size
= next_almost_prime ((int)
4543 / XFLOATINT (h
->rehash_threshold
)));
4544 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4545 error ("Hash table too large to resize");
4547 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4548 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4549 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4550 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4552 /* Update the free list. Do it so that new entries are added at
4553 the end of the free list. This makes some operations like
4555 for (i
= old_size
; i
< new_size
- 1; ++i
)
4556 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4558 if (!NILP (h
->next_free
))
4560 Lisp_Object last
, next
;
4562 last
= h
->next_free
;
4563 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4567 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4570 XSETFASTINT (h
->next_free
, old_size
);
4573 for (i
= 0; i
< old_size
; ++i
)
4574 if (!NILP (HASH_HASH (h
, i
)))
4576 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4577 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4578 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4579 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4585 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4586 the hash code of KEY. Value is the index of the entry in H
4587 matching KEY, or -1 if not found. */
4590 hash_lookup (h
, key
, hash
)
4591 struct Lisp_Hash_Table
*h
;
4596 int start_of_bucket
;
4599 hash_code
= h
->hashfn (h
, key
);
4603 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4604 idx
= HASH_INDEX (h
, start_of_bucket
);
4606 /* We need not gcpro idx since it's either an integer or nil. */
4609 int i
= XFASTINT (idx
);
4610 if (EQ (key
, HASH_KEY (h
, i
))
4612 && h
->cmpfn (h
, key
, hash_code
,
4613 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4615 idx
= HASH_NEXT (h
, i
);
4618 return NILP (idx
) ? -1 : XFASTINT (idx
);
4622 /* Put an entry into hash table H that associates KEY with VALUE.
4623 HASH is a previously computed hash code of KEY.
4624 Value is the index of the entry in H matching KEY. */
4627 hash_put (h
, key
, value
, hash
)
4628 struct Lisp_Hash_Table
*h
;
4629 Lisp_Object key
, value
;
4632 int start_of_bucket
, i
;
4634 xassert ((hash
& ~INTMASK
) == 0);
4636 /* Increment count after resizing because resizing may fail. */
4637 maybe_resize_hash_table (h
);
4638 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4640 /* Store key/value in the key_and_value vector. */
4641 i
= XFASTINT (h
->next_free
);
4642 h
->next_free
= HASH_NEXT (h
, i
);
4643 HASH_KEY (h
, i
) = key
;
4644 HASH_VALUE (h
, i
) = value
;
4646 /* Remember its hash code. */
4647 HASH_HASH (h
, i
) = make_number (hash
);
4649 /* Add new entry to its collision chain. */
4650 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4651 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4652 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4657 /* Remove the entry matching KEY from hash table H, if there is one. */
4660 hash_remove (h
, key
)
4661 struct Lisp_Hash_Table
*h
;
4665 int start_of_bucket
;
4666 Lisp_Object idx
, prev
;
4668 hash_code
= h
->hashfn (h
, key
);
4669 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4670 idx
= HASH_INDEX (h
, start_of_bucket
);
4673 /* We need not gcpro idx, prev since they're either integers or nil. */
4676 int i
= XFASTINT (idx
);
4678 if (EQ (key
, HASH_KEY (h
, i
))
4680 && h
->cmpfn (h
, key
, hash_code
,
4681 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4683 /* Take entry out of collision chain. */
4685 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4687 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4689 /* Clear slots in key_and_value and add the slots to
4691 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4692 HASH_NEXT (h
, i
) = h
->next_free
;
4693 h
->next_free
= make_number (i
);
4694 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4695 xassert (XINT (h
->count
) >= 0);
4701 idx
= HASH_NEXT (h
, i
);
4707 /* Clear hash table H. */
4711 struct Lisp_Hash_Table
*h
;
4713 if (XFASTINT (h
->count
) > 0)
4715 int i
, size
= HASH_TABLE_SIZE (h
);
4717 for (i
= 0; i
< size
; ++i
)
4719 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4720 HASH_KEY (h
, i
) = Qnil
;
4721 HASH_VALUE (h
, i
) = Qnil
;
4722 HASH_HASH (h
, i
) = Qnil
;
4725 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4726 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4728 h
->next_free
= make_number (0);
4729 h
->count
= make_number (0);
4735 /************************************************************************
4737 ************************************************************************/
4739 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4740 entries from the table that don't survive the current GC.
4741 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4742 non-zero if anything was marked. */
4745 sweep_weak_table (h
, remove_entries_p
)
4746 struct Lisp_Hash_Table
*h
;
4747 int remove_entries_p
;
4749 int bucket
, n
, marked
;
4751 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4754 for (bucket
= 0; bucket
< n
; ++bucket
)
4756 Lisp_Object idx
, next
, prev
;
4758 /* Follow collision chain, removing entries that
4759 don't survive this garbage collection. */
4761 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4763 int i
= XFASTINT (idx
);
4764 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4765 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4768 if (EQ (h
->weak
, Qkey
))
4769 remove_p
= !key_known_to_survive_p
;
4770 else if (EQ (h
->weak
, Qvalue
))
4771 remove_p
= !value_known_to_survive_p
;
4772 else if (EQ (h
->weak
, Qkey_or_value
))
4773 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4774 else if (EQ (h
->weak
, Qkey_and_value
))
4775 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4779 next
= HASH_NEXT (h
, i
);
4781 if (remove_entries_p
)
4785 /* Take out of collision chain. */
4787 HASH_INDEX (h
, bucket
) = next
;
4789 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4791 /* Add to free list. */
4792 HASH_NEXT (h
, i
) = h
->next_free
;
4795 /* Clear key, value, and hash. */
4796 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4797 HASH_HASH (h
, i
) = Qnil
;
4799 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4806 /* Make sure key and value survive. */
4807 if (!key_known_to_survive_p
)
4809 mark_object (HASH_KEY (h
, i
));
4813 if (!value_known_to_survive_p
)
4815 mark_object (HASH_VALUE (h
, i
));
4826 /* Remove elements from weak hash tables that don't survive the
4827 current garbage collection. Remove weak tables that don't survive
4828 from Vweak_hash_tables. Called from gc_sweep. */
4831 sweep_weak_hash_tables ()
4833 Lisp_Object table
, used
, next
;
4834 struct Lisp_Hash_Table
*h
;
4837 /* Mark all keys and values that are in use. Keep on marking until
4838 there is no more change. This is necessary for cases like
4839 value-weak table A containing an entry X -> Y, where Y is used in a
4840 key-weak table B, Z -> Y. If B comes after A in the list of weak
4841 tables, X -> Y might be removed from A, although when looking at B
4842 one finds that it shouldn't. */
4846 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4848 h
= XHASH_TABLE (table
);
4849 if (h
->size
& ARRAY_MARK_FLAG
)
4850 marked
|= sweep_weak_table (h
, 0);
4855 /* Remove tables and entries that aren't used. */
4856 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4858 h
= XHASH_TABLE (table
);
4859 next
= h
->next_weak
;
4861 if (h
->size
& ARRAY_MARK_FLAG
)
4863 /* TABLE is marked as used. Sweep its contents. */
4864 if (XFASTINT (h
->count
) > 0)
4865 sweep_weak_table (h
, 1);
4867 /* Add table to the list of used weak hash tables. */
4868 h
->next_weak
= used
;
4873 Vweak_hash_tables
= used
;
4878 /***********************************************************************
4879 Hash Code Computation
4880 ***********************************************************************/
4882 /* Maximum depth up to which to dive into Lisp structures. */
4884 #define SXHASH_MAX_DEPTH 3
4886 /* Maximum length up to which to take list and vector elements into
4889 #define SXHASH_MAX_LEN 7
4891 /* Combine two integers X and Y for hashing. */
4893 #define SXHASH_COMBINE(X, Y) \
4894 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4898 /* Return a hash for string PTR which has length LEN. The hash
4899 code returned is guaranteed to fit in a Lisp integer. */
4902 sxhash_string (ptr
, len
)
4906 unsigned char *p
= ptr
;
4907 unsigned char *end
= p
+ len
;
4916 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4919 return hash
& INTMASK
;
4923 /* Return a hash for list LIST. DEPTH is the current depth in the
4924 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4927 sxhash_list (list
, depth
)
4934 if (depth
< SXHASH_MAX_DEPTH
)
4936 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4937 list
= XCDR (list
), ++i
)
4939 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4940 hash
= SXHASH_COMBINE (hash
, hash2
);
4947 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4948 the Lisp structure. */
4951 sxhash_vector (vec
, depth
)
4955 unsigned hash
= XVECTOR (vec
)->size
;
4958 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4959 for (i
= 0; i
< n
; ++i
)
4961 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4962 hash
= SXHASH_COMBINE (hash
, hash2
);
4969 /* Return a hash for bool-vector VECTOR. */
4972 sxhash_bool_vector (vec
)
4975 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4978 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4979 for (i
= 0; i
< n
; ++i
)
4980 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4986 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4987 structure. Value is an unsigned integer clipped to INTMASK. */
4996 if (depth
> SXHASH_MAX_DEPTH
)
4999 switch (XTYPE (obj
))
5006 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
5007 SCHARS (SYMBOL_NAME (obj
)));
5015 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5018 /* This can be everything from a vector to an overlay. */
5019 case Lisp_Vectorlike
:
5021 /* According to the CL HyperSpec, two arrays are equal only if
5022 they are `eq', except for strings and bit-vectors. In
5023 Emacs, this works differently. We have to compare element
5025 hash
= sxhash_vector (obj
, depth
);
5026 else if (BOOL_VECTOR_P (obj
))
5027 hash
= sxhash_bool_vector (obj
);
5029 /* Others are `equal' if they are `eq', so let's take their
5035 hash
= sxhash_list (obj
, depth
);
5040 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5041 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5042 for (hash
= 0; p
< e
; ++p
)
5043 hash
= SXHASH_COMBINE (hash
, *p
);
5051 return hash
& INTMASK
;
5056 /***********************************************************************
5058 ***********************************************************************/
5061 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5062 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5066 unsigned hash
= sxhash (obj
, 0);;
5067 return make_number (hash
);
5071 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5072 doc
: /* Create and return a new hash table.
5074 Arguments are specified as keyword/argument pairs. The following
5075 arguments are defined:
5077 :test TEST -- TEST must be a symbol that specifies how to compare
5078 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5079 `equal'. User-supplied test and hash functions can be specified via
5080 `define-hash-table-test'.
5082 :size SIZE -- A hint as to how many elements will be put in the table.
5085 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5086 fills up. If REHASH-SIZE is an integer, add that many space. If it
5087 is a float, it must be > 1.0, and the new size is computed by
5088 multiplying the old size with that factor. Default is 1.5.
5090 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5091 Resize the hash table when ratio of the number of entries in the
5092 table. Default is 0.8.
5094 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5095 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5096 returned is a weak table. Key/value pairs are removed from a weak
5097 hash table when there are no non-weak references pointing to their
5098 key, value, one of key or value, or both key and value, depending on
5099 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5102 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5107 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5108 Lisp_Object user_test
, user_hash
;
5112 /* The vector `used' is used to keep track of arguments that
5113 have been consumed. */
5114 used
= (char *) alloca (nargs
* sizeof *used
);
5115 bzero (used
, nargs
* sizeof *used
);
5117 /* See if there's a `:test TEST' among the arguments. */
5118 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5119 test
= i
< 0 ? Qeql
: args
[i
];
5120 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5122 /* See if it is a user-defined test. */
5125 prop
= Fget (test
, Qhash_table_test
);
5126 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5127 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5129 user_test
= XCAR (prop
);
5130 user_hash
= XCAR (XCDR (prop
));
5133 user_test
= user_hash
= Qnil
;
5135 /* See if there's a `:size SIZE' argument. */
5136 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5137 size
= i
< 0 ? Qnil
: args
[i
];
5139 size
= make_number (DEFAULT_HASH_SIZE
);
5140 else if (!INTEGERP (size
) || XINT (size
) < 0)
5142 list2 (build_string ("Invalid hash table size"),
5145 /* Look for `:rehash-size SIZE'. */
5146 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5147 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5148 if (!NUMBERP (rehash_size
)
5149 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5150 || XFLOATINT (rehash_size
) <= 1.0)
5152 list2 (build_string ("Invalid hash table rehash size"),
5155 /* Look for `:rehash-threshold THRESHOLD'. */
5156 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5157 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5158 if (!FLOATP (rehash_threshold
)
5159 || XFLOATINT (rehash_threshold
) <= 0.0
5160 || XFLOATINT (rehash_threshold
) > 1.0)
5162 list2 (build_string ("Invalid hash table rehash threshold"),
5165 /* Look for `:weakness WEAK'. */
5166 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5167 weak
= i
< 0 ? Qnil
: args
[i
];
5169 weak
= Qkey_and_value
;
5172 && !EQ (weak
, Qvalue
)
5173 && !EQ (weak
, Qkey_or_value
)
5174 && !EQ (weak
, Qkey_and_value
))
5175 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5178 /* Now, all args should have been used up, or there's a problem. */
5179 for (i
= 0; i
< nargs
; ++i
)
5182 list2 (build_string ("Invalid argument list"), args
[i
]));
5184 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5185 user_test
, user_hash
);
5189 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5190 doc
: /* Return a copy of hash table TABLE. */)
5194 return copy_hash_table (check_hash_table (table
));
5198 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5199 doc
: /* Return the number of elements in TABLE. */)
5203 return check_hash_table (table
)->count
;
5207 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5208 Shash_table_rehash_size
, 1, 1, 0,
5209 doc
: /* Return the current rehash size of TABLE. */)
5213 return check_hash_table (table
)->rehash_size
;
5217 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5218 Shash_table_rehash_threshold
, 1, 1, 0,
5219 doc
: /* Return the current rehash threshold of TABLE. */)
5223 return check_hash_table (table
)->rehash_threshold
;
5227 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5228 doc
: /* Return the size of TABLE.
5229 The size can be used as an argument to `make-hash-table' to create
5230 a hash table than can hold as many elements of TABLE holds
5231 without need for resizing. */)
5235 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5236 return make_number (HASH_TABLE_SIZE (h
));
5240 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5241 doc
: /* Return the test TABLE uses. */)
5245 return check_hash_table (table
)->test
;
5249 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5251 doc
: /* Return the weakness of TABLE. */)
5255 return check_hash_table (table
)->weak
;
5259 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5260 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5264 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5268 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5269 doc
: /* Clear hash table TABLE. */)
5273 hash_clear (check_hash_table (table
));
5278 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5279 doc
: /* Look up KEY in TABLE and return its associated value.
5280 If KEY is not found, return DFLT which defaults to nil. */)
5282 Lisp_Object key
, table
, dflt
;
5284 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5285 int i
= hash_lookup (h
, key
, NULL
);
5286 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5290 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5291 doc
: /* Associate KEY with VALUE in hash table TABLE.
5292 If KEY is already present in table, replace its current value with
5295 Lisp_Object key
, value
, table
;
5297 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5301 i
= hash_lookup (h
, key
, &hash
);
5303 HASH_VALUE (h
, i
) = value
;
5305 hash_put (h
, key
, value
, hash
);
5311 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5312 doc
: /* Remove KEY from TABLE. */)
5314 Lisp_Object key
, table
;
5316 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5317 hash_remove (h
, key
);
5322 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5323 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5324 FUNCTION is called with 2 arguments KEY and VALUE. */)
5326 Lisp_Object function
, table
;
5328 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5329 Lisp_Object args
[3];
5332 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5333 if (!NILP (HASH_HASH (h
, i
)))
5336 args
[1] = HASH_KEY (h
, i
);
5337 args
[2] = HASH_VALUE (h
, i
);
5345 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5346 Sdefine_hash_table_test
, 3, 3, 0,
5347 doc
: /* Define a new hash table test with name NAME, a symbol.
5349 In hash tables created with NAME specified as test, use TEST to
5350 compare keys, and HASH for computing hash codes of keys.
5352 TEST must be a function taking two arguments and returning non-nil if
5353 both arguments are the same. HASH must be a function taking one
5354 argument and return an integer that is the hash code of the argument.
5355 Hash code computation should use the whole value range of integers,
5356 including negative integers. */)
5358 Lisp_Object name
, test
, hash
;
5360 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5365 /************************************************************************
5367 ************************************************************************/
5372 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5373 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5375 A message digest is a cryptographic checksum of a document, and the
5376 algorithm to calculate it is defined in RFC 1321.
5378 The two optional arguments START and END are character positions
5379 specifying for which part of OBJECT the message digest should be
5380 computed. If nil or omitted, the digest is computed for the whole
5383 The MD5 message digest is computed from the result of encoding the
5384 text in a coding system, not directly from the internal Emacs form of
5385 the text. The optional fourth argument CODING-SYSTEM specifies which
5386 coding system to encode the text with. It should be the same coding
5387 system that you used or will use when actually writing the text into a
5390 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5391 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5392 system would be chosen by default for writing this text into a file.
5394 If OBJECT is a string, the most preferred coding system (see the
5395 command `prefer-coding-system') is used.
5397 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5398 guesswork fails. Normally, an error is signaled in such case. */)
5399 (object
, start
, end
, coding_system
, noerror
)
5400 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5402 unsigned char digest
[16];
5403 unsigned char value
[33];
5407 int start_char
= 0, end_char
= 0;
5408 int start_byte
= 0, end_byte
= 0;
5410 register struct buffer
*bp
;
5413 if (STRINGP (object
))
5415 if (NILP (coding_system
))
5417 /* Decide the coding-system to encode the data with. */
5419 if (STRING_MULTIBYTE (object
))
5420 /* use default, we can't guess correct value */
5421 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5423 coding_system
= Qraw_text
;
5426 if (NILP (Fcoding_system_p (coding_system
)))
5428 /* Invalid coding system. */
5430 if (!NILP (noerror
))
5431 coding_system
= Qraw_text
;
5434 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5437 if (STRING_MULTIBYTE (object
))
5438 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5440 size
= SCHARS (object
);
5441 size_byte
= SBYTES (object
);
5445 CHECK_NUMBER (start
);
5447 start_char
= XINT (start
);
5452 start_byte
= string_char_to_byte (object
, start_char
);
5458 end_byte
= size_byte
;
5464 end_char
= XINT (end
);
5469 end_byte
= string_char_to_byte (object
, end_char
);
5472 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5473 args_out_of_range_3 (object
, make_number (start_char
),
5474 make_number (end_char
));
5478 struct buffer
*prev
= current_buffer
;
5480 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5482 CHECK_BUFFER (object
);
5484 bp
= XBUFFER (object
);
5485 if (bp
!= current_buffer
)
5486 set_buffer_internal (bp
);
5492 CHECK_NUMBER_COERCE_MARKER (start
);
5500 CHECK_NUMBER_COERCE_MARKER (end
);
5505 temp
= b
, b
= e
, e
= temp
;
5507 if (!(BEGV
<= b
&& e
<= ZV
))
5508 args_out_of_range (start
, end
);
5510 if (NILP (coding_system
))
5512 /* Decide the coding-system to encode the data with.
5513 See fileio.c:Fwrite-region */
5515 if (!NILP (Vcoding_system_for_write
))
5516 coding_system
= Vcoding_system_for_write
;
5519 int force_raw_text
= 0;
5521 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5522 if (NILP (coding_system
)
5523 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5525 coding_system
= Qnil
;
5526 if (NILP (current_buffer
->enable_multibyte_characters
))
5530 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5532 /* Check file-coding-system-alist. */
5533 Lisp_Object args
[4], val
;
5535 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5536 args
[3] = Fbuffer_file_name(object
);
5537 val
= Ffind_operation_coding_system (4, args
);
5538 if (CONSP (val
) && !NILP (XCDR (val
)))
5539 coding_system
= XCDR (val
);
5542 if (NILP (coding_system
)
5543 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5545 /* If we still have not decided a coding system, use the
5546 default value of buffer-file-coding-system. */
5547 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5551 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5552 /* Confirm that VAL can surely encode the current region. */
5553 coding_system
= call4 (Vselect_safe_coding_system_function
,
5554 make_number (b
), make_number (e
),
5555 coding_system
, Qnil
);
5558 coding_system
= Qraw_text
;
5561 if (NILP (Fcoding_system_p (coding_system
)))
5563 /* Invalid coding system. */
5565 if (!NILP (noerror
))
5566 coding_system
= Qraw_text
;
5569 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5573 object
= make_buffer_string (b
, e
, 0);
5574 if (prev
!= current_buffer
)
5575 set_buffer_internal (prev
);
5576 /* Discard the unwind protect for recovering the current
5580 if (STRING_MULTIBYTE (object
))
5581 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5584 md5_buffer (SDATA (object
) + start_byte
,
5585 SBYTES (object
) - (size_byte
- end_byte
),
5588 for (i
= 0; i
< 16; i
++)
5589 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5592 return make_string (value
, 32);
5599 /* Hash table stuff. */
5600 Qhash_table_p
= intern ("hash-table-p");
5601 staticpro (&Qhash_table_p
);
5602 Qeq
= intern ("eq");
5604 Qeql
= intern ("eql");
5606 Qequal
= intern ("equal");
5607 staticpro (&Qequal
);
5608 QCtest
= intern (":test");
5609 staticpro (&QCtest
);
5610 QCsize
= intern (":size");
5611 staticpro (&QCsize
);
5612 QCrehash_size
= intern (":rehash-size");
5613 staticpro (&QCrehash_size
);
5614 QCrehash_threshold
= intern (":rehash-threshold");
5615 staticpro (&QCrehash_threshold
);
5616 QCweakness
= intern (":weakness");
5617 staticpro (&QCweakness
);
5618 Qkey
= intern ("key");
5620 Qvalue
= intern ("value");
5621 staticpro (&Qvalue
);
5622 Qhash_table_test
= intern ("hash-table-test");
5623 staticpro (&Qhash_table_test
);
5624 Qkey_or_value
= intern ("key-or-value");
5625 staticpro (&Qkey_or_value
);
5626 Qkey_and_value
= intern ("key-and-value");
5627 staticpro (&Qkey_and_value
);
5630 defsubr (&Smake_hash_table
);
5631 defsubr (&Scopy_hash_table
);
5632 defsubr (&Shash_table_count
);
5633 defsubr (&Shash_table_rehash_size
);
5634 defsubr (&Shash_table_rehash_threshold
);
5635 defsubr (&Shash_table_size
);
5636 defsubr (&Shash_table_test
);
5637 defsubr (&Shash_table_weakness
);
5638 defsubr (&Shash_table_p
);
5639 defsubr (&Sclrhash
);
5640 defsubr (&Sgethash
);
5641 defsubr (&Sputhash
);
5642 defsubr (&Sremhash
);
5643 defsubr (&Smaphash
);
5644 defsubr (&Sdefine_hash_table_test
);
5646 Qstring_lessp
= intern ("string-lessp");
5647 staticpro (&Qstring_lessp
);
5648 Qprovide
= intern ("provide");
5649 staticpro (&Qprovide
);
5650 Qrequire
= intern ("require");
5651 staticpro (&Qrequire
);
5652 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5653 staticpro (&Qyes_or_no_p_history
);
5654 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5655 staticpro (&Qcursor_in_echo_area
);
5656 Qwidget_type
= intern ("widget-type");
5657 staticpro (&Qwidget_type
);
5659 staticpro (&string_char_byte_cache_string
);
5660 string_char_byte_cache_string
= Qnil
;
5662 require_nesting_list
= Qnil
;
5663 staticpro (&require_nesting_list
);
5665 Fset (Qyes_or_no_p_history
, Qnil
);
5667 DEFVAR_LISP ("features", &Vfeatures
,
5668 doc
: /* A list of symbols which are the features of the executing emacs.
5669 Used by `featurep' and `require', and altered by `provide'. */);
5671 Qsubfeatures
= intern ("subfeatures");
5672 staticpro (&Qsubfeatures
);
5674 #ifdef HAVE_LANGINFO_CODESET
5675 Qcodeset
= intern ("codeset");
5676 staticpro (&Qcodeset
);
5677 Qdays
= intern ("days");
5679 Qmonths
= intern ("months");
5680 staticpro (&Qmonths
);
5681 Qpaper
= intern ("paper");
5682 staticpro (&Qpaper
);
5683 #endif /* HAVE_LANGINFO_CODESET */
5685 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5686 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5687 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5688 invoked by mouse clicks and mouse menu items. */);
5691 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5692 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5693 This applies to commands from menus and tool bar buttons. The value of
5694 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5695 used if both `use-dialog-box' and this variable are non-nil. */);
5696 use_file_dialog
= 1;
5698 defsubr (&Sidentity
);
5701 defsubr (&Ssafe_length
);
5702 defsubr (&Sstring_bytes
);
5703 defsubr (&Sstring_equal
);
5704 defsubr (&Scompare_strings
);
5705 defsubr (&Sstring_lessp
);
5708 defsubr (&Svconcat
);
5709 defsubr (&Scopy_sequence
);
5710 defsubr (&Sstring_make_multibyte
);
5711 defsubr (&Sstring_make_unibyte
);
5712 defsubr (&Sstring_as_multibyte
);
5713 defsubr (&Sstring_as_unibyte
);
5714 defsubr (&Sstring_to_multibyte
);
5715 defsubr (&Scopy_alist
);
5716 defsubr (&Ssubstring
);
5717 defsubr (&Ssubstring_no_properties
);
5729 defsubr (&Snreverse
);
5730 defsubr (&Sreverse
);
5732 defsubr (&Splist_get
);
5734 defsubr (&Splist_put
);
5736 defsubr (&Slax_plist_get
);
5737 defsubr (&Slax_plist_put
);
5740 defsubr (&Sequal_including_properties
);
5741 defsubr (&Sfillarray
);
5742 defsubr (&Sclear_string
);
5743 defsubr (&Schar_table_subtype
);
5744 defsubr (&Schar_table_parent
);
5745 defsubr (&Sset_char_table_parent
);
5746 defsubr (&Schar_table_extra_slot
);
5747 defsubr (&Sset_char_table_extra_slot
);
5748 defsubr (&Schar_table_range
);
5749 defsubr (&Sset_char_table_range
);
5750 defsubr (&Sset_char_table_default
);
5751 defsubr (&Soptimize_char_table
);
5752 defsubr (&Smap_char_table
);
5756 defsubr (&Smapconcat
);
5757 defsubr (&Sy_or_n_p
);
5758 defsubr (&Syes_or_no_p
);
5759 defsubr (&Sload_average
);
5760 defsubr (&Sfeaturep
);
5761 defsubr (&Srequire
);
5762 defsubr (&Sprovide
);
5763 defsubr (&Splist_member
);
5764 defsubr (&Swidget_put
);
5765 defsubr (&Swidget_get
);
5766 defsubr (&Swidget_apply
);
5767 defsubr (&Sbase64_encode_region
);
5768 defsubr (&Sbase64_decode_region
);
5769 defsubr (&Sbase64_encode_string
);
5770 defsubr (&Sbase64_decode_string
);
5772 defsubr (&Slocale_info
);
5779 Vweak_hash_tables
= Qnil
;
5782 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5783 (do not change this comment) */