1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 02, 2003
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 28 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
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
518 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
519 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
524 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
525 arg
= wrong_type_argument (Qsequencep
, arg
);
526 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
529 /* In string STR of length LEN, see if bytes before STR[I] combine
530 with bytes after STR[I] to form a single character. If so, return
531 the number of bytes after STR[I] which combine in this way.
532 Otherwize, return 0. */
535 count_combining (str
, len
, i
)
539 int j
= i
- 1, bytes
;
541 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
543 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
544 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
546 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
547 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
550 /* This structure holds information of an argument of `concat' that is
551 a string and has text properties to be copied. */
554 int argnum
; /* refer to ARGS (arguments of `concat') */
555 int from
; /* refer to ARGS[argnum] (argument string) */
556 int to
; /* refer to VAL (the target string) */
560 concat (nargs
, args
, target_type
, last_special
)
563 enum Lisp_Type target_type
;
567 register Lisp_Object tail
;
568 register Lisp_Object
this;
570 int toindex_byte
= 0;
571 register int result_len
;
572 register int result_len_byte
;
574 Lisp_Object last_tail
;
577 /* When we make a multibyte string, we can't copy text properties
578 while concatinating each string because the length of resulting
579 string can't be decided until we finish the whole concatination.
580 So, we record strings that have text properties to be copied
581 here, and copy the text properties after the concatination. */
582 struct textprop_rec
*textprops
= NULL
;
583 /* Number of elments in textprops. */
584 int num_textprops
= 0;
588 /* In append, the last arg isn't treated like the others */
589 if (last_special
&& nargs
> 0)
592 last_tail
= args
[nargs
];
597 /* Canonicalize each argument. */
598 for (argnum
= 0; argnum
< nargs
; argnum
++)
601 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
602 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
604 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
608 /* Compute total length in chars of arguments in RESULT_LEN.
609 If desired output is a string, also compute length in bytes
610 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
611 whether the result should be a multibyte string. */
615 for (argnum
= 0; argnum
< nargs
; argnum
++)
619 len
= XFASTINT (Flength (this));
620 if (target_type
== Lisp_String
)
622 /* We must count the number of bytes needed in the string
623 as well as the number of characters. */
629 for (i
= 0; i
< len
; i
++)
631 ch
= XVECTOR (this)->contents
[i
];
633 wrong_type_argument (Qintegerp
, ch
);
634 this_len_byte
= CHAR_BYTES (XINT (ch
));
635 result_len_byte
+= this_len_byte
;
636 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
639 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
640 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
641 else if (CONSP (this))
642 for (; CONSP (this); this = XCDR (this))
646 wrong_type_argument (Qintegerp
, ch
);
647 this_len_byte
= CHAR_BYTES (XINT (ch
));
648 result_len_byte
+= this_len_byte
;
649 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
652 else if (STRINGP (this))
654 if (STRING_MULTIBYTE (this))
657 result_len_byte
+= SBYTES (this);
660 result_len_byte
+= count_size_as_multibyte (SDATA (this),
668 if (! some_multibyte
)
669 result_len_byte
= result_len
;
671 /* Create the output object. */
672 if (target_type
== Lisp_Cons
)
673 val
= Fmake_list (make_number (result_len
), Qnil
);
674 else if (target_type
== Lisp_Vectorlike
)
675 val
= Fmake_vector (make_number (result_len
), Qnil
);
676 else if (some_multibyte
)
677 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
679 val
= make_uninit_string (result_len
);
681 /* In `append', if all but last arg are nil, return last arg. */
682 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
685 /* Copy the contents of the args into the result. */
687 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
689 toindex
= 0, toindex_byte
= 0;
694 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
696 for (argnum
= 0; argnum
< nargs
; argnum
++)
700 register unsigned int thisindex
= 0;
701 register unsigned int thisindex_byte
= 0;
705 thislen
= Flength (this), thisleni
= XINT (thislen
);
707 /* Between strings of the same kind, copy fast. */
708 if (STRINGP (this) && STRINGP (val
)
709 && STRING_MULTIBYTE (this) == some_multibyte
)
711 int thislen_byte
= SBYTES (this);
714 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
716 combined
= (some_multibyte
&& toindex_byte
> 0
717 ? count_combining (SDATA (val
),
718 toindex_byte
+ thislen_byte
,
721 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
723 textprops
[num_textprops
].argnum
= argnum
;
724 /* We ignore text properties on characters being combined. */
725 textprops
[num_textprops
].from
= combined
;
726 textprops
[num_textprops
++].to
= toindex
;
728 toindex_byte
+= thislen_byte
;
729 toindex
+= thisleni
- combined
;
730 STRING_SET_CHARS (val
, SCHARS (val
) - combined
);
732 /* Copy a single-byte string to a multibyte string. */
733 else if (STRINGP (this) && STRINGP (val
))
735 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
737 textprops
[num_textprops
].argnum
= argnum
;
738 textprops
[num_textprops
].from
= 0;
739 textprops
[num_textprops
++].to
= toindex
;
741 toindex_byte
+= copy_text (SDATA (this),
742 SDATA (val
) + toindex_byte
,
743 SCHARS (this), 0, 1);
747 /* Copy element by element. */
750 register Lisp_Object elt
;
752 /* Fetch next element of `this' arg into `elt', or break if
753 `this' is exhausted. */
754 if (NILP (this)) break;
756 elt
= XCAR (this), this = XCDR (this);
757 else if (thisindex
>= thisleni
)
759 else if (STRINGP (this))
762 if (STRING_MULTIBYTE (this))
764 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
767 XSETFASTINT (elt
, c
);
771 XSETFASTINT (elt
, SREF (this, thisindex
++));
773 && (XINT (elt
) >= 0240
774 || (XINT (elt
) >= 0200
775 && ! NILP (Vnonascii_translation_table
)))
776 && XINT (elt
) < 0400)
778 c
= unibyte_char_to_multibyte (XINT (elt
));
783 else if (BOOL_VECTOR_P (this))
786 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
787 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
794 elt
= XVECTOR (this)->contents
[thisindex
++];
796 /* Store this element into the result. */
803 else if (VECTORP (val
))
804 XVECTOR (val
)->contents
[toindex
++] = elt
;
808 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
812 += CHAR_STRING (XINT (elt
),
813 SDATA (val
) + toindex_byte
);
815 SSET (val
, toindex_byte
++, XINT (elt
));
818 && count_combining (SDATA (val
),
819 toindex_byte
, toindex_byte
- 1))
820 STRING_SET_CHARS (val
, SCHARS (val
) - 1);
825 /* If we have any multibyte characters,
826 we already decided to make a multibyte string. */
829 /* P exists as a variable
830 to avoid a bug on the Masscomp C compiler. */
831 unsigned char *p
= SDATA (val
) + toindex_byte
;
833 toindex_byte
+= CHAR_STRING (c
, p
);
840 XSETCDR (prev
, last_tail
);
842 if (num_textprops
> 0)
845 int last_to_end
= -1;
847 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
849 this = args
[textprops
[argnum
].argnum
];
850 props
= text_property_list (this,
852 make_number (SCHARS (this)),
854 /* If successive arguments have properites, be sure that the
855 value of `composition' property be the copy. */
856 if (last_to_end
== textprops
[argnum
].to
)
857 make_composition_value_copy (props
);
858 add_text_properties_from_list (val
, props
,
859 make_number (textprops
[argnum
].to
));
860 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
866 static Lisp_Object string_char_byte_cache_string
;
867 static int string_char_byte_cache_charpos
;
868 static int string_char_byte_cache_bytepos
;
871 clear_string_char_byte_cache ()
873 string_char_byte_cache_string
= Qnil
;
876 /* Return the character index corresponding to CHAR_INDEX in STRING. */
879 string_char_to_byte (string
, char_index
)
884 int best_below
, best_below_byte
;
885 int best_above
, best_above_byte
;
887 if (! STRING_MULTIBYTE (string
))
890 best_below
= best_below_byte
= 0;
891 best_above
= SCHARS (string
);
892 best_above_byte
= SBYTES (string
);
894 if (EQ (string
, string_char_byte_cache_string
))
896 if (string_char_byte_cache_charpos
< char_index
)
898 best_below
= string_char_byte_cache_charpos
;
899 best_below_byte
= string_char_byte_cache_bytepos
;
903 best_above
= string_char_byte_cache_charpos
;
904 best_above_byte
= string_char_byte_cache_bytepos
;
908 if (char_index
- best_below
< best_above
- char_index
)
910 while (best_below
< char_index
)
913 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
914 best_below
, best_below_byte
);
917 i_byte
= best_below_byte
;
921 while (best_above
> char_index
)
923 unsigned char *pend
= SDATA (string
) + best_above_byte
;
924 unsigned char *pbeg
= pend
- best_above_byte
;
925 unsigned char *p
= pend
- 1;
928 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
929 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
930 if (bytes
== pend
- p
)
931 best_above_byte
-= bytes
;
932 else if (bytes
> pend
- p
)
933 best_above_byte
-= (pend
- p
);
939 i_byte
= best_above_byte
;
942 string_char_byte_cache_bytepos
= i_byte
;
943 string_char_byte_cache_charpos
= i
;
944 string_char_byte_cache_string
= string
;
949 /* Return the character index corresponding to BYTE_INDEX in STRING. */
952 string_byte_to_char (string
, byte_index
)
957 int best_below
, best_below_byte
;
958 int best_above
, best_above_byte
;
960 if (! STRING_MULTIBYTE (string
))
963 best_below
= best_below_byte
= 0;
964 best_above
= SCHARS (string
);
965 best_above_byte
= SBYTES (string
);
967 if (EQ (string
, string_char_byte_cache_string
))
969 if (string_char_byte_cache_bytepos
< byte_index
)
971 best_below
= string_char_byte_cache_charpos
;
972 best_below_byte
= string_char_byte_cache_bytepos
;
976 best_above
= string_char_byte_cache_charpos
;
977 best_above_byte
= string_char_byte_cache_bytepos
;
981 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
983 while (best_below_byte
< byte_index
)
986 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
987 best_below
, best_below_byte
);
990 i_byte
= best_below_byte
;
994 while (best_above_byte
> byte_index
)
996 unsigned char *pend
= SDATA (string
) + best_above_byte
;
997 unsigned char *pbeg
= pend
- best_above_byte
;
998 unsigned char *p
= pend
- 1;
1001 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
1002 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
1003 if (bytes
== pend
- p
)
1004 best_above_byte
-= bytes
;
1005 else if (bytes
> pend
- p
)
1006 best_above_byte
-= (pend
- p
);
1012 i_byte
= best_above_byte
;
1015 string_char_byte_cache_bytepos
= i_byte
;
1016 string_char_byte_cache_charpos
= i
;
1017 string_char_byte_cache_string
= string
;
1022 /* Convert STRING to a multibyte string.
1023 Single-byte characters 0240 through 0377 are converted
1024 by adding nonascii_insert_offset to each. */
1027 string_make_multibyte (string
)
1033 if (STRING_MULTIBYTE (string
))
1036 nbytes
= count_size_as_multibyte (SDATA (string
),
1038 /* If all the chars are ASCII, they won't need any more bytes
1039 once converted. In that case, we can return STRING itself. */
1040 if (nbytes
== SBYTES (string
))
1043 buf
= (unsigned char *) alloca (nbytes
);
1044 copy_text (SDATA (string
), buf
, SBYTES (string
),
1047 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1051 /* Convert STRING to a multibyte string without changing each
1052 character codes. Thus, characters 0200 trough 0237 are converted
1053 to eight-bit-control characters, and characters 0240 through 0377
1054 are converted eight-bit-graphic characters. */
1057 string_to_multibyte (string
)
1063 if (STRING_MULTIBYTE (string
))
1066 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1067 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1068 any more bytes once converted. */
1069 if (nbytes
== SBYTES (string
))
1070 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1072 buf
= (unsigned char *) alloca (nbytes
);
1073 bcopy (SDATA (string
), buf
, SBYTES (string
));
1074 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1076 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1080 /* Convert STRING to a single-byte string. */
1083 string_make_unibyte (string
)
1088 if (! STRING_MULTIBYTE (string
))
1091 buf
= (unsigned char *) alloca (SCHARS (string
));
1093 copy_text (SDATA (string
), buf
, SBYTES (string
),
1096 return make_unibyte_string (buf
, SCHARS (string
));
1099 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1101 doc
: /* Return the multibyte equivalent of STRING.
1102 The function `unibyte-char-to-multibyte' is used to convert
1103 each unibyte character to a multibyte character. */)
1107 CHECK_STRING (string
);
1109 return string_make_multibyte (string
);
1112 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1114 doc
: /* Return the unibyte equivalent of STRING.
1115 Multibyte character codes are converted to unibyte according to
1116 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1117 If the lookup in the translation table fails, this function takes just
1118 the low 8 bits of each character. */)
1122 CHECK_STRING (string
);
1124 return string_make_unibyte (string
);
1127 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1129 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1130 If STRING is unibyte, the result is STRING itself.
1131 Otherwise it is a newly created string, with no text properties.
1132 If STRING is multibyte and contains a character of charset
1133 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1134 corresponding single byte. */)
1138 CHECK_STRING (string
);
1140 if (STRING_MULTIBYTE (string
))
1142 int bytes
= SBYTES (string
);
1143 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1145 bcopy (SDATA (string
), str
, bytes
);
1146 bytes
= str_as_unibyte (str
, bytes
);
1147 string
= make_unibyte_string (str
, bytes
);
1153 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1155 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1156 If STRING is multibyte, the result is STRING itself.
1157 Otherwise it is a newly created string, with no text properties.
1158 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1159 part of a multibyte form), it is converted to the corresponding
1160 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1164 CHECK_STRING (string
);
1166 if (! STRING_MULTIBYTE (string
))
1168 Lisp_Object new_string
;
1171 parse_str_as_multibyte (SDATA (string
),
1174 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1175 bcopy (SDATA (string
), SDATA (new_string
),
1177 if (nbytes
!= SBYTES (string
))
1178 str_as_multibyte (SDATA (new_string
), nbytes
,
1179 SBYTES (string
), NULL
);
1180 string
= new_string
;
1181 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1186 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1188 doc
: /* Return a multibyte string with the same individual chars as STRING.
1189 If STRING is multibyte, the result is STRING itself.
1190 Otherwise it is a newly created string, with no text properties.
1191 Characters 0200 through 0237 are converted to eight-bit-control
1192 characters of the same character code. Characters 0240 through 0377
1193 are converted to eight-bit-graphic characters of the same character
1198 CHECK_STRING (string
);
1200 return string_to_multibyte (string
);
1204 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1205 doc
: /* Return a copy of ALIST.
1206 This is an alist which represents the same mapping from objects to objects,
1207 but does not share the alist structure with ALIST.
1208 The objects mapped (cars and cdrs of elements of the alist)
1209 are shared, however.
1210 Elements of ALIST that are not conses are also shared. */)
1214 register Lisp_Object tem
;
1219 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1220 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1222 register Lisp_Object car
;
1226 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1231 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1232 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1233 TO may be nil or omitted; then the substring runs to the end of STRING.
1234 FROM and TO start at 0. If either is negative, it counts from the end.
1236 This function allows vectors as well as strings. */)
1239 register Lisp_Object from
, to
;
1244 int from_char
, to_char
;
1245 int from_byte
= 0, to_byte
= 0;
1247 if (! (STRINGP (string
) || VECTORP (string
)))
1248 wrong_type_argument (Qarrayp
, string
);
1250 CHECK_NUMBER (from
);
1252 if (STRINGP (string
))
1254 size
= SCHARS (string
);
1255 size_byte
= SBYTES (string
);
1258 size
= XVECTOR (string
)->size
;
1263 to_byte
= size_byte
;
1269 to_char
= XINT (to
);
1273 if (STRINGP (string
))
1274 to_byte
= string_char_to_byte (string
, to_char
);
1277 from_char
= XINT (from
);
1280 if (STRINGP (string
))
1281 from_byte
= string_char_to_byte (string
, from_char
);
1283 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1284 args_out_of_range_3 (string
, make_number (from_char
),
1285 make_number (to_char
));
1287 if (STRINGP (string
))
1289 res
= make_specified_string (SDATA (string
) + from_byte
,
1290 to_char
- from_char
, to_byte
- from_byte
,
1291 STRING_MULTIBYTE (string
));
1292 copy_text_properties (make_number (from_char
), make_number (to_char
),
1293 string
, make_number (0), res
, Qnil
);
1296 res
= Fvector (to_char
- from_char
,
1297 XVECTOR (string
)->contents
+ from_char
);
1303 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1304 doc
: /* Return a substring of STRING, without text properties.
1305 It starts at index FROM and ending before TO.
1306 TO may be nil or omitted; then the substring runs to the end of STRING.
1307 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1308 If FROM or TO is negative, it counts from the end.
1310 With one argument, just copy STRING without its properties. */)
1313 register Lisp_Object from
, to
;
1315 int size
, size_byte
;
1316 int from_char
, to_char
;
1317 int from_byte
, to_byte
;
1319 CHECK_STRING (string
);
1321 size
= SCHARS (string
);
1322 size_byte
= SBYTES (string
);
1325 from_char
= from_byte
= 0;
1328 CHECK_NUMBER (from
);
1329 from_char
= XINT (from
);
1333 from_byte
= string_char_to_byte (string
, from_char
);
1339 to_byte
= size_byte
;
1345 to_char
= XINT (to
);
1349 to_byte
= string_char_to_byte (string
, to_char
);
1352 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1353 args_out_of_range_3 (string
, make_number (from_char
),
1354 make_number (to_char
));
1356 return make_specified_string (SDATA (string
) + from_byte
,
1357 to_char
- from_char
, to_byte
- from_byte
,
1358 STRING_MULTIBYTE (string
));
1361 /* Extract a substring of STRING, giving start and end positions
1362 both in characters and in bytes. */
1365 substring_both (string
, from
, from_byte
, to
, to_byte
)
1367 int from
, from_byte
, to
, to_byte
;
1373 if (! (STRINGP (string
) || VECTORP (string
)))
1374 wrong_type_argument (Qarrayp
, string
);
1376 if (STRINGP (string
))
1378 size
= SCHARS (string
);
1379 size_byte
= SBYTES (string
);
1382 size
= XVECTOR (string
)->size
;
1384 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1385 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1387 if (STRINGP (string
))
1389 res
= make_specified_string (SDATA (string
) + from_byte
,
1390 to
- from
, to_byte
- from_byte
,
1391 STRING_MULTIBYTE (string
));
1392 copy_text_properties (make_number (from
), make_number (to
),
1393 string
, make_number (0), res
, Qnil
);
1396 res
= Fvector (to
- from
,
1397 XVECTOR (string
)->contents
+ from
);
1402 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1403 doc
: /* Take cdr N times on LIST, returns the result. */)
1406 register Lisp_Object list
;
1408 register int i
, num
;
1411 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1415 wrong_type_argument (Qlistp
, list
);
1421 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1422 doc
: /* Return the Nth element of LIST.
1423 N counts from zero. If LIST is not that long, nil is returned. */)
1425 Lisp_Object n
, list
;
1427 return Fcar (Fnthcdr (n
, list
));
1430 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1431 doc
: /* Return element of SEQUENCE at index N. */)
1433 register Lisp_Object sequence
, n
;
1438 if (CONSP (sequence
) || NILP (sequence
))
1439 return Fcar (Fnthcdr (n
, sequence
));
1440 else if (STRINGP (sequence
) || VECTORP (sequence
)
1441 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1442 return Faref (sequence
, n
);
1444 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1448 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1449 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1450 The value is actually the tail of LIST whose car is ELT. */)
1452 register Lisp_Object elt
;
1455 register Lisp_Object tail
;
1456 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1458 register Lisp_Object tem
;
1460 wrong_type_argument (Qlistp
, list
);
1462 if (! NILP (Fequal (elt
, tem
)))
1469 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1470 doc
: /* Return non-nil if ELT is an element of LIST.
1471 Comparison done with EQ. The value is actually the tail of LIST
1472 whose car is ELT. */)
1474 Lisp_Object elt
, list
;
1478 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1482 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1486 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1493 if (!CONSP (list
) && !NILP (list
))
1494 list
= wrong_type_argument (Qlistp
, list
);
1499 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1500 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1501 The value is actually the first element of LIST whose car is KEY.
1502 Elements of LIST that are not conses are ignored. */)
1504 Lisp_Object key
, list
;
1511 || (CONSP (XCAR (list
))
1512 && EQ (XCAR (XCAR (list
)), key
)))
1517 || (CONSP (XCAR (list
))
1518 && EQ (XCAR (XCAR (list
)), key
)))
1523 || (CONSP (XCAR (list
))
1524 && EQ (XCAR (XCAR (list
)), key
)))
1532 result
= XCAR (list
);
1533 else if (NILP (list
))
1536 result
= wrong_type_argument (Qlistp
, list
);
1541 /* Like Fassq but never report an error and do not allow quits.
1542 Use only on lists known never to be circular. */
1545 assq_no_quit (key
, list
)
1546 Lisp_Object key
, list
;
1549 && (!CONSP (XCAR (list
))
1550 || !EQ (XCAR (XCAR (list
)), key
)))
1553 return CONSP (list
) ? XCAR (list
) : Qnil
;
1556 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1557 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1558 The value is actually the first element of LIST whose car equals KEY. */)
1560 Lisp_Object key
, list
;
1562 Lisp_Object result
, car
;
1567 || (CONSP (XCAR (list
))
1568 && (car
= XCAR (XCAR (list
)),
1569 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1574 || (CONSP (XCAR (list
))
1575 && (car
= XCAR (XCAR (list
)),
1576 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1581 || (CONSP (XCAR (list
))
1582 && (car
= XCAR (XCAR (list
)),
1583 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1591 result
= XCAR (list
);
1592 else if (NILP (list
))
1595 result
= wrong_type_argument (Qlistp
, list
);
1600 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1601 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1602 The value is actually the first element of LIST whose cdr is KEY. */)
1604 register Lisp_Object key
;
1612 || (CONSP (XCAR (list
))
1613 && EQ (XCDR (XCAR (list
)), key
)))
1618 || (CONSP (XCAR (list
))
1619 && EQ (XCDR (XCAR (list
)), key
)))
1624 || (CONSP (XCAR (list
))
1625 && EQ (XCDR (XCAR (list
)), key
)))
1634 else if (CONSP (list
))
1635 result
= XCAR (list
);
1637 result
= wrong_type_argument (Qlistp
, list
);
1642 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1643 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1644 The value is actually the first element of LIST whose cdr equals KEY. */)
1646 Lisp_Object key
, list
;
1648 Lisp_Object result
, cdr
;
1653 || (CONSP (XCAR (list
))
1654 && (cdr
= XCDR (XCAR (list
)),
1655 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1660 || (CONSP (XCAR (list
))
1661 && (cdr
= XCDR (XCAR (list
)),
1662 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1667 || (CONSP (XCAR (list
))
1668 && (cdr
= XCDR (XCAR (list
)),
1669 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1677 result
= XCAR (list
);
1678 else if (NILP (list
))
1681 result
= wrong_type_argument (Qlistp
, list
);
1686 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1687 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1688 The modified LIST is returned. Comparison is done with `eq'.
1689 If the first member of LIST is ELT, there is no way to remove it by side effect;
1690 therefore, write `(setq foo (delq element foo))'
1691 to be sure of changing the value of `foo'. */)
1693 register Lisp_Object elt
;
1696 register Lisp_Object tail
, prev
;
1697 register Lisp_Object tem
;
1701 while (!NILP (tail
))
1704 wrong_type_argument (Qlistp
, list
);
1711 Fsetcdr (prev
, XCDR (tail
));
1721 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1722 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1723 SEQ must be a list, a vector, or a string.
1724 The modified SEQ is returned. Comparison is done with `equal'.
1725 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1726 is not a side effect; it is simply using a different sequence.
1727 Therefore, write `(setq foo (delete element foo))'
1728 to be sure of changing the value of `foo'. */)
1730 Lisp_Object elt
, seq
;
1736 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1737 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1740 if (n
!= ASIZE (seq
))
1742 struct Lisp_Vector
*p
= allocate_vector (n
);
1744 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1745 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1746 p
->contents
[n
++] = AREF (seq
, i
);
1748 XSETVECTOR (seq
, p
);
1751 else if (STRINGP (seq
))
1753 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1756 for (i
= nchars
= nbytes
= ibyte
= 0;
1758 ++i
, ibyte
+= cbytes
)
1760 if (STRING_MULTIBYTE (seq
))
1762 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1763 SBYTES (seq
) - ibyte
);
1764 cbytes
= CHAR_BYTES (c
);
1772 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1779 if (nchars
!= SCHARS (seq
))
1783 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1784 if (!STRING_MULTIBYTE (seq
))
1785 STRING_SET_UNIBYTE (tem
);
1787 for (i
= nchars
= nbytes
= ibyte
= 0;
1789 ++i
, ibyte
+= cbytes
)
1791 if (STRING_MULTIBYTE (seq
))
1793 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1794 SBYTES (seq
) - ibyte
);
1795 cbytes
= CHAR_BYTES (c
);
1803 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1805 unsigned char *from
= SDATA (seq
) + ibyte
;
1806 unsigned char *to
= SDATA (tem
) + nbytes
;
1812 for (n
= cbytes
; n
--; )
1822 Lisp_Object tail
, prev
;
1824 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1827 wrong_type_argument (Qlistp
, seq
);
1829 if (!NILP (Fequal (elt
, XCAR (tail
))))
1834 Fsetcdr (prev
, XCDR (tail
));
1845 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1846 doc
: /* Reverse LIST by modifying cdr pointers.
1847 Return the reversed list. */)
1851 register Lisp_Object prev
, tail
, next
;
1853 if (NILP (list
)) return list
;
1856 while (!NILP (tail
))
1860 wrong_type_argument (Qlistp
, list
);
1862 Fsetcdr (tail
, prev
);
1869 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1870 doc
: /* Reverse LIST, copying. Return the reversed list.
1871 See also the function `nreverse', which is used more often. */)
1877 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1880 new = Fcons (XCAR (list
), new);
1883 wrong_type_argument (Qconsp
, list
);
1887 Lisp_Object
merge ();
1889 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1890 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1891 Returns the sorted list. LIST is modified by side effects.
1892 PREDICATE is called with two elements of LIST, and should return t
1893 if the first element is "less" than the second. */)
1895 Lisp_Object list
, predicate
;
1897 Lisp_Object front
, back
;
1898 register Lisp_Object len
, tem
;
1899 struct gcpro gcpro1
, gcpro2
;
1900 register int length
;
1903 len
= Flength (list
);
1904 length
= XINT (len
);
1908 XSETINT (len
, (length
/ 2) - 1);
1909 tem
= Fnthcdr (len
, list
);
1911 Fsetcdr (tem
, Qnil
);
1913 GCPRO2 (front
, back
);
1914 front
= Fsort (front
, predicate
);
1915 back
= Fsort (back
, predicate
);
1917 return merge (front
, back
, predicate
);
1921 merge (org_l1
, org_l2
, pred
)
1922 Lisp_Object org_l1
, org_l2
;
1926 register Lisp_Object tail
;
1928 register Lisp_Object l1
, l2
;
1929 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1936 /* It is sufficient to protect org_l1 and org_l2.
1937 When l1 and l2 are updated, we copy the new values
1938 back into the org_ vars. */
1939 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1959 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1975 Fsetcdr (tail
, tem
);
1981 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1982 doc
: /* Extract a value from a property list.
1983 PLIST is a property list, which is a list of the form
1984 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1985 corresponding to the given PROP, or nil if PROP is not
1986 one of the properties on the list. */)
1994 CONSP (tail
) && CONSP (XCDR (tail
));
1995 tail
= XCDR (XCDR (tail
)))
1997 if (EQ (prop
, XCAR (tail
)))
1998 return XCAR (XCDR (tail
));
2000 /* This function can be called asynchronously
2001 (setup_coding_system). Don't QUIT in that case. */
2002 if (!interrupt_input_blocked
)
2007 wrong_type_argument (Qlistp
, prop
);
2012 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2013 doc
: /* Return the value of SYMBOL's PROPNAME property.
2014 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2016 Lisp_Object symbol
, propname
;
2018 CHECK_SYMBOL (symbol
);
2019 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2022 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2023 doc
: /* Change value in PLIST of PROP to VAL.
2024 PLIST is a property list, which is a list of the form
2025 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2026 If PROP is already a property on the list, its value is set to VAL,
2027 otherwise the new PROP VAL pair is added. The new plist is returned;
2028 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2029 The PLIST is modified by side effects. */)
2032 register Lisp_Object prop
;
2035 register Lisp_Object tail
, prev
;
2036 Lisp_Object newcell
;
2038 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2039 tail
= XCDR (XCDR (tail
)))
2041 if (EQ (prop
, XCAR (tail
)))
2043 Fsetcar (XCDR (tail
), val
);
2050 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2054 Fsetcdr (XCDR (prev
), newcell
);
2058 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2059 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2060 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2061 (symbol
, propname
, value
)
2062 Lisp_Object symbol
, propname
, value
;
2064 CHECK_SYMBOL (symbol
);
2065 XSYMBOL (symbol
)->plist
2066 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2070 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2071 doc
: /* Extract a value from a property list, comparing with `equal'.
2072 PLIST is a property list, which is a list of the form
2073 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2074 corresponding to the given PROP, or nil if PROP is not
2075 one of the properties on the list. */)
2083 CONSP (tail
) && CONSP (XCDR (tail
));
2084 tail
= XCDR (XCDR (tail
)))
2086 if (! NILP (Fequal (prop
, XCAR (tail
))))
2087 return XCAR (XCDR (tail
));
2093 wrong_type_argument (Qlistp
, prop
);
2098 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2099 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2100 PLIST is a property list, which is a list of the form
2101 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2102 If PROP is already a property on the list, its value is set to VAL,
2103 otherwise the new PROP VAL pair is added. The new plist is returned;
2104 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2105 The PLIST is modified by side effects. */)
2108 register Lisp_Object prop
;
2111 register Lisp_Object tail
, prev
;
2112 Lisp_Object newcell
;
2114 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2115 tail
= XCDR (XCDR (tail
)))
2117 if (! NILP (Fequal (prop
, XCAR (tail
))))
2119 Fsetcar (XCDR (tail
), val
);
2126 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2130 Fsetcdr (XCDR (prev
), newcell
);
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) ? Qt
: Qnil
;
2149 internal_equal (o1
, o2
, depth
)
2150 register Lisp_Object o1
, o2
;
2154 error ("Stack overflow in equal");
2160 if (XTYPE (o1
) != XTYPE (o2
))
2166 return (extract_float (o1
) == extract_float (o2
));
2169 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2176 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2180 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2182 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2185 o1
= XOVERLAY (o1
)->plist
;
2186 o2
= XOVERLAY (o2
)->plist
;
2191 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2192 && (XMARKER (o1
)->buffer
== 0
2193 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2197 case Lisp_Vectorlike
:
2200 EMACS_INT size
= XVECTOR (o1
)->size
;
2201 /* Pseudovectors have the type encoded in the size field, so this test
2202 actually checks that the objects have the same type as well as the
2204 if (XVECTOR (o2
)->size
!= size
)
2206 /* Boolvectors are compared much like strings. */
2207 if (BOOL_VECTOR_P (o1
))
2210 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2212 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2214 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2219 if (WINDOW_CONFIGURATIONP (o1
))
2220 return compare_window_configurations (o1
, o2
, 0);
2222 /* Aside from them, only true vectors, char-tables, and compiled
2223 functions are sensible to compare, so eliminate the others now. */
2224 if (size
& PSEUDOVECTOR_FLAG
)
2226 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2228 size
&= PSEUDOVECTOR_SIZE_MASK
;
2230 for (i
= 0; i
< size
; i
++)
2233 v1
= XVECTOR (o1
)->contents
[i
];
2234 v2
= XVECTOR (o2
)->contents
[i
];
2235 if (!internal_equal (v1
, v2
, depth
+ 1))
2243 if (SCHARS (o1
) != SCHARS (o2
))
2245 if (SBYTES (o1
) != SBYTES (o2
))
2247 if (bcmp (SDATA (o1
), SDATA (o2
),
2254 case Lisp_Type_Limit
:
2261 extern Lisp_Object
Fmake_char_internal ();
2263 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2264 doc
: /* Store each element of ARRAY with ITEM.
2265 ARRAY is a vector, string, char-table, or bool-vector. */)
2267 Lisp_Object array
, item
;
2269 register int size
, index
, charval
;
2271 if (VECTORP (array
))
2273 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2274 size
= XVECTOR (array
)->size
;
2275 for (index
= 0; index
< size
; index
++)
2278 else if (CHAR_TABLE_P (array
))
2280 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2281 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2282 for (index
= 0; index
< size
; index
++)
2284 XCHAR_TABLE (array
)->defalt
= Qnil
;
2286 else if (STRINGP (array
))
2288 register unsigned char *p
= SDATA (array
);
2289 CHECK_NUMBER (item
);
2290 charval
= XINT (item
);
2291 size
= SCHARS (array
);
2292 if (STRING_MULTIBYTE (array
))
2294 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2295 int len
= CHAR_STRING (charval
, str
);
2296 int size_byte
= SBYTES (array
);
2297 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2300 if (size
!= size_byte
)
2303 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2304 if (len
!= this_len
)
2305 error ("Attempt to change byte length of a string");
2308 for (i
= 0; i
< size_byte
; i
++)
2309 *p
++ = str
[i
% len
];
2312 for (index
= 0; index
< size
; index
++)
2315 else if (BOOL_VECTOR_P (array
))
2317 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2319 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2321 charval
= (! NILP (item
) ? -1 : 0);
2322 for (index
= 0; index
< size_in_chars
- 1; index
++)
2324 if (index
< size_in_chars
)
2326 /* Mask out bits beyond the vector size. */
2327 if (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)
2328 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)) - 1;
2334 array
= wrong_type_argument (Qarrayp
, array
);
2340 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2342 doc
: /* Clear the contents of STRING.
2343 This makes STRING unibyte and may change its length. */)
2347 int len
= SBYTES (string
);
2348 bzero (SDATA (string
), len
);
2349 STRING_SET_CHARS (string
, len
);
2350 STRING_SET_UNIBYTE (string
);
2354 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2356 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2358 Lisp_Object char_table
;
2360 CHECK_CHAR_TABLE (char_table
);
2362 return XCHAR_TABLE (char_table
)->purpose
;
2365 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2367 doc
: /* Return the parent char-table of CHAR-TABLE.
2368 The value is either nil or another char-table.
2369 If CHAR-TABLE holds nil for a given character,
2370 then the actual applicable value is inherited from the parent char-table
2371 \(or from its parents, if necessary). */)
2373 Lisp_Object char_table
;
2375 CHECK_CHAR_TABLE (char_table
);
2377 return XCHAR_TABLE (char_table
)->parent
;
2380 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2382 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2383 Return PARENT. PARENT must be either nil or another char-table. */)
2384 (char_table
, parent
)
2385 Lisp_Object char_table
, parent
;
2389 CHECK_CHAR_TABLE (char_table
);
2393 CHECK_CHAR_TABLE (parent
);
2395 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2396 if (EQ (temp
, char_table
))
2397 error ("Attempt to make a chartable be its own parent");
2400 XCHAR_TABLE (char_table
)->parent
= parent
;
2405 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2407 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2409 Lisp_Object char_table
, n
;
2411 CHECK_CHAR_TABLE (char_table
);
2414 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2415 args_out_of_range (char_table
, n
);
2417 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2420 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2421 Sset_char_table_extra_slot
,
2423 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2424 (char_table
, n
, value
)
2425 Lisp_Object char_table
, n
, value
;
2427 CHECK_CHAR_TABLE (char_table
);
2430 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2431 args_out_of_range (char_table
, n
);
2433 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2436 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2438 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2439 RANGE should be nil (for the default value)
2440 a vector which identifies a character set or a row of a character set,
2441 a character set name, or a character code. */)
2443 Lisp_Object char_table
, range
;
2445 CHECK_CHAR_TABLE (char_table
);
2447 if (EQ (range
, Qnil
))
2448 return XCHAR_TABLE (char_table
)->defalt
;
2449 else if (INTEGERP (range
))
2450 return Faref (char_table
, range
);
2451 else if (SYMBOLP (range
))
2453 Lisp_Object charset_info
;
2455 charset_info
= Fget (range
, Qcharset
);
2456 CHECK_VECTOR (charset_info
);
2458 return Faref (char_table
,
2459 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2462 else if (VECTORP (range
))
2464 if (XVECTOR (range
)->size
== 1)
2465 return Faref (char_table
,
2466 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2469 int size
= XVECTOR (range
)->size
;
2470 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2471 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2472 size
<= 1 ? Qnil
: val
[1],
2473 size
<= 2 ? Qnil
: val
[2]);
2474 return Faref (char_table
, ch
);
2478 error ("Invalid RANGE argument to `char-table-range'");
2482 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2484 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2485 RANGE should be t (for all characters), nil (for the default value)
2486 a vector which identifies a character set or a row of a character set,
2487 a coding system, or a character code. */)
2488 (char_table
, range
, value
)
2489 Lisp_Object char_table
, range
, value
;
2493 CHECK_CHAR_TABLE (char_table
);
2496 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2497 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2498 else if (EQ (range
, Qnil
))
2499 XCHAR_TABLE (char_table
)->defalt
= value
;
2500 else if (SYMBOLP (range
))
2502 Lisp_Object charset_info
;
2504 charset_info
= Fget (range
, Qcharset
);
2505 CHECK_VECTOR (charset_info
);
2507 return Faset (char_table
,
2508 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2512 else if (INTEGERP (range
))
2513 Faset (char_table
, range
, value
);
2514 else if (VECTORP (range
))
2516 if (XVECTOR (range
)->size
== 1)
2517 return Faset (char_table
,
2518 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2522 int size
= XVECTOR (range
)->size
;
2523 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2524 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2525 size
<= 1 ? Qnil
: val
[1],
2526 size
<= 2 ? Qnil
: val
[2]);
2527 return Faset (char_table
, ch
, value
);
2531 error ("Invalid RANGE argument to `set-char-table-range'");
2536 DEFUN ("set-char-table-default", Fset_char_table_default
,
2537 Sset_char_table_default
, 3, 3, 0,
2538 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2539 The generic character specifies the group of characters.
2540 See also the documentation of `make-char'. */)
2541 (char_table
, ch
, value
)
2542 Lisp_Object char_table
, ch
, value
;
2544 int c
, charset
, code1
, code2
;
2547 CHECK_CHAR_TABLE (char_table
);
2551 SPLIT_CHAR (c
, charset
, code1
, code2
);
2553 /* Since we may want to set the default value for a character set
2554 not yet defined, we check only if the character set is in the
2555 valid range or not, instead of it is already defined or not. */
2556 if (! CHARSET_VALID_P (charset
))
2557 invalid_character (c
);
2559 if (charset
== CHARSET_ASCII
)
2560 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2562 /* Even if C is not a generic char, we had better behave as if a
2563 generic char is specified. */
2564 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2566 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2569 if (SUB_CHAR_TABLE_P (temp
))
2570 XCHAR_TABLE (temp
)->defalt
= value
;
2572 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2575 if (SUB_CHAR_TABLE_P (temp
))
2578 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2579 = make_sub_char_table (temp
));
2580 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2581 if (SUB_CHAR_TABLE_P (temp
))
2582 XCHAR_TABLE (temp
)->defalt
= value
;
2584 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2588 /* Look up the element in TABLE at index CH,
2589 and return it as an integer.
2590 If the element is nil, return CH itself.
2591 (Actually we do that for any non-integer.) */
2594 char_table_translate (table
, ch
)
2599 value
= Faref (table
, make_number (ch
));
2600 if (! INTEGERP (value
))
2602 return XINT (value
);
2606 optimize_sub_char_table (table
, chars
)
2614 from
= 33, to
= 127;
2616 from
= 32, to
= 128;
2618 if (!SUB_CHAR_TABLE_P (*table
))
2620 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2621 for (; from
< to
; from
++)
2622 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2627 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2628 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2636 CHECK_CHAR_TABLE (table
);
2638 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2640 elt
= XCHAR_TABLE (table
)->contents
[i
];
2641 if (!SUB_CHAR_TABLE_P (elt
))
2643 dim
= CHARSET_DIMENSION (i
- 128);
2645 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2646 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2647 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2653 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2654 character or group of characters that share a value.
2655 DEPTH is the current depth in the originally specified
2656 chartable, and INDICES contains the vector indices
2657 for the levels our callers have descended.
2659 ARG is passed to C_FUNCTION when that is called. */
2662 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2663 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2664 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2671 /* At first, handle ASCII and 8-bit European characters. */
2672 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2674 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2676 elt
= XCHAR_TABLE (subtable
)->defalt
;
2678 elt
= Faref (subtable
, make_number (i
));
2680 (*c_function
) (arg
, make_number (i
), elt
);
2682 call2 (function
, make_number (i
), elt
);
2684 #if 0 /* If the char table has entries for higher characters,
2685 we should report them. */
2686 if (NILP (current_buffer
->enable_multibyte_characters
))
2689 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2693 int charset
= XFASTINT (indices
[0]) - 128;
2696 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2697 if (CHARSET_CHARS (charset
) == 94)
2706 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2707 XSETFASTINT (indices
[depth
], i
);
2708 charset
= XFASTINT (indices
[0]) - 128;
2710 && (!CHARSET_DEFINED_P (charset
)
2711 || charset
== CHARSET_8_BIT_CONTROL
2712 || charset
== CHARSET_8_BIT_GRAPHIC
))
2715 if (SUB_CHAR_TABLE_P (elt
))
2718 error ("Too deep char table");
2719 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2725 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2726 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2727 c
= MAKE_CHAR (charset
, c1
, c2
);
2730 elt
= XCHAR_TABLE (subtable
)->defalt
;
2732 elt
= Faref (table
, make_number (c
));
2735 (*c_function
) (arg
, make_number (c
), elt
);
2737 call2 (function
, make_number (c
), elt
);
2742 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2744 void_call2 (a
, b
, c
)
2745 Lisp_Object a
, b
, c
;
2750 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2752 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2753 FUNCTION is called with two arguments--a key and a value.
2754 The key is always a possible IDX argument to `aref'. */)
2755 (function
, char_table
)
2756 Lisp_Object function
, char_table
;
2758 /* The depth of char table is at most 3. */
2759 Lisp_Object indices
[3];
2761 CHECK_CHAR_TABLE (char_table
);
2763 /* When Lisp_Object is represented as a union, `call2' cannot directly
2764 be passed to map_char_table because it returns a Lisp_Object rather
2765 than returning nothing.
2766 Casting leads to crashes on some architectures. -stef */
2767 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2771 /* Return a value for character C in char-table TABLE. Store the
2772 actual index for that value in *IDX. Ignore the default value of
2776 char_table_ref_and_index (table
, c
, idx
)
2780 int charset
, c1
, c2
;
2783 if (SINGLE_BYTE_CHAR_P (c
))
2786 return XCHAR_TABLE (table
)->contents
[c
];
2788 SPLIT_CHAR (c
, charset
, c1
, c2
);
2789 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2790 *idx
= MAKE_CHAR (charset
, 0, 0);
2791 if (!SUB_CHAR_TABLE_P (elt
))
2793 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2794 return XCHAR_TABLE (elt
)->defalt
;
2795 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2796 *idx
= MAKE_CHAR (charset
, c1
, 0);
2797 if (!SUB_CHAR_TABLE_P (elt
))
2799 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2800 return XCHAR_TABLE (elt
)->defalt
;
2802 return XCHAR_TABLE (elt
)->contents
[c2
];
2812 Lisp_Object args
[2];
2815 return Fnconc (2, args
);
2817 return Fnconc (2, &s1
);
2818 #endif /* NO_ARG_ARRAY */
2821 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2822 doc
: /* Concatenate any number of lists by altering them.
2823 Only the last argument is not altered, and need not be a list.
2824 usage: (nconc &rest LISTS) */)
2829 register int argnum
;
2830 register Lisp_Object tail
, tem
, val
;
2834 for (argnum
= 0; argnum
< nargs
; argnum
++)
2837 if (NILP (tem
)) continue;
2842 if (argnum
+ 1 == nargs
) break;
2845 tem
= wrong_type_argument (Qlistp
, tem
);
2854 tem
= args
[argnum
+ 1];
2855 Fsetcdr (tail
, tem
);
2857 args
[argnum
+ 1] = tail
;
2863 /* This is the guts of all mapping functions.
2864 Apply FN to each element of SEQ, one by one,
2865 storing the results into elements of VALS, a C vector of Lisp_Objects.
2866 LENI is the length of VALS, which should also be the length of SEQ. */
2869 mapcar1 (leni
, vals
, fn
, seq
)
2872 Lisp_Object fn
, seq
;
2874 register Lisp_Object tail
;
2877 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2881 /* Don't let vals contain any garbage when GC happens. */
2882 for (i
= 0; i
< leni
; i
++)
2885 GCPRO3 (dummy
, fn
, seq
);
2887 gcpro1
.nvars
= leni
;
2891 /* We need not explicitly protect `tail' because it is used only on lists, and
2892 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2896 for (i
= 0; i
< leni
; i
++)
2898 dummy
= XVECTOR (seq
)->contents
[i
];
2899 dummy
= call1 (fn
, dummy
);
2904 else if (BOOL_VECTOR_P (seq
))
2906 for (i
= 0; i
< leni
; i
++)
2909 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2910 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2915 dummy
= call1 (fn
, dummy
);
2920 else if (STRINGP (seq
))
2924 for (i
= 0, i_byte
= 0; i
< leni
;)
2929 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2930 XSETFASTINT (dummy
, c
);
2931 dummy
= call1 (fn
, dummy
);
2933 vals
[i_before
] = dummy
;
2936 else /* Must be a list, since Flength did not get an error */
2939 for (i
= 0; i
< leni
; i
++)
2941 dummy
= call1 (fn
, Fcar (tail
));
2951 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2952 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2953 In between each pair of results, stick in SEPARATOR. Thus, " " as
2954 SEPARATOR results in spaces between the values returned by FUNCTION.
2955 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2956 (function
, sequence
, separator
)
2957 Lisp_Object function
, sequence
, separator
;
2962 register Lisp_Object
*args
;
2964 struct gcpro gcpro1
;
2966 len
= Flength (sequence
);
2968 nargs
= leni
+ leni
- 1;
2969 if (nargs
< 0) return build_string ("");
2971 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2974 mapcar1 (leni
, args
, function
, sequence
);
2977 for (i
= leni
- 1; i
>= 0; i
--)
2978 args
[i
+ i
] = args
[i
];
2980 for (i
= 1; i
< nargs
; i
+= 2)
2981 args
[i
] = separator
;
2983 return Fconcat (nargs
, args
);
2986 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2987 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2988 The result is a list just as long as SEQUENCE.
2989 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2990 (function
, sequence
)
2991 Lisp_Object function
, sequence
;
2993 register Lisp_Object len
;
2995 register Lisp_Object
*args
;
2997 len
= Flength (sequence
);
2998 leni
= XFASTINT (len
);
2999 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
3001 mapcar1 (leni
, args
, function
, sequence
);
3003 return Flist (leni
, args
);
3006 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3007 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3008 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3009 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3010 (function
, sequence
)
3011 Lisp_Object function
, sequence
;
3015 leni
= XFASTINT (Flength (sequence
));
3016 mapcar1 (leni
, 0, function
, sequence
);
3021 /* Anything that calls this function must protect from GC! */
3023 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3024 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3025 Takes one argument, which is the string to display to ask the question.
3026 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3027 No confirmation of the answer is requested; a single character is enough.
3028 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3029 the bindings in `query-replace-map'; see the documentation of that variable
3030 for more information. In this case, the useful bindings are `act', `skip',
3031 `recenter', and `quit'.\)
3033 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3034 is nil and `use-dialog-box' is non-nil. */)
3038 register Lisp_Object obj
, key
, def
, map
;
3039 register int answer
;
3040 Lisp_Object xprompt
;
3041 Lisp_Object args
[2];
3042 struct gcpro gcpro1
, gcpro2
;
3043 int count
= SPECPDL_INDEX ();
3045 specbind (Qcursor_in_echo_area
, Qt
);
3047 map
= Fsymbol_value (intern ("query-replace-map"));
3049 CHECK_STRING (prompt
);
3051 GCPRO2 (prompt
, xprompt
);
3053 #ifdef HAVE_X_WINDOWS
3054 if (display_hourglass_p
)
3055 cancel_hourglass ();
3062 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3066 Lisp_Object pane
, menu
;
3067 redisplay_preserve_echo_area (3);
3068 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3069 Fcons (Fcons (build_string ("No"), Qnil
),
3071 menu
= Fcons (prompt
, pane
);
3072 obj
= Fx_popup_dialog (Qt
, menu
);
3073 answer
= !NILP (obj
);
3076 #endif /* HAVE_MENUS */
3077 cursor_in_echo_area
= 1;
3078 choose_minibuf_frame ();
3081 Lisp_Object pargs
[3];
3083 /* Colorize prompt according to `minibuffer-prompt' face. */
3084 pargs
[0] = build_string ("%s(y or n) ");
3085 pargs
[1] = intern ("face");
3086 pargs
[2] = intern ("minibuffer-prompt");
3087 args
[0] = Fpropertize (3, pargs
);
3092 if (minibuffer_auto_raise
)
3094 Lisp_Object mini_frame
;
3096 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3098 Fraise_frame (mini_frame
);
3101 obj
= read_filtered_event (1, 0, 0, 0);
3102 cursor_in_echo_area
= 0;
3103 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3106 key
= Fmake_vector (make_number (1), obj
);
3107 def
= Flookup_key (map
, key
, Qt
);
3109 if (EQ (def
, intern ("skip")))
3114 else if (EQ (def
, intern ("act")))
3119 else if (EQ (def
, intern ("recenter")))
3125 else if (EQ (def
, intern ("quit")))
3127 /* We want to exit this command for exit-prefix,
3128 and this is the only way to do it. */
3129 else if (EQ (def
, intern ("exit-prefix")))
3134 /* If we don't clear this, then the next call to read_char will
3135 return quit_char again, and we'll enter an infinite loop. */
3140 if (EQ (xprompt
, prompt
))
3142 args
[0] = build_string ("Please answer y or n. ");
3144 xprompt
= Fconcat (2, args
);
3149 if (! noninteractive
)
3151 cursor_in_echo_area
= -1;
3152 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3156 unbind_to (count
, Qnil
);
3157 return answer
? Qt
: Qnil
;
3160 /* This is how C code calls `yes-or-no-p' and allows the user
3163 Anything that calls this function must protect from GC! */
3166 do_yes_or_no_p (prompt
)
3169 return call1 (intern ("yes-or-no-p"), prompt
);
3172 /* Anything that calls this function must protect from GC! */
3174 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3175 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3176 Takes one argument, which is the string to display to ask the question.
3177 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3178 The user must confirm the answer with RET,
3179 and can edit it until it has been confirmed.
3181 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3182 is nil, and `use-dialog-box' is non-nil. */)
3186 register Lisp_Object ans
;
3187 Lisp_Object args
[2];
3188 struct gcpro gcpro1
;
3190 CHECK_STRING (prompt
);
3193 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3197 Lisp_Object pane
, menu
, obj
;
3198 redisplay_preserve_echo_area (4);
3199 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3200 Fcons (Fcons (build_string ("No"), Qnil
),
3203 menu
= Fcons (prompt
, pane
);
3204 obj
= Fx_popup_dialog (Qt
, menu
);
3208 #endif /* HAVE_MENUS */
3211 args
[1] = build_string ("(yes or no) ");
3212 prompt
= Fconcat (2, args
);
3218 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3219 Qyes_or_no_p_history
, Qnil
,
3221 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3226 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3234 message ("Please answer yes or no.");
3235 Fsleep_for (make_number (2), Qnil
);
3239 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3240 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3242 Each of the three load averages is multiplied by 100, then converted
3245 When USE-FLOATS is non-nil, floats will be used instead of integers.
3246 These floats are not multiplied by 100.
3248 If the 5-minute or 15-minute load averages are not available, return a
3249 shortened list, containing only those averages which are available.
3251 An error is thrown if the load average can't be obtained. In some
3252 cases making it work would require Emacs being installed setuid or
3253 setgid so that it can read kernel information, and that usually isn't
3256 Lisp_Object use_floats
;
3259 int loads
= getloadavg (load_ave
, 3);
3260 Lisp_Object ret
= Qnil
;
3263 error ("load-average not implemented for this operating system");
3267 Lisp_Object load
= (NILP (use_floats
) ?
3268 make_number ((int) (100.0 * load_ave
[loads
]))
3269 : make_float (load_ave
[loads
]));
3270 ret
= Fcons (load
, ret
);
3276 Lisp_Object Vfeatures
, Qsubfeatures
;
3277 extern Lisp_Object Vafter_load_alist
;
3279 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3280 doc
: /* Returns t if FEATURE is present in this Emacs.
3282 Use this to conditionalize execution of lisp code based on the
3283 presence or absence of emacs or environment extensions.
3284 Use `provide' to declare that a feature is available. This function
3285 looks at the value of the variable `features'. The optional argument
3286 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3287 (feature
, subfeature
)
3288 Lisp_Object feature
, subfeature
;
3290 register Lisp_Object tem
;
3291 CHECK_SYMBOL (feature
);
3292 tem
= Fmemq (feature
, Vfeatures
);
3293 if (!NILP (tem
) && !NILP (subfeature
))
3294 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3295 return (NILP (tem
)) ? Qnil
: Qt
;
3298 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3299 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3300 The optional argument SUBFEATURES should be a list of symbols listing
3301 particular subfeatures supported in this version of FEATURE. */)
3302 (feature
, subfeatures
)
3303 Lisp_Object feature
, subfeatures
;
3305 register Lisp_Object tem
;
3306 CHECK_SYMBOL (feature
);
3307 CHECK_LIST (subfeatures
);
3308 if (!NILP (Vautoload_queue
))
3309 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3310 tem
= Fmemq (feature
, Vfeatures
);
3312 Vfeatures
= Fcons (feature
, Vfeatures
);
3313 if (!NILP (subfeatures
))
3314 Fput (feature
, Qsubfeatures
, subfeatures
);
3315 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3317 /* Run any load-hooks for this file. */
3318 tem
= Fassq (feature
, Vafter_load_alist
);
3320 Fprogn (XCDR (tem
));
3325 /* `require' and its subroutines. */
3327 /* List of features currently being require'd, innermost first. */
3329 Lisp_Object require_nesting_list
;
3332 require_unwind (old_value
)
3333 Lisp_Object old_value
;
3335 return require_nesting_list
= old_value
;
3338 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3339 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3340 If FEATURE is not a member of the list `features', then the feature
3341 is not loaded; so load the file FILENAME.
3342 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3343 and `load' will try to load this name appended with the suffix `.elc' or
3344 `.el', in that order. The name without appended suffix will not be used.
3345 If the optional third argument NOERROR is non-nil,
3346 then return nil if the file is not found instead of signaling an error.
3347 Normally the return value is FEATURE.
3348 The normal messages at start and end of loading FILENAME are suppressed. */)
3349 (feature
, filename
, noerror
)
3350 Lisp_Object feature
, filename
, noerror
;
3352 register Lisp_Object tem
;
3353 struct gcpro gcpro1
, gcpro2
;
3355 CHECK_SYMBOL (feature
);
3357 tem
= Fmemq (feature
, Vfeatures
);
3361 int count
= SPECPDL_INDEX ();
3364 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3366 /* This is to make sure that loadup.el gives a clear picture
3367 of what files are preloaded and when. */
3368 if (! NILP (Vpurify_flag
))
3369 error ("(require %s) while preparing to dump",
3370 SDATA (SYMBOL_NAME (feature
)));
3372 /* A certain amount of recursive `require' is legitimate,
3373 but if we require the same feature recursively 3 times,
3375 tem
= require_nesting_list
;
3376 while (! NILP (tem
))
3378 if (! NILP (Fequal (feature
, XCAR (tem
))))
3383 error ("Recursive `require' for feature `%s'",
3384 SDATA (SYMBOL_NAME (feature
)));
3386 /* Update the list for any nested `require's that occur. */
3387 record_unwind_protect (require_unwind
, require_nesting_list
);
3388 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3390 /* Value saved here is to be restored into Vautoload_queue */
3391 record_unwind_protect (un_autoload
, Vautoload_queue
);
3392 Vautoload_queue
= Qt
;
3394 /* Load the file. */
3395 GCPRO2 (feature
, filename
);
3396 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3397 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3400 /* If load failed entirely, return nil. */
3402 return unbind_to (count
, Qnil
);
3404 tem
= Fmemq (feature
, Vfeatures
);
3406 error ("Required feature `%s' was not provided",
3407 SDATA (SYMBOL_NAME (feature
)));
3409 /* Once loading finishes, don't undo it. */
3410 Vautoload_queue
= Qt
;
3411 feature
= unbind_to (count
, feature
);
3417 /* Primitives for work of the "widget" library.
3418 In an ideal world, this section would not have been necessary.
3419 However, lisp function calls being as slow as they are, it turns
3420 out that some functions in the widget library (wid-edit.el) are the
3421 bottleneck of Widget operation. Here is their translation to C,
3422 for the sole reason of efficiency. */
3424 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3425 doc
: /* Return non-nil if PLIST has the property PROP.
3426 PLIST is a property list, which is a list of the form
3427 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3428 Unlike `plist-get', this allows you to distinguish between a missing
3429 property and a property with the value nil.
3430 The value is actually the tail of PLIST whose car is PROP. */)
3432 Lisp_Object plist
, prop
;
3434 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3437 plist
= XCDR (plist
);
3438 plist
= CDR (plist
);
3443 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3444 doc
: /* In WIDGET, set PROPERTY to VALUE.
3445 The value can later be retrieved with `widget-get'. */)
3446 (widget
, property
, value
)
3447 Lisp_Object widget
, property
, value
;
3449 CHECK_CONS (widget
);
3450 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3454 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3455 doc
: /* In WIDGET, get the value of PROPERTY.
3456 The value could either be specified when the widget was created, or
3457 later with `widget-put'. */)
3459 Lisp_Object widget
, property
;
3467 CHECK_CONS (widget
);
3468 tmp
= Fplist_member (XCDR (widget
), property
);
3474 tmp
= XCAR (widget
);
3477 widget
= Fget (tmp
, Qwidget_type
);
3481 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3482 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3483 ARGS are passed as extra arguments to the function.
3484 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3489 /* This function can GC. */
3490 Lisp_Object newargs
[3];
3491 struct gcpro gcpro1
, gcpro2
;
3494 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3495 newargs
[1] = args
[0];
3496 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3497 GCPRO2 (newargs
[0], newargs
[2]);
3498 result
= Fapply (3, newargs
);
3503 #ifdef HAVE_LANGINFO_CODESET
3504 #include <langinfo.h>
3507 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3508 doc
: /* Access locale data ITEM for the current C locale, if available.
3509 ITEM should be one of the following:
3511 `codeset', returning the character set as a string (locale item CODESET);
3513 `days', returning a 7-element vector of day names (locale items DAY_n);
3515 `months', returning a 12-element vector of month names (locale items MON_n);
3517 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3518 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3520 If the system can't provide such information through a call to
3521 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3523 See also Info node `(libc)Locales'.
3525 The data read from the system are decoded using `locale-coding-system'. */)
3530 #ifdef HAVE_LANGINFO_CODESET
3532 if (EQ (item
, Qcodeset
))
3534 str
= nl_langinfo (CODESET
);
3535 return build_string (str
);
3538 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3540 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3541 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3543 synchronize_system_time_locale ();
3544 for (i
= 0; i
< 7; i
++)
3546 str
= nl_langinfo (days
[i
]);
3547 val
= make_unibyte_string (str
, strlen (str
));
3548 /* Fixme: Is this coding system necessarily right, even if
3549 it is consistent with CODESET? If not, what to do? */
3550 Faset (v
, make_number (i
),
3551 code_convert_string_norecord (val
, Vlocale_coding_system
,
3558 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3560 struct Lisp_Vector
*p
= allocate_vector (12);
3561 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3562 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3564 synchronize_system_time_locale ();
3565 for (i
= 0; i
< 12; i
++)
3567 str
= nl_langinfo (months
[i
]);
3568 val
= make_unibyte_string (str
, strlen (str
));
3570 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3572 XSETVECTOR (val
, p
);
3576 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3577 but is in the locale files. This could be used by ps-print. */
3579 else if (EQ (item
, Qpaper
))
3581 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3582 make_number (nl_langinfo (PAPER_HEIGHT
)));
3584 #endif /* PAPER_WIDTH */
3585 #endif /* HAVE_LANGINFO_CODESET*/
3589 /* base64 encode/decode functions (RFC 2045).
3590 Based on code from GNU recode. */
3592 #define MIME_LINE_LENGTH 76
3594 #define IS_ASCII(Character) \
3596 #define IS_BASE64(Character) \
3597 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3598 #define IS_BASE64_IGNORABLE(Character) \
3599 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3600 || (Character) == '\f' || (Character) == '\r')
3602 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3603 character or return retval if there are no characters left to
3605 #define READ_QUADRUPLET_BYTE(retval) \
3610 if (nchars_return) \
3611 *nchars_return = nchars; \
3616 while (IS_BASE64_IGNORABLE (c))
3618 /* Don't use alloca for regions larger than this, lest we overflow
3620 #define MAX_ALLOCA 16*1024
3622 /* Table of characters coding the 64 values. */
3623 static char base64_value_to_char
[64] =
3625 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3626 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3627 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3628 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3629 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3630 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3631 '8', '9', '+', '/' /* 60-63 */
3634 /* Table of base64 values for first 128 characters. */
3635 static short base64_char_to_value
[128] =
3637 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3638 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3639 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3640 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3641 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3642 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3643 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3644 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3645 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3646 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3647 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3648 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3649 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3652 /* The following diagram shows the logical steps by which three octets
3653 get transformed into four base64 characters.
3655 .--------. .--------. .--------.
3656 |aaaaaabb| |bbbbcccc| |ccdddddd|
3657 `--------' `--------' `--------'
3659 .--------+--------+--------+--------.
3660 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3661 `--------+--------+--------+--------'
3663 .--------+--------+--------+--------.
3664 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3665 `--------+--------+--------+--------'
3667 The octets are divided into 6 bit chunks, which are then encoded into
3668 base64 characters. */
3671 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3672 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3674 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3676 doc
: /* Base64-encode the region between BEG and END.
3677 Return the length of the encoded text.
3678 Optional third argument NO-LINE-BREAK means do not break long lines
3679 into shorter lines. */)
3680 (beg
, end
, no_line_break
)
3681 Lisp_Object beg
, end
, no_line_break
;
3684 int allength
, length
;
3685 int ibeg
, iend
, encoded_length
;
3688 validate_region (&beg
, &end
);
3690 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3691 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3692 move_gap_both (XFASTINT (beg
), ibeg
);
3694 /* We need to allocate enough room for encoding the text.
3695 We need 33 1/3% more space, plus a newline every 76
3696 characters, and then we round up. */
3697 length
= iend
- ibeg
;
3698 allength
= length
+ length
/3 + 1;
3699 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3701 if (allength
<= MAX_ALLOCA
)
3702 encoded
= (char *) alloca (allength
);
3704 encoded
= (char *) xmalloc (allength
);
3705 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3706 NILP (no_line_break
),
3707 !NILP (current_buffer
->enable_multibyte_characters
));
3708 if (encoded_length
> allength
)
3711 if (encoded_length
< 0)
3713 /* The encoding wasn't possible. */
3714 if (length
> MAX_ALLOCA
)
3716 error ("Multibyte character in data for base64 encoding");
3719 /* Now we have encoded the region, so we insert the new contents
3720 and delete the old. (Insert first in order to preserve markers.) */
3721 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3722 insert (encoded
, encoded_length
);
3723 if (allength
> MAX_ALLOCA
)
3725 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3727 /* If point was outside of the region, restore it exactly; else just
3728 move to the beginning of the region. */
3729 if (old_pos
>= XFASTINT (end
))
3730 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3731 else if (old_pos
> XFASTINT (beg
))
3732 old_pos
= XFASTINT (beg
);
3735 /* We return the length of the encoded text. */
3736 return make_number (encoded_length
);
3739 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3741 doc
: /* Base64-encode STRING and return the result.
3742 Optional second argument NO-LINE-BREAK means do not break long lines
3743 into shorter lines. */)
3744 (string
, no_line_break
)
3745 Lisp_Object string
, no_line_break
;
3747 int allength
, length
, encoded_length
;
3749 Lisp_Object encoded_string
;
3751 CHECK_STRING (string
);
3753 /* We need to allocate enough room for encoding the text.
3754 We need 33 1/3% more space, plus a newline every 76
3755 characters, and then we round up. */
3756 length
= SBYTES (string
);
3757 allength
= length
+ length
/3 + 1;
3758 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3760 /* We need to allocate enough room for decoding the text. */
3761 if (allength
<= MAX_ALLOCA
)
3762 encoded
= (char *) alloca (allength
);
3764 encoded
= (char *) xmalloc (allength
);
3766 encoded_length
= base64_encode_1 (SDATA (string
),
3767 encoded
, length
, NILP (no_line_break
),
3768 STRING_MULTIBYTE (string
));
3769 if (encoded_length
> allength
)
3772 if (encoded_length
< 0)
3774 /* The encoding wasn't possible. */
3775 if (length
> MAX_ALLOCA
)
3777 error ("Multibyte character in data for base64 encoding");
3780 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3781 if (allength
> MAX_ALLOCA
)
3784 return encoded_string
;
3788 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3795 int counter
= 0, i
= 0;
3805 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3813 /* Wrap line every 76 characters. */
3817 if (counter
< MIME_LINE_LENGTH
/ 4)
3826 /* Process first byte of a triplet. */
3828 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3829 value
= (0x03 & c
) << 4;
3831 /* Process second byte of a triplet. */
3835 *e
++ = base64_value_to_char
[value
];
3843 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3851 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3852 value
= (0x0f & c
) << 2;
3854 /* Process third byte of a triplet. */
3858 *e
++ = base64_value_to_char
[value
];
3865 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3873 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3874 *e
++ = base64_value_to_char
[0x3f & c
];
3881 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3883 doc
: /* Base64-decode the region between BEG and END.
3884 Return the length of the decoded text.
3885 If the region can't be decoded, signal an error and don't modify the buffer. */)
3887 Lisp_Object beg
, end
;
3889 int ibeg
, iend
, length
, allength
;
3894 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3896 validate_region (&beg
, &end
);
3898 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3899 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3901 length
= iend
- ibeg
;
3903 /* We need to allocate enough room for decoding the text. If we are
3904 working on a multibyte buffer, each decoded code may occupy at
3906 allength
= multibyte
? length
* 2 : length
;
3907 if (allength
<= MAX_ALLOCA
)
3908 decoded
= (char *) alloca (allength
);
3910 decoded
= (char *) xmalloc (allength
);
3912 move_gap_both (XFASTINT (beg
), ibeg
);
3913 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3914 multibyte
, &inserted_chars
);
3915 if (decoded_length
> allength
)
3918 if (decoded_length
< 0)
3920 /* The decoding wasn't possible. */
3921 if (allength
> MAX_ALLOCA
)
3923 error ("Invalid base64 data");
3926 /* Now we have decoded the region, so we insert the new contents
3927 and delete the old. (Insert first in order to preserve markers.) */
3928 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3929 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3930 if (allength
> MAX_ALLOCA
)
3932 /* Delete the original text. */
3933 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3934 iend
+ decoded_length
, 1);
3936 /* If point was outside of the region, restore it exactly; else just
3937 move to the beginning of the region. */
3938 if (old_pos
>= XFASTINT (end
))
3939 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3940 else if (old_pos
> XFASTINT (beg
))
3941 old_pos
= XFASTINT (beg
);
3942 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3944 return make_number (inserted_chars
);
3947 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3949 doc
: /* Base64-decode STRING and return the result. */)
3954 int length
, decoded_length
;
3955 Lisp_Object decoded_string
;
3957 CHECK_STRING (string
);
3959 length
= SBYTES (string
);
3960 /* We need to allocate enough room for decoding the text. */
3961 if (length
<= MAX_ALLOCA
)
3962 decoded
= (char *) alloca (length
);
3964 decoded
= (char *) xmalloc (length
);
3966 /* The decoded result should be unibyte. */
3967 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3969 if (decoded_length
> length
)
3971 else if (decoded_length
>= 0)
3972 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3974 decoded_string
= Qnil
;
3976 if (length
> MAX_ALLOCA
)
3978 if (!STRINGP (decoded_string
))
3979 error ("Invalid base64 data");
3981 return decoded_string
;
3984 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3985 MULTIBYTE is nonzero, the decoded result should be in multibyte
3986 form. If NCHARS_RETRUN is not NULL, store the number of produced
3987 characters in *NCHARS_RETURN. */
3990 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4000 unsigned long value
;
4005 /* Process first byte of a quadruplet. */
4007 READ_QUADRUPLET_BYTE (e
-to
);
4011 value
= base64_char_to_value
[c
] << 18;
4013 /* Process second byte of a quadruplet. */
4015 READ_QUADRUPLET_BYTE (-1);
4019 value
|= base64_char_to_value
[c
] << 12;
4021 c
= (unsigned char) (value
>> 16);
4023 e
+= CHAR_STRING (c
, e
);
4028 /* Process third byte of a quadruplet. */
4030 READ_QUADRUPLET_BYTE (-1);
4034 READ_QUADRUPLET_BYTE (-1);
4043 value
|= base64_char_to_value
[c
] << 6;
4045 c
= (unsigned char) (0xff & value
>> 8);
4047 e
+= CHAR_STRING (c
, e
);
4052 /* Process fourth byte of a quadruplet. */
4054 READ_QUADRUPLET_BYTE (-1);
4061 value
|= base64_char_to_value
[c
];
4063 c
= (unsigned char) (0xff & value
);
4065 e
+= CHAR_STRING (c
, e
);
4074 /***********************************************************************
4076 ***** Hash Tables *****
4078 ***********************************************************************/
4080 /* Implemented by gerd@gnu.org. This hash table implementation was
4081 inspired by CMUCL hash tables. */
4085 1. For small tables, association lists are probably faster than
4086 hash tables because they have lower overhead.
4088 For uses of hash tables where the O(1) behavior of table
4089 operations is not a requirement, it might therefore be a good idea
4090 not to hash. Instead, we could just do a linear search in the
4091 key_and_value vector of the hash table. This could be done
4092 if a `:linear-search t' argument is given to make-hash-table. */
4095 /* The list of all weak hash tables. Don't staticpro this one. */
4097 Lisp_Object Vweak_hash_tables
;
4099 /* Various symbols. */
4101 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4102 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4103 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4105 /* Function prototypes. */
4107 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4108 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4109 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4110 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4111 Lisp_Object
, unsigned));
4112 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4113 Lisp_Object
, unsigned));
4114 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4115 unsigned, Lisp_Object
, unsigned));
4116 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4117 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4118 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4119 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4121 static unsigned sxhash_string
P_ ((unsigned char *, int));
4122 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4123 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4124 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4125 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4129 /***********************************************************************
4131 ***********************************************************************/
4133 /* If OBJ is a Lisp hash table, return a pointer to its struct
4134 Lisp_Hash_Table. Otherwise, signal an error. */
4136 static struct Lisp_Hash_Table
*
4137 check_hash_table (obj
)
4140 CHECK_HASH_TABLE (obj
);
4141 return XHASH_TABLE (obj
);
4145 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4149 next_almost_prime (n
)
4162 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4163 which USED[I] is non-zero. If found at index I in ARGS, set
4164 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4165 -1. This function is used to extract a keyword/argument pair from
4166 a DEFUN parameter list. */
4169 get_key_arg (key
, nargs
, args
, used
)
4177 for (i
= 0; i
< nargs
- 1; ++i
)
4178 if (!used
[i
] && EQ (args
[i
], key
))
4193 /* Return a Lisp vector which has the same contents as VEC but has
4194 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4195 vector that are not copied from VEC are set to INIT. */
4198 larger_vector (vec
, new_size
, init
)
4203 struct Lisp_Vector
*v
;
4206 xassert (VECTORP (vec
));
4207 old_size
= XVECTOR (vec
)->size
;
4208 xassert (new_size
>= old_size
);
4210 v
= allocate_vector (new_size
);
4211 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4212 old_size
* sizeof *v
->contents
);
4213 for (i
= old_size
; i
< new_size
; ++i
)
4214 v
->contents
[i
] = init
;
4215 XSETVECTOR (vec
, v
);
4220 /***********************************************************************
4222 ***********************************************************************/
4224 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4225 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4226 KEY2 are the same. */
4229 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4230 struct Lisp_Hash_Table
*h
;
4231 Lisp_Object key1
, key2
;
4232 unsigned hash1
, hash2
;
4234 return (FLOATP (key1
)
4236 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4240 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4241 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4242 KEY2 are the same. */
4245 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4246 struct Lisp_Hash_Table
*h
;
4247 Lisp_Object key1
, key2
;
4248 unsigned hash1
, hash2
;
4250 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4254 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4255 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4256 if KEY1 and KEY2 are the same. */
4259 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4260 struct Lisp_Hash_Table
*h
;
4261 Lisp_Object key1
, key2
;
4262 unsigned hash1
, hash2
;
4266 Lisp_Object args
[3];
4268 args
[0] = h
->user_cmp_function
;
4271 return !NILP (Ffuncall (3, args
));
4278 /* Value is a hash code for KEY for use in hash table H which uses
4279 `eq' to compare keys. The hash code returned is guaranteed to fit
4280 in a Lisp integer. */
4284 struct Lisp_Hash_Table
*h
;
4287 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4288 xassert ((hash
& ~INTMASK
) == 0);
4293 /* Value is a hash code for KEY for use in hash table H which uses
4294 `eql' to compare keys. The hash code returned is guaranteed to fit
4295 in a Lisp integer. */
4299 struct Lisp_Hash_Table
*h
;
4304 hash
= sxhash (key
, 0);
4306 hash
= XUINT (key
) ^ XGCTYPE (key
);
4307 xassert ((hash
& ~INTMASK
) == 0);
4312 /* Value is a hash code for KEY for use in hash table H which uses
4313 `equal' to compare keys. The hash code returned is guaranteed to fit
4314 in a Lisp integer. */
4317 hashfn_equal (h
, key
)
4318 struct Lisp_Hash_Table
*h
;
4321 unsigned hash
= sxhash (key
, 0);
4322 xassert ((hash
& ~INTMASK
) == 0);
4327 /* Value is a hash code for KEY for use in hash table H which uses as
4328 user-defined function to compare keys. The hash code returned is
4329 guaranteed to fit in a Lisp integer. */
4332 hashfn_user_defined (h
, key
)
4333 struct Lisp_Hash_Table
*h
;
4336 Lisp_Object args
[2], hash
;
4338 args
[0] = h
->user_hash_function
;
4340 hash
= Ffuncall (2, args
);
4341 if (!INTEGERP (hash
))
4343 list2 (build_string ("Invalid hash code returned from \
4344 user-supplied hash function"),
4346 return XUINT (hash
);
4350 /* Create and initialize a new hash table.
4352 TEST specifies the test the hash table will use to compare keys.
4353 It must be either one of the predefined tests `eq', `eql' or
4354 `equal' or a symbol denoting a user-defined test named TEST with
4355 test and hash functions USER_TEST and USER_HASH.
4357 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4359 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4360 new size when it becomes full is computed by adding REHASH_SIZE to
4361 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4362 table's new size is computed by multiplying its old size with
4365 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4366 be resized when the ratio of (number of entries in the table) /
4367 (table size) is >= REHASH_THRESHOLD.
4369 WEAK specifies the weakness of the table. If non-nil, it must be
4370 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4373 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4374 user_test
, user_hash
)
4375 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4376 Lisp_Object user_test
, user_hash
;
4378 struct Lisp_Hash_Table
*h
;
4380 int index_size
, i
, sz
;
4382 /* Preconditions. */
4383 xassert (SYMBOLP (test
));
4384 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4385 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4386 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4387 xassert (FLOATP (rehash_threshold
)
4388 && XFLOATINT (rehash_threshold
) > 0
4389 && XFLOATINT (rehash_threshold
) <= 1.0);
4391 if (XFASTINT (size
) == 0)
4392 size
= make_number (1);
4394 /* Allocate a table and initialize it. */
4395 h
= allocate_hash_table ();
4397 /* Initialize hash table slots. */
4398 sz
= XFASTINT (size
);
4401 if (EQ (test
, Qeql
))
4403 h
->cmpfn
= cmpfn_eql
;
4404 h
->hashfn
= hashfn_eql
;
4406 else if (EQ (test
, Qeq
))
4409 h
->hashfn
= hashfn_eq
;
4411 else if (EQ (test
, Qequal
))
4413 h
->cmpfn
= cmpfn_equal
;
4414 h
->hashfn
= hashfn_equal
;
4418 h
->user_cmp_function
= user_test
;
4419 h
->user_hash_function
= user_hash
;
4420 h
->cmpfn
= cmpfn_user_defined
;
4421 h
->hashfn
= hashfn_user_defined
;
4425 h
->rehash_threshold
= rehash_threshold
;
4426 h
->rehash_size
= rehash_size
;
4427 h
->count
= make_number (0);
4428 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4429 h
->hash
= Fmake_vector (size
, Qnil
);
4430 h
->next
= Fmake_vector (size
, Qnil
);
4431 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4432 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4433 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4435 /* Set up the free list. */
4436 for (i
= 0; i
< sz
- 1; ++i
)
4437 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4438 h
->next_free
= make_number (0);
4440 XSET_HASH_TABLE (table
, h
);
4441 xassert (HASH_TABLE_P (table
));
4442 xassert (XHASH_TABLE (table
) == h
);
4444 /* Maybe add this hash table to the list of all weak hash tables. */
4446 h
->next_weak
= Qnil
;
4449 h
->next_weak
= Vweak_hash_tables
;
4450 Vweak_hash_tables
= table
;
4457 /* Return a copy of hash table H1. Keys and values are not copied,
4458 only the table itself is. */
4461 copy_hash_table (h1
)
4462 struct Lisp_Hash_Table
*h1
;
4465 struct Lisp_Hash_Table
*h2
;
4466 struct Lisp_Vector
*next
;
4468 h2
= allocate_hash_table ();
4469 next
= h2
->vec_next
;
4470 bcopy (h1
, h2
, sizeof *h2
);
4471 h2
->vec_next
= next
;
4472 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4473 h2
->hash
= Fcopy_sequence (h1
->hash
);
4474 h2
->next
= Fcopy_sequence (h1
->next
);
4475 h2
->index
= Fcopy_sequence (h1
->index
);
4476 XSET_HASH_TABLE (table
, h2
);
4478 /* Maybe add this hash table to the list of all weak hash tables. */
4479 if (!NILP (h2
->weak
))
4481 h2
->next_weak
= Vweak_hash_tables
;
4482 Vweak_hash_tables
= table
;
4489 /* Resize hash table H if it's too full. If H cannot be resized
4490 because it's already too large, throw an error. */
4493 maybe_resize_hash_table (h
)
4494 struct Lisp_Hash_Table
*h
;
4496 if (NILP (h
->next_free
))
4498 int old_size
= HASH_TABLE_SIZE (h
);
4499 int i
, new_size
, index_size
;
4501 if (INTEGERP (h
->rehash_size
))
4502 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4504 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4505 new_size
= max (old_size
+ 1, new_size
);
4506 index_size
= next_almost_prime ((int)
4508 / XFLOATINT (h
->rehash_threshold
)));
4509 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4510 error ("Hash table too large to resize");
4512 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4513 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4514 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4515 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4517 /* Update the free list. Do it so that new entries are added at
4518 the end of the free list. This makes some operations like
4520 for (i
= old_size
; i
< new_size
- 1; ++i
)
4521 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4523 if (!NILP (h
->next_free
))
4525 Lisp_Object last
, next
;
4527 last
= h
->next_free
;
4528 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4532 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4535 XSETFASTINT (h
->next_free
, old_size
);
4538 for (i
= 0; i
< old_size
; ++i
)
4539 if (!NILP (HASH_HASH (h
, i
)))
4541 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4542 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4543 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4544 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4550 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4551 the hash code of KEY. Value is the index of the entry in H
4552 matching KEY, or -1 if not found. */
4555 hash_lookup (h
, key
, hash
)
4556 struct Lisp_Hash_Table
*h
;
4561 int start_of_bucket
;
4564 hash_code
= h
->hashfn (h
, key
);
4568 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4569 idx
= HASH_INDEX (h
, start_of_bucket
);
4571 /* We need not gcpro idx since it's either an integer or nil. */
4574 int i
= XFASTINT (idx
);
4575 if (EQ (key
, HASH_KEY (h
, i
))
4577 && h
->cmpfn (h
, key
, hash_code
,
4578 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4580 idx
= HASH_NEXT (h
, i
);
4583 return NILP (idx
) ? -1 : XFASTINT (idx
);
4587 /* Put an entry into hash table H that associates KEY with VALUE.
4588 HASH is a previously computed hash code of KEY.
4589 Value is the index of the entry in H matching KEY. */
4592 hash_put (h
, key
, value
, hash
)
4593 struct Lisp_Hash_Table
*h
;
4594 Lisp_Object key
, value
;
4597 int start_of_bucket
, i
;
4599 xassert ((hash
& ~INTMASK
) == 0);
4601 /* Increment count after resizing because resizing may fail. */
4602 maybe_resize_hash_table (h
);
4603 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4605 /* Store key/value in the key_and_value vector. */
4606 i
= XFASTINT (h
->next_free
);
4607 h
->next_free
= HASH_NEXT (h
, i
);
4608 HASH_KEY (h
, i
) = key
;
4609 HASH_VALUE (h
, i
) = value
;
4611 /* Remember its hash code. */
4612 HASH_HASH (h
, i
) = make_number (hash
);
4614 /* Add new entry to its collision chain. */
4615 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4616 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4617 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4622 /* Remove the entry matching KEY from hash table H, if there is one. */
4625 hash_remove (h
, key
)
4626 struct Lisp_Hash_Table
*h
;
4630 int start_of_bucket
;
4631 Lisp_Object idx
, prev
;
4633 hash_code
= h
->hashfn (h
, key
);
4634 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4635 idx
= HASH_INDEX (h
, start_of_bucket
);
4638 /* We need not gcpro idx, prev since they're either integers or nil. */
4641 int i
= XFASTINT (idx
);
4643 if (EQ (key
, HASH_KEY (h
, i
))
4645 && h
->cmpfn (h
, key
, hash_code
,
4646 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4648 /* Take entry out of collision chain. */
4650 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4652 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4654 /* Clear slots in key_and_value and add the slots to
4656 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4657 HASH_NEXT (h
, i
) = h
->next_free
;
4658 h
->next_free
= make_number (i
);
4659 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4660 xassert (XINT (h
->count
) >= 0);
4666 idx
= HASH_NEXT (h
, i
);
4672 /* Clear hash table H. */
4676 struct Lisp_Hash_Table
*h
;
4678 if (XFASTINT (h
->count
) > 0)
4680 int i
, size
= HASH_TABLE_SIZE (h
);
4682 for (i
= 0; i
< size
; ++i
)
4684 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4685 HASH_KEY (h
, i
) = Qnil
;
4686 HASH_VALUE (h
, i
) = Qnil
;
4687 HASH_HASH (h
, i
) = Qnil
;
4690 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4691 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4693 h
->next_free
= make_number (0);
4694 h
->count
= make_number (0);
4700 /************************************************************************
4702 ************************************************************************/
4704 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4705 entries from the table that don't survive the current GC.
4706 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4707 non-zero if anything was marked. */
4710 sweep_weak_table (h
, remove_entries_p
)
4711 struct Lisp_Hash_Table
*h
;
4712 int remove_entries_p
;
4714 int bucket
, n
, marked
;
4716 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4719 for (bucket
= 0; bucket
< n
; ++bucket
)
4721 Lisp_Object idx
, next
, prev
;
4723 /* Follow collision chain, removing entries that
4724 don't survive this garbage collection. */
4726 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4728 int i
= XFASTINT (idx
);
4729 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4730 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4733 if (EQ (h
->weak
, Qkey
))
4734 remove_p
= !key_known_to_survive_p
;
4735 else if (EQ (h
->weak
, Qvalue
))
4736 remove_p
= !value_known_to_survive_p
;
4737 else if (EQ (h
->weak
, Qkey_or_value
))
4738 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4739 else if (EQ (h
->weak
, Qkey_and_value
))
4740 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4744 next
= HASH_NEXT (h
, i
);
4746 if (remove_entries_p
)
4750 /* Take out of collision chain. */
4752 HASH_INDEX (h
, bucket
) = next
;
4754 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4756 /* Add to free list. */
4757 HASH_NEXT (h
, i
) = h
->next_free
;
4760 /* Clear key, value, and hash. */
4761 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4762 HASH_HASH (h
, i
) = Qnil
;
4764 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4771 /* Make sure key and value survive. */
4772 if (!key_known_to_survive_p
)
4774 mark_object (HASH_KEY (h
, i
));
4778 if (!value_known_to_survive_p
)
4780 mark_object (HASH_VALUE (h
, i
));
4791 /* Remove elements from weak hash tables that don't survive the
4792 current garbage collection. Remove weak tables that don't survive
4793 from Vweak_hash_tables. Called from gc_sweep. */
4796 sweep_weak_hash_tables ()
4798 Lisp_Object table
, used
, next
;
4799 struct Lisp_Hash_Table
*h
;
4802 /* Mark all keys and values that are in use. Keep on marking until
4803 there is no more change. This is necessary for cases like
4804 value-weak table A containing an entry X -> Y, where Y is used in a
4805 key-weak table B, Z -> Y. If B comes after A in the list of weak
4806 tables, X -> Y might be removed from A, although when looking at B
4807 one finds that it shouldn't. */
4811 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4813 h
= XHASH_TABLE (table
);
4814 if (h
->size
& ARRAY_MARK_FLAG
)
4815 marked
|= sweep_weak_table (h
, 0);
4820 /* Remove tables and entries that aren't used. */
4821 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4823 h
= XHASH_TABLE (table
);
4824 next
= h
->next_weak
;
4826 if (h
->size
& ARRAY_MARK_FLAG
)
4828 /* TABLE is marked as used. Sweep its contents. */
4829 if (XFASTINT (h
->count
) > 0)
4830 sweep_weak_table (h
, 1);
4832 /* Add table to the list of used weak hash tables. */
4833 h
->next_weak
= used
;
4838 Vweak_hash_tables
= used
;
4843 /***********************************************************************
4844 Hash Code Computation
4845 ***********************************************************************/
4847 /* Maximum depth up to which to dive into Lisp structures. */
4849 #define SXHASH_MAX_DEPTH 3
4851 /* Maximum length up to which to take list and vector elements into
4854 #define SXHASH_MAX_LEN 7
4856 /* Combine two integers X and Y for hashing. */
4858 #define SXHASH_COMBINE(X, Y) \
4859 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4863 /* Return a hash for string PTR which has length LEN. The hash
4864 code returned is guaranteed to fit in a Lisp integer. */
4867 sxhash_string (ptr
, len
)
4871 unsigned char *p
= ptr
;
4872 unsigned char *end
= p
+ len
;
4881 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4884 return hash
& INTMASK
;
4888 /* Return a hash for list LIST. DEPTH is the current depth in the
4889 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4892 sxhash_list (list
, depth
)
4899 if (depth
< SXHASH_MAX_DEPTH
)
4901 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4902 list
= XCDR (list
), ++i
)
4904 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4905 hash
= SXHASH_COMBINE (hash
, hash2
);
4912 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4913 the Lisp structure. */
4916 sxhash_vector (vec
, depth
)
4920 unsigned hash
= XVECTOR (vec
)->size
;
4923 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4924 for (i
= 0; i
< n
; ++i
)
4926 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4927 hash
= SXHASH_COMBINE (hash
, hash2
);
4934 /* Return a hash for bool-vector VECTOR. */
4937 sxhash_bool_vector (vec
)
4940 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4943 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4944 for (i
= 0; i
< n
; ++i
)
4945 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4951 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4952 structure. Value is an unsigned integer clipped to INTMASK. */
4961 if (depth
> SXHASH_MAX_DEPTH
)
4964 switch (XTYPE (obj
))
4971 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4972 SCHARS (SYMBOL_NAME (obj
)));
4980 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4983 /* This can be everything from a vector to an overlay. */
4984 case Lisp_Vectorlike
:
4986 /* According to the CL HyperSpec, two arrays are equal only if
4987 they are `eq', except for strings and bit-vectors. In
4988 Emacs, this works differently. We have to compare element
4990 hash
= sxhash_vector (obj
, depth
);
4991 else if (BOOL_VECTOR_P (obj
))
4992 hash
= sxhash_bool_vector (obj
);
4994 /* Others are `equal' if they are `eq', so let's take their
5000 hash
= sxhash_list (obj
, depth
);
5005 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5006 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5007 for (hash
= 0; p
< e
; ++p
)
5008 hash
= SXHASH_COMBINE (hash
, *p
);
5016 return hash
& INTMASK
;
5021 /***********************************************************************
5023 ***********************************************************************/
5026 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5027 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5031 unsigned hash
= sxhash (obj
, 0);;
5032 return make_number (hash
);
5036 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5037 doc
: /* Create and return a new hash table.
5039 Arguments are specified as keyword/argument pairs. The following
5040 arguments are defined:
5042 :test TEST -- TEST must be a symbol that specifies how to compare
5043 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5044 `equal'. User-supplied test and hash functions can be specified via
5045 `define-hash-table-test'.
5047 :size SIZE -- A hint as to how many elements will be put in the table.
5050 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5051 fills up. If REHASH-SIZE is an integer, add that many space. If it
5052 is a float, it must be > 1.0, and the new size is computed by
5053 multiplying the old size with that factor. Default is 1.5.
5055 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5056 Resize the hash table when ratio of the number of entries in the
5057 table. Default is 0.8.
5059 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5060 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5061 returned is a weak table. Key/value pairs are removed from a weak
5062 hash table when there are no non-weak references pointing to their
5063 key, value, one of key or value, or both key and value, depending on
5064 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5067 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5072 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5073 Lisp_Object user_test
, user_hash
;
5077 /* The vector `used' is used to keep track of arguments that
5078 have been consumed. */
5079 used
= (char *) alloca (nargs
* sizeof *used
);
5080 bzero (used
, nargs
* sizeof *used
);
5082 /* See if there's a `:test TEST' among the arguments. */
5083 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5084 test
= i
< 0 ? Qeql
: args
[i
];
5085 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5087 /* See if it is a user-defined test. */
5090 prop
= Fget (test
, Qhash_table_test
);
5091 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5092 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5094 user_test
= XCAR (prop
);
5095 user_hash
= XCAR (XCDR (prop
));
5098 user_test
= user_hash
= Qnil
;
5100 /* See if there's a `:size SIZE' argument. */
5101 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5102 size
= i
< 0 ? Qnil
: args
[i
];
5104 size
= make_number (DEFAULT_HASH_SIZE
);
5105 else if (!INTEGERP (size
) || XINT (size
) < 0)
5107 list2 (build_string ("Invalid hash table size"),
5110 /* Look for `:rehash-size SIZE'. */
5111 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5112 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5113 if (!NUMBERP (rehash_size
)
5114 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5115 || XFLOATINT (rehash_size
) <= 1.0)
5117 list2 (build_string ("Invalid hash table rehash size"),
5120 /* Look for `:rehash-threshold THRESHOLD'. */
5121 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5122 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5123 if (!FLOATP (rehash_threshold
)
5124 || XFLOATINT (rehash_threshold
) <= 0.0
5125 || XFLOATINT (rehash_threshold
) > 1.0)
5127 list2 (build_string ("Invalid hash table rehash threshold"),
5130 /* Look for `:weakness WEAK'. */
5131 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5132 weak
= i
< 0 ? Qnil
: args
[i
];
5134 weak
= Qkey_and_value
;
5137 && !EQ (weak
, Qvalue
)
5138 && !EQ (weak
, Qkey_or_value
)
5139 && !EQ (weak
, Qkey_and_value
))
5140 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5143 /* Now, all args should have been used up, or there's a problem. */
5144 for (i
= 0; i
< nargs
; ++i
)
5147 list2 (build_string ("Invalid argument list"), args
[i
]));
5149 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5150 user_test
, user_hash
);
5154 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5155 doc
: /* Return a copy of hash table TABLE. */)
5159 return copy_hash_table (check_hash_table (table
));
5163 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5164 doc
: /* Return the number of elements in TABLE. */)
5168 return check_hash_table (table
)->count
;
5172 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5173 Shash_table_rehash_size
, 1, 1, 0,
5174 doc
: /* Return the current rehash size of TABLE. */)
5178 return check_hash_table (table
)->rehash_size
;
5182 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5183 Shash_table_rehash_threshold
, 1, 1, 0,
5184 doc
: /* Return the current rehash threshold of TABLE. */)
5188 return check_hash_table (table
)->rehash_threshold
;
5192 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5193 doc
: /* Return the size of TABLE.
5194 The size can be used as an argument to `make-hash-table' to create
5195 a hash table than can hold as many elements of TABLE holds
5196 without need for resizing. */)
5200 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5201 return make_number (HASH_TABLE_SIZE (h
));
5205 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5206 doc
: /* Return the test TABLE uses. */)
5210 return check_hash_table (table
)->test
;
5214 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5216 doc
: /* Return the weakness of TABLE. */)
5220 return check_hash_table (table
)->weak
;
5224 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5225 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5229 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5233 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5234 doc
: /* Clear hash table TABLE. */)
5238 hash_clear (check_hash_table (table
));
5243 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5244 doc
: /* Look up KEY in TABLE and return its associated value.
5245 If KEY is not found, return DFLT which defaults to nil. */)
5247 Lisp_Object key
, table
, dflt
;
5249 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5250 int i
= hash_lookup (h
, key
, NULL
);
5251 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5255 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5256 doc
: /* Associate KEY with VALUE in hash table TABLE.
5257 If KEY is already present in table, replace its current value with
5260 Lisp_Object key
, value
, table
;
5262 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5266 i
= hash_lookup (h
, key
, &hash
);
5268 HASH_VALUE (h
, i
) = value
;
5270 hash_put (h
, key
, value
, hash
);
5276 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5277 doc
: /* Remove KEY from TABLE. */)
5279 Lisp_Object key
, table
;
5281 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5282 hash_remove (h
, key
);
5287 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5288 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5289 FUNCTION is called with 2 arguments KEY and VALUE. */)
5291 Lisp_Object function
, table
;
5293 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5294 Lisp_Object args
[3];
5297 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5298 if (!NILP (HASH_HASH (h
, i
)))
5301 args
[1] = HASH_KEY (h
, i
);
5302 args
[2] = HASH_VALUE (h
, i
);
5310 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5311 Sdefine_hash_table_test
, 3, 3, 0,
5312 doc
: /* Define a new hash table test with name NAME, a symbol.
5314 In hash tables created with NAME specified as test, use TEST to
5315 compare keys, and HASH for computing hash codes of keys.
5317 TEST must be a function taking two arguments and returning non-nil if
5318 both arguments are the same. HASH must be a function taking one
5319 argument and return an integer that is the hash code of the argument.
5320 Hash code computation should use the whole value range of integers,
5321 including negative integers. */)
5323 Lisp_Object name
, test
, hash
;
5325 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5330 /************************************************************************
5332 ************************************************************************/
5337 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5338 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5340 A message digest is a cryptographic checksum of a document, and the
5341 algorithm to calculate it is defined in RFC 1321.
5343 The two optional arguments START and END are character positions
5344 specifying for which part of OBJECT the message digest should be
5345 computed. If nil or omitted, the digest is computed for the whole
5348 The MD5 message digest is computed from the result of encoding the
5349 text in a coding system, not directly from the internal Emacs form of
5350 the text. The optional fourth argument CODING-SYSTEM specifies which
5351 coding system to encode the text with. It should be the same coding
5352 system that you used or will use when actually writing the text into a
5355 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5356 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5357 system would be chosen by default for writing this text into a file.
5359 If OBJECT is a string, the most preferred coding system (see the
5360 command `prefer-coding-system') is used.
5362 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5363 guesswork fails. Normally, an error is signaled in such case. */)
5364 (object
, start
, end
, coding_system
, noerror
)
5365 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5367 unsigned char digest
[16];
5368 unsigned char value
[33];
5372 int start_char
= 0, end_char
= 0;
5373 int start_byte
= 0, end_byte
= 0;
5375 register struct buffer
*bp
;
5378 if (STRINGP (object
))
5380 if (NILP (coding_system
))
5382 /* Decide the coding-system to encode the data with. */
5384 if (STRING_MULTIBYTE (object
))
5385 /* use default, we can't guess correct value */
5386 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5388 coding_system
= Qraw_text
;
5391 if (NILP (Fcoding_system_p (coding_system
)))
5393 /* Invalid coding system. */
5395 if (!NILP (noerror
))
5396 coding_system
= Qraw_text
;
5399 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5402 if (STRING_MULTIBYTE (object
))
5403 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5405 size
= SCHARS (object
);
5406 size_byte
= SBYTES (object
);
5410 CHECK_NUMBER (start
);
5412 start_char
= XINT (start
);
5417 start_byte
= string_char_to_byte (object
, start_char
);
5423 end_byte
= size_byte
;
5429 end_char
= XINT (end
);
5434 end_byte
= string_char_to_byte (object
, end_char
);
5437 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5438 args_out_of_range_3 (object
, make_number (start_char
),
5439 make_number (end_char
));
5443 CHECK_BUFFER (object
);
5445 bp
= XBUFFER (object
);
5451 CHECK_NUMBER_COERCE_MARKER (start
);
5459 CHECK_NUMBER_COERCE_MARKER (end
);
5464 temp
= b
, b
= e
, e
= temp
;
5466 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5467 args_out_of_range (start
, end
);
5469 if (NILP (coding_system
))
5471 /* Decide the coding-system to encode the data with.
5472 See fileio.c:Fwrite-region */
5474 if (!NILP (Vcoding_system_for_write
))
5475 coding_system
= Vcoding_system_for_write
;
5478 int force_raw_text
= 0;
5480 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5481 if (NILP (coding_system
)
5482 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5484 coding_system
= Qnil
;
5485 if (NILP (current_buffer
->enable_multibyte_characters
))
5489 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5491 /* Check file-coding-system-alist. */
5492 Lisp_Object args
[4], val
;
5494 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5495 args
[3] = Fbuffer_file_name(object
);
5496 val
= Ffind_operation_coding_system (4, args
);
5497 if (CONSP (val
) && !NILP (XCDR (val
)))
5498 coding_system
= XCDR (val
);
5501 if (NILP (coding_system
)
5502 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5504 /* If we still have not decided a coding system, use the
5505 default value of buffer-file-coding-system. */
5506 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5510 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5511 /* Confirm that VAL can surely encode the current region. */
5512 coding_system
= call4 (Vselect_safe_coding_system_function
,
5513 make_number (b
), make_number (e
),
5514 coding_system
, Qnil
);
5517 coding_system
= Qraw_text
;
5520 if (NILP (Fcoding_system_p (coding_system
)))
5522 /* Invalid coding system. */
5524 if (!NILP (noerror
))
5525 coding_system
= Qraw_text
;
5528 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5532 object
= make_buffer_string (b
, e
, 0);
5534 if (STRING_MULTIBYTE (object
))
5535 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5538 md5_buffer (SDATA (object
) + start_byte
,
5539 SBYTES (object
) - (size_byte
- end_byte
),
5542 for (i
= 0; i
< 16; i
++)
5543 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5546 return make_string (value
, 32);
5553 /* Hash table stuff. */
5554 Qhash_table_p
= intern ("hash-table-p");
5555 staticpro (&Qhash_table_p
);
5556 Qeq
= intern ("eq");
5558 Qeql
= intern ("eql");
5560 Qequal
= intern ("equal");
5561 staticpro (&Qequal
);
5562 QCtest
= intern (":test");
5563 staticpro (&QCtest
);
5564 QCsize
= intern (":size");
5565 staticpro (&QCsize
);
5566 QCrehash_size
= intern (":rehash-size");
5567 staticpro (&QCrehash_size
);
5568 QCrehash_threshold
= intern (":rehash-threshold");
5569 staticpro (&QCrehash_threshold
);
5570 QCweakness
= intern (":weakness");
5571 staticpro (&QCweakness
);
5572 Qkey
= intern ("key");
5574 Qvalue
= intern ("value");
5575 staticpro (&Qvalue
);
5576 Qhash_table_test
= intern ("hash-table-test");
5577 staticpro (&Qhash_table_test
);
5578 Qkey_or_value
= intern ("key-or-value");
5579 staticpro (&Qkey_or_value
);
5580 Qkey_and_value
= intern ("key-and-value");
5581 staticpro (&Qkey_and_value
);
5584 defsubr (&Smake_hash_table
);
5585 defsubr (&Scopy_hash_table
);
5586 defsubr (&Shash_table_count
);
5587 defsubr (&Shash_table_rehash_size
);
5588 defsubr (&Shash_table_rehash_threshold
);
5589 defsubr (&Shash_table_size
);
5590 defsubr (&Shash_table_test
);
5591 defsubr (&Shash_table_weakness
);
5592 defsubr (&Shash_table_p
);
5593 defsubr (&Sclrhash
);
5594 defsubr (&Sgethash
);
5595 defsubr (&Sputhash
);
5596 defsubr (&Sremhash
);
5597 defsubr (&Smaphash
);
5598 defsubr (&Sdefine_hash_table_test
);
5600 Qstring_lessp
= intern ("string-lessp");
5601 staticpro (&Qstring_lessp
);
5602 Qprovide
= intern ("provide");
5603 staticpro (&Qprovide
);
5604 Qrequire
= intern ("require");
5605 staticpro (&Qrequire
);
5606 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5607 staticpro (&Qyes_or_no_p_history
);
5608 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5609 staticpro (&Qcursor_in_echo_area
);
5610 Qwidget_type
= intern ("widget-type");
5611 staticpro (&Qwidget_type
);
5613 staticpro (&string_char_byte_cache_string
);
5614 string_char_byte_cache_string
= Qnil
;
5616 require_nesting_list
= Qnil
;
5617 staticpro (&require_nesting_list
);
5619 Fset (Qyes_or_no_p_history
, Qnil
);
5621 DEFVAR_LISP ("features", &Vfeatures
,
5622 doc
: /* A list of symbols which are the features of the executing emacs.
5623 Used by `featurep' and `require', and altered by `provide'. */);
5625 Qsubfeatures
= intern ("subfeatures");
5626 staticpro (&Qsubfeatures
);
5628 #ifdef HAVE_LANGINFO_CODESET
5629 Qcodeset
= intern ("codeset");
5630 staticpro (&Qcodeset
);
5631 Qdays
= intern ("days");
5633 Qmonths
= intern ("months");
5634 staticpro (&Qmonths
);
5635 Qpaper
= intern ("paper");
5636 staticpro (&Qpaper
);
5637 #endif /* HAVE_LANGINFO_CODESET */
5639 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5640 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5641 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5642 invoked by mouse clicks and mouse menu items. */);
5645 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5646 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5647 This applies to commands from menus and tool bar buttons. The value of
5648 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5649 used if both `use-dialog-box' and this variable are non-nil. */);
5650 use_file_dialog
= 1;
5652 defsubr (&Sidentity
);
5655 defsubr (&Ssafe_length
);
5656 defsubr (&Sstring_bytes
);
5657 defsubr (&Sstring_equal
);
5658 defsubr (&Scompare_strings
);
5659 defsubr (&Sstring_lessp
);
5662 defsubr (&Svconcat
);
5663 defsubr (&Scopy_sequence
);
5664 defsubr (&Sstring_make_multibyte
);
5665 defsubr (&Sstring_make_unibyte
);
5666 defsubr (&Sstring_as_multibyte
);
5667 defsubr (&Sstring_as_unibyte
);
5668 defsubr (&Sstring_to_multibyte
);
5669 defsubr (&Scopy_alist
);
5670 defsubr (&Ssubstring
);
5671 defsubr (&Ssubstring_no_properties
);
5683 defsubr (&Snreverse
);
5684 defsubr (&Sreverse
);
5686 defsubr (&Splist_get
);
5688 defsubr (&Splist_put
);
5690 defsubr (&Slax_plist_get
);
5691 defsubr (&Slax_plist_put
);
5693 defsubr (&Sfillarray
);
5694 defsubr (&Sclear_string
);
5695 defsubr (&Schar_table_subtype
);
5696 defsubr (&Schar_table_parent
);
5697 defsubr (&Sset_char_table_parent
);
5698 defsubr (&Schar_table_extra_slot
);
5699 defsubr (&Sset_char_table_extra_slot
);
5700 defsubr (&Schar_table_range
);
5701 defsubr (&Sset_char_table_range
);
5702 defsubr (&Sset_char_table_default
);
5703 defsubr (&Soptimize_char_table
);
5704 defsubr (&Smap_char_table
);
5708 defsubr (&Smapconcat
);
5709 defsubr (&Sy_or_n_p
);
5710 defsubr (&Syes_or_no_p
);
5711 defsubr (&Sload_average
);
5712 defsubr (&Sfeaturep
);
5713 defsubr (&Srequire
);
5714 defsubr (&Sprovide
);
5715 defsubr (&Splist_member
);
5716 defsubr (&Swidget_put
);
5717 defsubr (&Swidget_get
);
5718 defsubr (&Swidget_apply
);
5719 defsubr (&Sbase64_encode_region
);
5720 defsubr (&Sbase64_decode_region
);
5721 defsubr (&Sbase64_encode_string
);
5722 defsubr (&Sbase64_decode_string
);
5724 defsubr (&Slocale_info
);
5731 Vweak_hash_tables
= Qnil
;
5734 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5735 (do not change this comment) */