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 29 bits' worth.
99 With positive integer argument N, return random number in interval [0,N).
100 With argument t, set the random number seed from the current time and pid. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (n
) && XFASTINT (n
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (n
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
145 if (STRINGP (sequence
))
146 XSETFASTINT (val
, SCHARS (sequence
));
147 else if (VECTORP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
149 else if (SUB_CHAR_TABLE_P (sequence
))
150 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
151 else if (CHAR_TABLE_P (sequence
))
152 XSETFASTINT (val
, MAX_CHAR
);
153 else if (BOOL_VECTOR_P (sequence
))
154 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
155 else if (COMPILEDP (sequence
))
156 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
157 else if (CONSP (sequence
))
160 while (CONSP (sequence
))
162 sequence
= XCDR (sequence
);
165 if (!CONSP (sequence
))
168 sequence
= XCDR (sequence
);
173 if (!NILP (sequence
))
174 wrong_type_argument (Qlistp
, sequence
);
176 val
= make_number (i
);
178 else if (NILP (sequence
))
179 XSETFASTINT (val
, 0);
182 sequence
= wrong_type_argument (Qsequencep
, sequence
);
188 /* This does not check for quits. That is safe
189 since it must terminate. */
191 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
192 doc
: /* Return the length of a list, but avoid error or infinite loop.
193 This function never gets an error. If LIST is not really a list,
194 it returns 0. If LIST is circular, it returns a finite value
195 which is at least the number of distinct elements. */)
199 Lisp_Object tail
, halftail
, length
;
202 /* halftail is used to detect circular lists. */
204 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
206 if (EQ (tail
, halftail
) && len
!= 0)
210 halftail
= XCDR (halftail
);
213 XSETINT (length
, len
);
217 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
218 doc
: /* Return the number of bytes in STRING.
219 If STRING is a multibyte string, this is greater than the length of STRING. */)
223 CHECK_STRING (string
);
224 return make_number (SBYTES (string
));
227 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
228 doc
: /* Return t if two strings have identical contents.
229 Case is significant, but text properties are ignored.
230 Symbols are also allowed; their print names are used instead. */)
232 register Lisp_Object s1
, s2
;
235 s1
= SYMBOL_NAME (s1
);
237 s2
= SYMBOL_NAME (s2
);
241 if (SCHARS (s1
) != SCHARS (s2
)
242 || SBYTES (s1
) != SBYTES (s2
)
243 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
248 DEFUN ("compare-strings", Fcompare_strings
,
249 Scompare_strings
, 6, 7, 0,
250 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
251 In string STR1, skip the first START1 characters and stop at END1.
252 In string STR2, skip the first START2 characters and stop at END2.
253 END1 and END2 default to the full lengths of the respective strings.
255 Case is significant in this comparison if IGNORE-CASE is nil.
256 Unibyte strings are converted to multibyte for comparison.
258 The value is t if the strings (or specified portions) match.
259 If string STR1 is less, the value is a negative number N;
260 - 1 - N is the number of characters that match at the beginning.
261 If string STR1 is greater, the value is a positive number N;
262 N - 1 is the number of characters that match at the beginning. */)
263 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
264 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
266 register int end1_char
, end2_char
;
267 register int i1
, i1_byte
, i2
, i2_byte
;
272 start1
= make_number (0);
274 start2
= make_number (0);
275 CHECK_NATNUM (start1
);
276 CHECK_NATNUM (start2
);
285 i1_byte
= string_char_to_byte (str1
, i1
);
286 i2_byte
= string_char_to_byte (str2
, i2
);
288 end1_char
= SCHARS (str1
);
289 if (! NILP (end1
) && end1_char
> XINT (end1
))
290 end1_char
= XINT (end1
);
292 end2_char
= SCHARS (str2
);
293 if (! NILP (end2
) && end2_char
> XINT (end2
))
294 end2_char
= XINT (end2
);
296 while (i1
< end1_char
&& i2
< end2_char
)
298 /* When we find a mismatch, we must compare the
299 characters, not just the bytes. */
302 if (STRING_MULTIBYTE (str1
))
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
306 c1
= SREF (str1
, i1
++);
307 c1
= unibyte_char_to_multibyte (c1
);
310 if (STRING_MULTIBYTE (str2
))
311 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
314 c2
= SREF (str2
, i2
++);
315 c2
= unibyte_char_to_multibyte (c2
);
321 if (! NILP (ignore_case
))
325 tem
= Fupcase (make_number (c1
));
327 tem
= Fupcase (make_number (c2
));
334 /* Note that I1 has already been incremented
335 past the character that we are comparing;
336 hence we don't add or subtract 1 here. */
338 return make_number (- i1
+ XINT (start1
));
340 return make_number (i1
- XINT (start1
));
344 return make_number (i1
- XINT (start1
) + 1);
346 return make_number (- i1
+ XINT (start1
) - 1);
351 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
352 doc
: /* Return t if first arg string is less than second in lexicographic order.
354 Symbols are also allowed; their print names are used instead. */)
356 register Lisp_Object s1
, s2
;
359 register int i1
, i1_byte
, i2
, i2_byte
;
362 s1
= SYMBOL_NAME (s1
);
364 s2
= SYMBOL_NAME (s2
);
368 i1
= i1_byte
= i2
= i2_byte
= 0;
371 if (end
> SCHARS (s2
))
376 /* When we find a mismatch, we must compare the
377 characters, not just the bytes. */
380 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
381 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
384 return c1
< c2
? Qt
: Qnil
;
386 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
389 static Lisp_Object
concat ();
400 return concat (2, args
, Lisp_String
, 0);
402 return concat (2, &s1
, Lisp_String
, 0);
403 #endif /* NO_ARG_ARRAY */
409 Lisp_Object s1
, s2
, s3
;
416 return concat (3, args
, Lisp_String
, 0);
418 return concat (3, &s1
, Lisp_String
, 0);
419 #endif /* NO_ARG_ARRAY */
422 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
423 doc
: /* Concatenate all the arguments and make the result a list.
424 The result is a list whose elements are the elements of all the arguments.
425 Each argument may be a list, vector or string.
426 The last argument is not copied, just used as the tail of the new list.
427 usage: (append &rest SEQUENCES) */)
432 return concat (nargs
, args
, Lisp_Cons
, 1);
435 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
436 doc
: /* Concatenate all the arguments and make the result a string.
437 The result is a string whose elements are the elements of all the arguments.
438 Each argument may be a string or a list or vector of characters (integers).
439 usage: (concat &rest SEQUENCES) */)
444 return concat (nargs
, args
, Lisp_String
, 0);
447 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
448 doc
: /* Concatenate all the arguments and make the result a vector.
449 The result is a vector whose elements are the elements of all the arguments.
450 Each argument may be a list, vector or string.
451 usage: (vconcat &rest SEQUENCES) */)
456 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
459 /* Return a copy of a sub char table ARG. The elements except for a
460 nested sub char table are not copied. */
462 copy_sub_char_table (arg
)
465 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
468 /* Copy all the contents. */
469 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
470 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
471 /* Recursively copy any sub char-tables in the ordinary slots. */
472 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
473 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
474 XCHAR_TABLE (copy
)->contents
[i
]
475 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
481 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
482 doc
: /* Return a copy of a list, vector, string or char-table.
483 The elements of a list or vector are not copied; they are shared
484 with the original. */)
488 if (NILP (arg
)) return arg
;
490 if (CHAR_TABLE_P (arg
))
495 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
496 /* Copy all the slots, including the extra ones. */
497 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
498 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
499 * sizeof (Lisp_Object
)));
501 /* Recursively copy any sub char tables in the ordinary slots
502 for multibyte characters. */
503 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
504 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
505 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
506 XCHAR_TABLE (copy
)->contents
[i
]
507 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
512 if (BOOL_VECTOR_P (arg
))
516 = (XBOOL_VECTOR (arg
)->size
+ 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 best_below
= best_below_byte
= 0;
888 best_above
= SCHARS (string
);
889 best_above_byte
= SBYTES (string
);
890 if (best_above
== best_above_byte
)
893 if (EQ (string
, string_char_byte_cache_string
))
895 if (string_char_byte_cache_charpos
< char_index
)
897 best_below
= string_char_byte_cache_charpos
;
898 best_below_byte
= string_char_byte_cache_bytepos
;
902 best_above
= string_char_byte_cache_charpos
;
903 best_above_byte
= string_char_byte_cache_bytepos
;
907 if (char_index
- best_below
< best_above
- char_index
)
909 while (best_below
< char_index
)
912 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
913 best_below
, best_below_byte
);
916 i_byte
= best_below_byte
;
920 while (best_above
> char_index
)
922 unsigned char *pend
= SDATA (string
) + best_above_byte
;
923 unsigned char *pbeg
= pend
- best_above_byte
;
924 unsigned char *p
= pend
- 1;
927 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
928 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
929 if (bytes
== pend
- p
)
930 best_above_byte
-= bytes
;
931 else if (bytes
> pend
- p
)
932 best_above_byte
-= (pend
- p
);
938 i_byte
= best_above_byte
;
941 string_char_byte_cache_bytepos
= i_byte
;
942 string_char_byte_cache_charpos
= i
;
943 string_char_byte_cache_string
= string
;
948 /* Return the character index corresponding to BYTE_INDEX in STRING. */
951 string_byte_to_char (string
, byte_index
)
956 int best_below
, best_below_byte
;
957 int best_above
, best_above_byte
;
959 best_below
= best_below_byte
= 0;
960 best_above
= SCHARS (string
);
961 best_above_byte
= SBYTES (string
);
962 if (best_above
== best_above_byte
)
965 if (EQ (string
, string_char_byte_cache_string
))
967 if (string_char_byte_cache_bytepos
< byte_index
)
969 best_below
= string_char_byte_cache_charpos
;
970 best_below_byte
= string_char_byte_cache_bytepos
;
974 best_above
= string_char_byte_cache_charpos
;
975 best_above_byte
= string_char_byte_cache_bytepos
;
979 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
981 while (best_below_byte
< byte_index
)
984 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
985 best_below
, best_below_byte
);
988 i_byte
= best_below_byte
;
992 while (best_above_byte
> byte_index
)
994 unsigned char *pend
= SDATA (string
) + best_above_byte
;
995 unsigned char *pbeg
= pend
- best_above_byte
;
996 unsigned char *p
= pend
- 1;
999 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
1000 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
1001 if (bytes
== pend
- p
)
1002 best_above_byte
-= bytes
;
1003 else if (bytes
> pend
- p
)
1004 best_above_byte
-= (pend
- p
);
1010 i_byte
= best_above_byte
;
1013 string_char_byte_cache_bytepos
= i_byte
;
1014 string_char_byte_cache_charpos
= i
;
1015 string_char_byte_cache_string
= string
;
1020 /* Convert STRING to a multibyte string.
1021 Single-byte characters 0240 through 0377 are converted
1022 by adding nonascii_insert_offset to each. */
1025 string_make_multibyte (string
)
1031 if (STRING_MULTIBYTE (string
))
1034 nbytes
= count_size_as_multibyte (SDATA (string
),
1036 /* If all the chars are ASCII, they won't need any more bytes
1037 once converted. In that case, we can return STRING itself. */
1038 if (nbytes
== SBYTES (string
))
1041 buf
= (unsigned char *) alloca (nbytes
);
1042 copy_text (SDATA (string
), buf
, SBYTES (string
),
1045 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1049 /* Convert STRING to a multibyte string without changing each
1050 character codes. Thus, characters 0200 trough 0237 are converted
1051 to eight-bit-control characters, and characters 0240 through 0377
1052 are converted eight-bit-graphic characters. */
1055 string_to_multibyte (string
)
1061 if (STRING_MULTIBYTE (string
))
1064 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1065 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1066 any more bytes once converted. */
1067 if (nbytes
== SBYTES (string
))
1068 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1070 buf
= (unsigned char *) alloca (nbytes
);
1071 bcopy (SDATA (string
), buf
, SBYTES (string
));
1072 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1074 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1078 /* Convert STRING to a single-byte string. */
1081 string_make_unibyte (string
)
1086 if (! STRING_MULTIBYTE (string
))
1089 buf
= (unsigned char *) alloca (SCHARS (string
));
1091 copy_text (SDATA (string
), buf
, SBYTES (string
),
1094 return make_unibyte_string (buf
, SCHARS (string
));
1097 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1099 doc
: /* Return the multibyte equivalent of STRING.
1100 If STRING is unibyte and contains non-ASCII characters, the function
1101 `unibyte-char-to-multibyte' is used to convert each unibyte character
1102 to a multibyte character. In this case, the returned string is a
1103 newly created string with no text properties. If STRING is multibyte
1104 or entirely ASCII, it is returned unchanged. In particular, when
1105 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1106 \(When the characters are all ASCII, Emacs primitives will treat the
1107 string the same way whether it is unibyte or multibyte.) */)
1111 CHECK_STRING (string
);
1113 return string_make_multibyte (string
);
1116 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1118 doc
: /* Return the unibyte equivalent of STRING.
1119 Multibyte character codes are converted to unibyte according to
1120 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1121 If the lookup in the translation table fails, this function takes just
1122 the low 8 bits of each character. */)
1126 CHECK_STRING (string
);
1128 return string_make_unibyte (string
);
1131 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1133 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1134 If STRING is unibyte, the result is STRING itself.
1135 Otherwise it is a newly created string, with no text properties.
1136 If STRING is multibyte and contains a character of charset
1137 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1138 corresponding single byte. */)
1142 CHECK_STRING (string
);
1144 if (STRING_MULTIBYTE (string
))
1146 int bytes
= SBYTES (string
);
1147 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1149 bcopy (SDATA (string
), str
, bytes
);
1150 bytes
= str_as_unibyte (str
, bytes
);
1151 string
= make_unibyte_string (str
, bytes
);
1157 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1159 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1160 If STRING is multibyte, the result is STRING itself.
1161 Otherwise it is a newly created string, with no text properties.
1162 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1163 part of a multibyte form), it is converted to the corresponding
1164 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1168 CHECK_STRING (string
);
1170 if (! STRING_MULTIBYTE (string
))
1172 Lisp_Object new_string
;
1175 parse_str_as_multibyte (SDATA (string
),
1178 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1179 bcopy (SDATA (string
), SDATA (new_string
),
1181 if (nbytes
!= SBYTES (string
))
1182 str_as_multibyte (SDATA (new_string
), nbytes
,
1183 SBYTES (string
), NULL
);
1184 string
= new_string
;
1185 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1190 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1192 doc
: /* Return a multibyte string with the same individual chars as STRING.
1193 If STRING is multibyte, the result is STRING itself.
1194 Otherwise it is a newly created string, with no text properties.
1195 Characters 0200 through 0237 are converted to eight-bit-control
1196 characters of the same character code. Characters 0240 through 0377
1197 are converted to eight-bit-graphic characters of the same character
1202 CHECK_STRING (string
);
1204 return string_to_multibyte (string
);
1208 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1209 doc
: /* Return a copy of ALIST.
1210 This is an alist which represents the same mapping from objects to objects,
1211 but does not share the alist structure with ALIST.
1212 The objects mapped (cars and cdrs of elements of the alist)
1213 are shared, however.
1214 Elements of ALIST that are not conses are also shared. */)
1218 register Lisp_Object tem
;
1223 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1224 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1226 register Lisp_Object car
;
1230 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1235 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1236 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1237 TO may be nil or omitted; then the substring runs to the end of STRING.
1238 FROM and TO start at 0. If either is negative, it counts from the end.
1240 This function allows vectors as well as strings. */)
1243 register Lisp_Object from
, to
;
1248 int from_char
, to_char
;
1249 int from_byte
= 0, to_byte
= 0;
1251 if (! (STRINGP (string
) || VECTORP (string
)))
1252 wrong_type_argument (Qarrayp
, string
);
1254 CHECK_NUMBER (from
);
1256 if (STRINGP (string
))
1258 size
= SCHARS (string
);
1259 size_byte
= SBYTES (string
);
1262 size
= XVECTOR (string
)->size
;
1267 to_byte
= size_byte
;
1273 to_char
= XINT (to
);
1277 if (STRINGP (string
))
1278 to_byte
= string_char_to_byte (string
, to_char
);
1281 from_char
= XINT (from
);
1284 if (STRINGP (string
))
1285 from_byte
= string_char_to_byte (string
, from_char
);
1287 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1288 args_out_of_range_3 (string
, make_number (from_char
),
1289 make_number (to_char
));
1291 if (STRINGP (string
))
1293 res
= make_specified_string (SDATA (string
) + from_byte
,
1294 to_char
- from_char
, to_byte
- from_byte
,
1295 STRING_MULTIBYTE (string
));
1296 copy_text_properties (make_number (from_char
), make_number (to_char
),
1297 string
, make_number (0), res
, Qnil
);
1300 res
= Fvector (to_char
- from_char
,
1301 XVECTOR (string
)->contents
+ from_char
);
1307 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1308 doc
: /* Return a substring of STRING, without text properties.
1309 It starts at index FROM and ending before TO.
1310 TO may be nil or omitted; then the substring runs to the end of STRING.
1311 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1312 If FROM or TO is negative, it counts from the end.
1314 With one argument, just copy STRING without its properties. */)
1317 register Lisp_Object from
, to
;
1319 int size
, size_byte
;
1320 int from_char
, to_char
;
1321 int from_byte
, to_byte
;
1323 CHECK_STRING (string
);
1325 size
= SCHARS (string
);
1326 size_byte
= SBYTES (string
);
1329 from_char
= from_byte
= 0;
1332 CHECK_NUMBER (from
);
1333 from_char
= XINT (from
);
1337 from_byte
= string_char_to_byte (string
, from_char
);
1343 to_byte
= size_byte
;
1349 to_char
= XINT (to
);
1353 to_byte
= string_char_to_byte (string
, to_char
);
1356 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1357 args_out_of_range_3 (string
, make_number (from_char
),
1358 make_number (to_char
));
1360 return make_specified_string (SDATA (string
) + from_byte
,
1361 to_char
- from_char
, to_byte
- from_byte
,
1362 STRING_MULTIBYTE (string
));
1365 /* Extract a substring of STRING, giving start and end positions
1366 both in characters and in bytes. */
1369 substring_both (string
, from
, from_byte
, to
, to_byte
)
1371 int from
, from_byte
, to
, to_byte
;
1377 if (! (STRINGP (string
) || VECTORP (string
)))
1378 wrong_type_argument (Qarrayp
, string
);
1380 if (STRINGP (string
))
1382 size
= SCHARS (string
);
1383 size_byte
= SBYTES (string
);
1386 size
= XVECTOR (string
)->size
;
1388 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1389 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1391 if (STRINGP (string
))
1393 res
= make_specified_string (SDATA (string
) + from_byte
,
1394 to
- from
, to_byte
- from_byte
,
1395 STRING_MULTIBYTE (string
));
1396 copy_text_properties (make_number (from
), make_number (to
),
1397 string
, make_number (0), res
, Qnil
);
1400 res
= Fvector (to
- from
,
1401 XVECTOR (string
)->contents
+ from
);
1406 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1407 doc
: /* Take cdr N times on LIST, returns the result. */)
1410 register Lisp_Object list
;
1412 register int i
, num
;
1415 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1419 wrong_type_argument (Qlistp
, list
);
1425 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1426 doc
: /* Return the Nth element of LIST.
1427 N counts from zero. If LIST is not that long, nil is returned. */)
1429 Lisp_Object n
, list
;
1431 return Fcar (Fnthcdr (n
, list
));
1434 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1435 doc
: /* Return element of SEQUENCE at index N. */)
1437 register Lisp_Object sequence
, n
;
1442 if (CONSP (sequence
) || NILP (sequence
))
1443 return Fcar (Fnthcdr (n
, sequence
));
1444 else if (STRINGP (sequence
) || VECTORP (sequence
)
1445 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1446 return Faref (sequence
, n
);
1448 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1452 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1453 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1454 The value is actually the tail of LIST whose car is ELT. */)
1456 register Lisp_Object elt
;
1459 register Lisp_Object tail
;
1460 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1462 register Lisp_Object tem
;
1464 wrong_type_argument (Qlistp
, list
);
1466 if (! NILP (Fequal (elt
, tem
)))
1473 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1474 doc
: /* Return non-nil if ELT is an element of LIST.
1475 Comparison done with EQ. The value is actually the tail of LIST
1476 whose car is ELT. */)
1478 Lisp_Object elt
, list
;
1482 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1486 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1490 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1497 if (!CONSP (list
) && !NILP (list
))
1498 list
= wrong_type_argument (Qlistp
, list
);
1503 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1504 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1505 The value is actually the first element of LIST whose car is KEY.
1506 Elements of LIST that are not conses are ignored. */)
1508 Lisp_Object key
, list
;
1515 || (CONSP (XCAR (list
))
1516 && EQ (XCAR (XCAR (list
)), key
)))
1521 || (CONSP (XCAR (list
))
1522 && EQ (XCAR (XCAR (list
)), key
)))
1527 || (CONSP (XCAR (list
))
1528 && EQ (XCAR (XCAR (list
)), key
)))
1536 result
= XCAR (list
);
1537 else if (NILP (list
))
1540 result
= wrong_type_argument (Qlistp
, list
);
1545 /* Like Fassq but never report an error and do not allow quits.
1546 Use only on lists known never to be circular. */
1549 assq_no_quit (key
, list
)
1550 Lisp_Object key
, list
;
1553 && (!CONSP (XCAR (list
))
1554 || !EQ (XCAR (XCAR (list
)), key
)))
1557 return CONSP (list
) ? XCAR (list
) : Qnil
;
1560 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1561 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1562 The value is actually the first element of LIST whose car equals KEY. */)
1564 Lisp_Object key
, list
;
1566 Lisp_Object result
, car
;
1571 || (CONSP (XCAR (list
))
1572 && (car
= XCAR (XCAR (list
)),
1573 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1578 || (CONSP (XCAR (list
))
1579 && (car
= XCAR (XCAR (list
)),
1580 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1585 || (CONSP (XCAR (list
))
1586 && (car
= XCAR (XCAR (list
)),
1587 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1595 result
= XCAR (list
);
1596 else if (NILP (list
))
1599 result
= wrong_type_argument (Qlistp
, list
);
1604 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1605 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1606 The value is actually the first element of LIST whose cdr is KEY. */)
1608 register Lisp_Object key
;
1616 || (CONSP (XCAR (list
))
1617 && EQ (XCDR (XCAR (list
)), key
)))
1622 || (CONSP (XCAR (list
))
1623 && EQ (XCDR (XCAR (list
)), key
)))
1628 || (CONSP (XCAR (list
))
1629 && EQ (XCDR (XCAR (list
)), key
)))
1638 else if (CONSP (list
))
1639 result
= XCAR (list
);
1641 result
= wrong_type_argument (Qlistp
, list
);
1646 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1647 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1648 The value is actually the first element of LIST whose cdr equals KEY. */)
1650 Lisp_Object key
, list
;
1652 Lisp_Object result
, cdr
;
1657 || (CONSP (XCAR (list
))
1658 && (cdr
= XCDR (XCAR (list
)),
1659 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1664 || (CONSP (XCAR (list
))
1665 && (cdr
= XCDR (XCAR (list
)),
1666 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1671 || (CONSP (XCAR (list
))
1672 && (cdr
= XCDR (XCAR (list
)),
1673 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1681 result
= XCAR (list
);
1682 else if (NILP (list
))
1685 result
= wrong_type_argument (Qlistp
, list
);
1690 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1691 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1692 The modified LIST is returned. Comparison is done with `eq'.
1693 If the first member of LIST is ELT, there is no way to remove it by side effect;
1694 therefore, write `(setq foo (delq element foo))'
1695 to be sure of changing the value of `foo'. */)
1697 register Lisp_Object elt
;
1700 register Lisp_Object tail
, prev
;
1701 register Lisp_Object tem
;
1705 while (!NILP (tail
))
1708 wrong_type_argument (Qlistp
, list
);
1715 Fsetcdr (prev
, XCDR (tail
));
1725 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1726 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1727 SEQ must be a list, a vector, or a string.
1728 The modified SEQ is returned. Comparison is done with `equal'.
1729 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1730 is not a side effect; it is simply using a different sequence.
1731 Therefore, write `(setq foo (delete element foo))'
1732 to be sure of changing the value of `foo'. */)
1734 Lisp_Object elt
, seq
;
1740 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1741 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1744 if (n
!= ASIZE (seq
))
1746 struct Lisp_Vector
*p
= allocate_vector (n
);
1748 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1749 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1750 p
->contents
[n
++] = AREF (seq
, i
);
1752 XSETVECTOR (seq
, p
);
1755 else if (STRINGP (seq
))
1757 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1760 for (i
= nchars
= nbytes
= ibyte
= 0;
1762 ++i
, ibyte
+= cbytes
)
1764 if (STRING_MULTIBYTE (seq
))
1766 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1767 SBYTES (seq
) - ibyte
);
1768 cbytes
= CHAR_BYTES (c
);
1776 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1783 if (nchars
!= SCHARS (seq
))
1787 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1788 if (!STRING_MULTIBYTE (seq
))
1789 STRING_SET_UNIBYTE (tem
);
1791 for (i
= nchars
= nbytes
= ibyte
= 0;
1793 ++i
, ibyte
+= cbytes
)
1795 if (STRING_MULTIBYTE (seq
))
1797 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1798 SBYTES (seq
) - ibyte
);
1799 cbytes
= CHAR_BYTES (c
);
1807 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1809 unsigned char *from
= SDATA (seq
) + ibyte
;
1810 unsigned char *to
= SDATA (tem
) + nbytes
;
1816 for (n
= cbytes
; n
--; )
1826 Lisp_Object tail
, prev
;
1828 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1831 wrong_type_argument (Qlistp
, seq
);
1833 if (!NILP (Fequal (elt
, XCAR (tail
))))
1838 Fsetcdr (prev
, XCDR (tail
));
1849 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1850 doc
: /* Reverse LIST by modifying cdr pointers.
1851 Return the reversed list. */)
1855 register Lisp_Object prev
, tail
, next
;
1857 if (NILP (list
)) return list
;
1860 while (!NILP (tail
))
1864 wrong_type_argument (Qlistp
, list
);
1866 Fsetcdr (tail
, prev
);
1873 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1874 doc
: /* Reverse LIST, copying. Return the reversed list.
1875 See also the function `nreverse', which is used more often. */)
1881 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1884 new = Fcons (XCAR (list
), new);
1887 wrong_type_argument (Qconsp
, list
);
1891 Lisp_Object
merge ();
1893 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1894 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1895 Returns the sorted list. LIST is modified by side effects.
1896 PREDICATE is called with two elements of LIST, and should return t
1897 if the first element is "less" than the second. */)
1899 Lisp_Object list
, predicate
;
1901 Lisp_Object front
, back
;
1902 register Lisp_Object len
, tem
;
1903 struct gcpro gcpro1
, gcpro2
;
1904 register int length
;
1907 len
= Flength (list
);
1908 length
= XINT (len
);
1912 XSETINT (len
, (length
/ 2) - 1);
1913 tem
= Fnthcdr (len
, list
);
1915 Fsetcdr (tem
, Qnil
);
1917 GCPRO2 (front
, back
);
1918 front
= Fsort (front
, predicate
);
1919 back
= Fsort (back
, predicate
);
1921 return merge (front
, back
, predicate
);
1925 merge (org_l1
, org_l2
, pred
)
1926 Lisp_Object org_l1
, org_l2
;
1930 register Lisp_Object tail
;
1932 register Lisp_Object l1
, l2
;
1933 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1940 /* It is sufficient to protect org_l1 and org_l2.
1941 When l1 and l2 are updated, we copy the new values
1942 back into the org_ vars. */
1943 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1963 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1979 Fsetcdr (tail
, tem
);
1985 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1986 doc
: /* Extract a value from a property list.
1987 PLIST is a property list, which is a list of the form
1988 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1989 corresponding to the given PROP, or nil if PROP is not
1990 one of the properties on the list. */)
1998 CONSP (tail
) && CONSP (XCDR (tail
));
1999 tail
= XCDR (XCDR (tail
)))
2001 if (EQ (prop
, XCAR (tail
)))
2002 return XCAR (XCDR (tail
));
2004 /* This function can be called asynchronously
2005 (setup_coding_system). Don't QUIT in that case. */
2006 if (!interrupt_input_blocked
)
2011 wrong_type_argument (Qlistp
, prop
);
2016 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2017 doc
: /* Return the value of SYMBOL's PROPNAME property.
2018 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2020 Lisp_Object symbol
, propname
;
2022 CHECK_SYMBOL (symbol
);
2023 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2026 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2027 doc
: /* Change value in PLIST of PROP to VAL.
2028 PLIST is a property list, which is a list of the form
2029 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2030 If PROP is already a property on the list, its value is set to VAL,
2031 otherwise the new PROP VAL pair is added. The new plist is returned;
2032 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2033 The PLIST is modified by side effects. */)
2036 register Lisp_Object prop
;
2039 register Lisp_Object tail
, prev
;
2040 Lisp_Object newcell
;
2042 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2043 tail
= XCDR (XCDR (tail
)))
2045 if (EQ (prop
, XCAR (tail
)))
2047 Fsetcar (XCDR (tail
), val
);
2054 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2058 Fsetcdr (XCDR (prev
), newcell
);
2062 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2063 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2064 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2065 (symbol
, propname
, value
)
2066 Lisp_Object symbol
, propname
, value
;
2068 CHECK_SYMBOL (symbol
);
2069 XSYMBOL (symbol
)->plist
2070 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2074 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2075 doc
: /* Extract a value from a property list, comparing with `equal'.
2076 PLIST is a property list, which is a list of the form
2077 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2078 corresponding to the given PROP, or nil if PROP is not
2079 one of the properties on the list. */)
2087 CONSP (tail
) && CONSP (XCDR (tail
));
2088 tail
= XCDR (XCDR (tail
)))
2090 if (! NILP (Fequal (prop
, XCAR (tail
))))
2091 return XCAR (XCDR (tail
));
2097 wrong_type_argument (Qlistp
, prop
);
2102 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2103 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2104 PLIST is a property list, which is a list of the form
2105 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2106 If PROP is already a property on the list, its value is set to VAL,
2107 otherwise the new PROP VAL pair is added. The new plist is returned;
2108 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2109 The PLIST is modified by side effects. */)
2112 register Lisp_Object prop
;
2115 register Lisp_Object tail
, prev
;
2116 Lisp_Object newcell
;
2118 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2119 tail
= XCDR (XCDR (tail
)))
2121 if (! NILP (Fequal (prop
, XCAR (tail
))))
2123 Fsetcar (XCDR (tail
), val
);
2130 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2134 Fsetcdr (XCDR (prev
), newcell
);
2138 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2139 doc
: /* Return t if two Lisp objects have similar structure and contents.
2140 They must have the same data type.
2141 Conses are compared by comparing the cars and the cdrs.
2142 Vectors and strings are compared element by element.
2143 Numbers are compared by value, but integers cannot equal floats.
2144 (Use `=' if you want integers and floats to be able to be equal.)
2145 Symbols must match exactly. */)
2147 register Lisp_Object o1
, o2
;
2149 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2152 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2153 doc
: /* Return t if two Lisp objects have similar structure and contents.
2154 This is like `equal' except that it compares the text properties
2155 of strings. (`equal' ignores text properties.) */)
2157 register Lisp_Object o1
, o2
;
2159 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2162 /* DEPTH is current depth of recursion. Signal an error if it
2164 PROPS, if non-nil, means compare string text properties too. */
2167 internal_equal (o1
, o2
, depth
, props
)
2168 register Lisp_Object o1
, o2
;
2172 error ("Stack overflow in equal");
2178 if (XTYPE (o1
) != XTYPE (o2
))
2187 d1
= extract_float (o1
);
2188 d2
= extract_float (o2
);
2189 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2190 though they are not =. */
2191 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2195 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2202 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2206 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2208 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2211 o1
= XOVERLAY (o1
)->plist
;
2212 o2
= XOVERLAY (o2
)->plist
;
2217 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2218 && (XMARKER (o1
)->buffer
== 0
2219 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2223 case Lisp_Vectorlike
:
2226 EMACS_INT size
= XVECTOR (o1
)->size
;
2227 /* Pseudovectors have the type encoded in the size field, so this test
2228 actually checks that the objects have the same type as well as the
2230 if (XVECTOR (o2
)->size
!= size
)
2232 /* Boolvectors are compared much like strings. */
2233 if (BOOL_VECTOR_P (o1
))
2236 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2238 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2240 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2245 if (WINDOW_CONFIGURATIONP (o1
))
2246 return compare_window_configurations (o1
, o2
, 0);
2248 /* Aside from them, only true vectors, char-tables, and compiled
2249 functions are sensible to compare, so eliminate the others now. */
2250 if (size
& PSEUDOVECTOR_FLAG
)
2252 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2254 size
&= PSEUDOVECTOR_SIZE_MASK
;
2256 for (i
= 0; i
< size
; i
++)
2259 v1
= XVECTOR (o1
)->contents
[i
];
2260 v2
= XVECTOR (o2
)->contents
[i
];
2261 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2269 if (SCHARS (o1
) != SCHARS (o2
))
2271 if (SBYTES (o1
) != SBYTES (o2
))
2273 if (bcmp (SDATA (o1
), SDATA (o2
),
2276 if (props
&& !compare_string_intervals (o1
, o2
))
2282 case Lisp_Type_Limit
:
2289 extern Lisp_Object
Fmake_char_internal ();
2291 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2292 doc
: /* Store each element of ARRAY with ITEM.
2293 ARRAY is a vector, string, char-table, or bool-vector. */)
2295 Lisp_Object array
, item
;
2297 register int size
, index
, charval
;
2299 if (VECTORP (array
))
2301 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2302 size
= XVECTOR (array
)->size
;
2303 for (index
= 0; index
< size
; index
++)
2306 else if (CHAR_TABLE_P (array
))
2308 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2309 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2310 for (index
= 0; index
< size
; index
++)
2312 XCHAR_TABLE (array
)->defalt
= Qnil
;
2314 else if (STRINGP (array
))
2316 register unsigned char *p
= SDATA (array
);
2317 CHECK_NUMBER (item
);
2318 charval
= XINT (item
);
2319 size
= SCHARS (array
);
2320 if (STRING_MULTIBYTE (array
))
2322 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2323 int len
= CHAR_STRING (charval
, str
);
2324 int size_byte
= SBYTES (array
);
2325 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2328 if (size
!= size_byte
)
2331 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2332 if (len
!= this_len
)
2333 error ("Attempt to change byte length of a string");
2336 for (i
= 0; i
< size_byte
; i
++)
2337 *p
++ = str
[i
% len
];
2340 for (index
= 0; index
< size
; index
++)
2343 else if (BOOL_VECTOR_P (array
))
2345 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2347 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2349 charval
= (! NILP (item
) ? -1 : 0);
2350 for (index
= 0; index
< size_in_chars
- 1; index
++)
2352 if (index
< size_in_chars
)
2354 /* Mask out bits beyond the vector size. */
2355 if (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)
2356 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)) - 1;
2362 array
= wrong_type_argument (Qarrayp
, array
);
2368 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2370 doc
: /* Clear the contents of STRING.
2371 This makes STRING unibyte and may change its length. */)
2375 int len
= SBYTES (string
);
2376 bzero (SDATA (string
), len
);
2377 STRING_SET_CHARS (string
, len
);
2378 STRING_SET_UNIBYTE (string
);
2382 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2384 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2386 Lisp_Object char_table
;
2388 CHECK_CHAR_TABLE (char_table
);
2390 return XCHAR_TABLE (char_table
)->purpose
;
2393 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2395 doc
: /* Return the parent char-table of CHAR-TABLE.
2396 The value is either nil or another char-table.
2397 If CHAR-TABLE holds nil for a given character,
2398 then the actual applicable value is inherited from the parent char-table
2399 \(or from its parents, if necessary). */)
2401 Lisp_Object char_table
;
2403 CHECK_CHAR_TABLE (char_table
);
2405 return XCHAR_TABLE (char_table
)->parent
;
2408 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2410 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2411 Return PARENT. PARENT must be either nil or another char-table. */)
2412 (char_table
, parent
)
2413 Lisp_Object char_table
, parent
;
2417 CHECK_CHAR_TABLE (char_table
);
2421 CHECK_CHAR_TABLE (parent
);
2423 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2424 if (EQ (temp
, char_table
))
2425 error ("Attempt to make a chartable be its own parent");
2428 XCHAR_TABLE (char_table
)->parent
= parent
;
2433 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2435 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2437 Lisp_Object char_table
, n
;
2439 CHECK_CHAR_TABLE (char_table
);
2442 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2443 args_out_of_range (char_table
, n
);
2445 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2448 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2449 Sset_char_table_extra_slot
,
2451 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2452 (char_table
, n
, value
)
2453 Lisp_Object char_table
, n
, value
;
2455 CHECK_CHAR_TABLE (char_table
);
2458 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2459 args_out_of_range (char_table
, n
);
2461 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2464 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2466 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2467 RANGE should be nil (for the default value)
2468 a vector which identifies a character set or a row of a character set,
2469 a character set name, or a character code. */)
2471 Lisp_Object char_table
, range
;
2473 CHECK_CHAR_TABLE (char_table
);
2475 if (EQ (range
, Qnil
))
2476 return XCHAR_TABLE (char_table
)->defalt
;
2477 else if (INTEGERP (range
))
2478 return Faref (char_table
, range
);
2479 else if (SYMBOLP (range
))
2481 Lisp_Object charset_info
;
2483 charset_info
= Fget (range
, Qcharset
);
2484 CHECK_VECTOR (charset_info
);
2486 return Faref (char_table
,
2487 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2490 else if (VECTORP (range
))
2492 if (XVECTOR (range
)->size
== 1)
2493 return Faref (char_table
,
2494 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2497 int size
= XVECTOR (range
)->size
;
2498 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2499 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2500 size
<= 1 ? Qnil
: val
[1],
2501 size
<= 2 ? Qnil
: val
[2]);
2502 return Faref (char_table
, ch
);
2506 error ("Invalid RANGE argument to `char-table-range'");
2510 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2512 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2513 RANGE should be t (for all characters), nil (for the default value),
2514 a character set, a vector which identifies a character set, a row of a
2515 character set, or a character code. Return VALUE. */)
2516 (char_table
, range
, value
)
2517 Lisp_Object char_table
, range
, value
;
2521 CHECK_CHAR_TABLE (char_table
);
2524 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2525 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2526 else if (EQ (range
, Qnil
))
2527 XCHAR_TABLE (char_table
)->defalt
= value
;
2528 else if (SYMBOLP (range
))
2530 Lisp_Object charset_info
;
2533 charset_info
= Fget (range
, Qcharset
);
2534 if (! VECTORP (charset_info
)
2535 || ! NATNUMP (AREF (charset_info
, 0))
2536 || (charset_id
= XINT (AREF (charset_info
, 0)),
2537 ! CHARSET_DEFINED_P (charset_id
)))
2538 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2540 if (charset_id
== CHARSET_ASCII
)
2541 for (i
= 0; i
< 128; i
++)
2542 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2543 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2544 for (i
= 128; i
< 160; i
++)
2545 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2546 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2547 for (i
= 160; i
< 256; i
++)
2548 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2550 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2552 else if (INTEGERP (range
))
2553 Faset (char_table
, range
, value
);
2554 else if (VECTORP (range
))
2556 if (XVECTOR (range
)->size
== 1)
2557 return Faset (char_table
,
2558 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2562 int size
= XVECTOR (range
)->size
;
2563 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2564 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2565 size
<= 1 ? Qnil
: val
[1],
2566 size
<= 2 ? Qnil
: val
[2]);
2567 return Faset (char_table
, ch
, value
);
2571 error ("Invalid RANGE argument to `set-char-table-range'");
2576 DEFUN ("set-char-table-default", Fset_char_table_default
,
2577 Sset_char_table_default
, 3, 3, 0,
2578 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2579 The generic character specifies the group of characters.
2580 See also the documentation of `make-char'. */)
2581 (char_table
, ch
, value
)
2582 Lisp_Object char_table
, ch
, value
;
2584 int c
, charset
, code1
, code2
;
2587 CHECK_CHAR_TABLE (char_table
);
2591 SPLIT_CHAR (c
, charset
, code1
, code2
);
2593 /* Since we may want to set the default value for a character set
2594 not yet defined, we check only if the character set is in the
2595 valid range or not, instead of it is already defined or not. */
2596 if (! CHARSET_VALID_P (charset
))
2597 invalid_character (c
);
2599 if (charset
== CHARSET_ASCII
)
2600 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2602 /* Even if C is not a generic char, we had better behave as if a
2603 generic char is specified. */
2604 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2606 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2609 if (SUB_CHAR_TABLE_P (temp
))
2610 XCHAR_TABLE (temp
)->defalt
= value
;
2612 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2615 if (SUB_CHAR_TABLE_P (temp
))
2618 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2619 = make_sub_char_table (temp
));
2620 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2621 if (SUB_CHAR_TABLE_P (temp
))
2622 XCHAR_TABLE (temp
)->defalt
= value
;
2624 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2628 /* Look up the element in TABLE at index CH,
2629 and return it as an integer.
2630 If the element is nil, return CH itself.
2631 (Actually we do that for any non-integer.) */
2634 char_table_translate (table
, ch
)
2639 value
= Faref (table
, make_number (ch
));
2640 if (! INTEGERP (value
))
2642 return XINT (value
);
2646 optimize_sub_char_table (table
, chars
)
2654 from
= 33, to
= 127;
2656 from
= 32, to
= 128;
2658 if (!SUB_CHAR_TABLE_P (*table
))
2660 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2661 for (; from
< to
; from
++)
2662 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2667 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2668 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2676 CHECK_CHAR_TABLE (table
);
2678 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2680 elt
= XCHAR_TABLE (table
)->contents
[i
];
2681 if (!SUB_CHAR_TABLE_P (elt
))
2683 dim
= CHARSET_DIMENSION (i
- 128);
2685 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2686 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2687 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2693 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2694 character or group of characters that share a value.
2695 DEPTH is the current depth in the originally specified
2696 chartable, and INDICES contains the vector indices
2697 for the levels our callers have descended.
2699 ARG is passed to C_FUNCTION when that is called. */
2702 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2703 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2704 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2711 /* At first, handle ASCII and 8-bit European characters. */
2712 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2714 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2716 elt
= XCHAR_TABLE (subtable
)->defalt
;
2718 elt
= Faref (subtable
, make_number (i
));
2720 (*c_function
) (arg
, make_number (i
), elt
);
2722 call2 (function
, make_number (i
), elt
);
2724 #if 0 /* If the char table has entries for higher characters,
2725 we should report them. */
2726 if (NILP (current_buffer
->enable_multibyte_characters
))
2729 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2733 int charset
= XFASTINT (indices
[0]) - 128;
2736 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2737 if (CHARSET_CHARS (charset
) == 94)
2746 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2747 XSETFASTINT (indices
[depth
], i
);
2748 charset
= XFASTINT (indices
[0]) - 128;
2750 && (!CHARSET_DEFINED_P (charset
)
2751 || charset
== CHARSET_8_BIT_CONTROL
2752 || charset
== CHARSET_8_BIT_GRAPHIC
))
2755 if (SUB_CHAR_TABLE_P (elt
))
2758 error ("Too deep char table");
2759 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2765 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2766 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2767 c
= MAKE_CHAR (charset
, c1
, c2
);
2770 elt
= XCHAR_TABLE (subtable
)->defalt
;
2772 elt
= Faref (table
, make_number (c
));
2775 (*c_function
) (arg
, make_number (c
), elt
);
2777 call2 (function
, make_number (c
), elt
);
2782 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2784 void_call2 (a
, b
, c
)
2785 Lisp_Object a
, b
, c
;
2790 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2792 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2793 FUNCTION is called with two arguments--a key and a value.
2794 The key is always a possible IDX argument to `aref'. */)
2795 (function
, char_table
)
2796 Lisp_Object function
, char_table
;
2798 /* The depth of char table is at most 3. */
2799 Lisp_Object indices
[3];
2801 CHECK_CHAR_TABLE (char_table
);
2803 /* When Lisp_Object is represented as a union, `call2' cannot directly
2804 be passed to map_char_table because it returns a Lisp_Object rather
2805 than returning nothing.
2806 Casting leads to crashes on some architectures. -stef */
2807 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2811 /* Return a value for character C in char-table TABLE. Store the
2812 actual index for that value in *IDX. Ignore the default value of
2816 char_table_ref_and_index (table
, c
, idx
)
2820 int charset
, c1
, c2
;
2823 if (SINGLE_BYTE_CHAR_P (c
))
2826 return XCHAR_TABLE (table
)->contents
[c
];
2828 SPLIT_CHAR (c
, charset
, c1
, c2
);
2829 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2830 *idx
= MAKE_CHAR (charset
, 0, 0);
2831 if (!SUB_CHAR_TABLE_P (elt
))
2833 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2834 return XCHAR_TABLE (elt
)->defalt
;
2835 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2836 *idx
= MAKE_CHAR (charset
, c1
, 0);
2837 if (!SUB_CHAR_TABLE_P (elt
))
2839 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2840 return XCHAR_TABLE (elt
)->defalt
;
2842 return XCHAR_TABLE (elt
)->contents
[c2
];
2852 Lisp_Object args
[2];
2855 return Fnconc (2, args
);
2857 return Fnconc (2, &s1
);
2858 #endif /* NO_ARG_ARRAY */
2861 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2862 doc
: /* Concatenate any number of lists by altering them.
2863 Only the last argument is not altered, and need not be a list.
2864 usage: (nconc &rest LISTS) */)
2869 register int argnum
;
2870 register Lisp_Object tail
, tem
, val
;
2874 for (argnum
= 0; argnum
< nargs
; argnum
++)
2877 if (NILP (tem
)) continue;
2882 if (argnum
+ 1 == nargs
) break;
2885 tem
= wrong_type_argument (Qlistp
, tem
);
2894 tem
= args
[argnum
+ 1];
2895 Fsetcdr (tail
, tem
);
2897 args
[argnum
+ 1] = tail
;
2903 /* This is the guts of all mapping functions.
2904 Apply FN to each element of SEQ, one by one,
2905 storing the results into elements of VALS, a C vector of Lisp_Objects.
2906 LENI is the length of VALS, which should also be the length of SEQ. */
2909 mapcar1 (leni
, vals
, fn
, seq
)
2912 Lisp_Object fn
, seq
;
2914 register Lisp_Object tail
;
2917 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2921 /* Don't let vals contain any garbage when GC happens. */
2922 for (i
= 0; i
< leni
; i
++)
2925 GCPRO3 (dummy
, fn
, seq
);
2927 gcpro1
.nvars
= leni
;
2931 /* We need not explicitly protect `tail' because it is used only on lists, and
2932 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2936 for (i
= 0; i
< leni
; i
++)
2938 dummy
= XVECTOR (seq
)->contents
[i
];
2939 dummy
= call1 (fn
, dummy
);
2944 else if (BOOL_VECTOR_P (seq
))
2946 for (i
= 0; i
< leni
; i
++)
2949 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2950 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2955 dummy
= call1 (fn
, dummy
);
2960 else if (STRINGP (seq
))
2964 for (i
= 0, i_byte
= 0; i
< leni
;)
2969 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2970 XSETFASTINT (dummy
, c
);
2971 dummy
= call1 (fn
, dummy
);
2973 vals
[i_before
] = dummy
;
2976 else /* Must be a list, since Flength did not get an error */
2979 for (i
= 0; i
< leni
; i
++)
2981 dummy
= call1 (fn
, Fcar (tail
));
2991 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2992 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2993 In between each pair of results, stick in SEPARATOR. Thus, " " as
2994 SEPARATOR results in spaces between the values returned by FUNCTION.
2995 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2996 (function
, sequence
, separator
)
2997 Lisp_Object function
, sequence
, separator
;
3002 register Lisp_Object
*args
;
3004 struct gcpro gcpro1
;
3006 len
= Flength (sequence
);
3008 nargs
= leni
+ leni
- 1;
3009 if (nargs
< 0) return build_string ("");
3011 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
3014 mapcar1 (leni
, args
, function
, sequence
);
3017 for (i
= leni
- 1; i
>= 0; i
--)
3018 args
[i
+ i
] = args
[i
];
3020 for (i
= 1; i
< nargs
; i
+= 2)
3021 args
[i
] = separator
;
3023 return Fconcat (nargs
, args
);
3026 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3027 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3028 The result is a list just as long as SEQUENCE.
3029 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3030 (function
, sequence
)
3031 Lisp_Object function
, sequence
;
3033 register Lisp_Object len
;
3035 register Lisp_Object
*args
;
3037 len
= Flength (sequence
);
3038 leni
= XFASTINT (len
);
3039 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
3041 mapcar1 (leni
, args
, function
, sequence
);
3043 return Flist (leni
, args
);
3046 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3047 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3048 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3049 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3050 (function
, sequence
)
3051 Lisp_Object function
, sequence
;
3055 leni
= XFASTINT (Flength (sequence
));
3056 mapcar1 (leni
, 0, function
, sequence
);
3061 /* Anything that calls this function must protect from GC! */
3063 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3064 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3065 Takes one argument, which is the string to display to ask the question.
3066 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3067 No confirmation of the answer is requested; a single character is enough.
3068 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3069 the bindings in `query-replace-map'; see the documentation of that variable
3070 for more information. In this case, the useful bindings are `act', `skip',
3071 `recenter', and `quit'.\)
3073 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3074 is nil and `use-dialog-box' is non-nil. */)
3078 register Lisp_Object obj
, key
, def
, map
;
3079 register int answer
;
3080 Lisp_Object xprompt
;
3081 Lisp_Object args
[2];
3082 struct gcpro gcpro1
, gcpro2
;
3083 int count
= SPECPDL_INDEX ();
3085 specbind (Qcursor_in_echo_area
, Qt
);
3087 map
= Fsymbol_value (intern ("query-replace-map"));
3089 CHECK_STRING (prompt
);
3091 GCPRO2 (prompt
, xprompt
);
3093 #ifdef HAVE_X_WINDOWS
3094 if (display_hourglass_p
)
3095 cancel_hourglass ();
3102 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3106 Lisp_Object pane
, menu
;
3107 redisplay_preserve_echo_area (3);
3108 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3109 Fcons (Fcons (build_string ("No"), Qnil
),
3111 menu
= Fcons (prompt
, pane
);
3112 obj
= Fx_popup_dialog (Qt
, menu
);
3113 answer
= !NILP (obj
);
3116 #endif /* HAVE_MENUS */
3117 cursor_in_echo_area
= 1;
3118 choose_minibuf_frame ();
3121 Lisp_Object pargs
[3];
3123 /* Colorize prompt according to `minibuffer-prompt' face. */
3124 pargs
[0] = build_string ("%s(y or n) ");
3125 pargs
[1] = intern ("face");
3126 pargs
[2] = intern ("minibuffer-prompt");
3127 args
[0] = Fpropertize (3, pargs
);
3132 if (minibuffer_auto_raise
)
3134 Lisp_Object mini_frame
;
3136 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3138 Fraise_frame (mini_frame
);
3141 obj
= read_filtered_event (1, 0, 0, 0);
3142 cursor_in_echo_area
= 0;
3143 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3146 key
= Fmake_vector (make_number (1), obj
);
3147 def
= Flookup_key (map
, key
, Qt
);
3149 if (EQ (def
, intern ("skip")))
3154 else if (EQ (def
, intern ("act")))
3159 else if (EQ (def
, intern ("recenter")))
3165 else if (EQ (def
, intern ("quit")))
3167 /* We want to exit this command for exit-prefix,
3168 and this is the only way to do it. */
3169 else if (EQ (def
, intern ("exit-prefix")))
3174 /* If we don't clear this, then the next call to read_char will
3175 return quit_char again, and we'll enter an infinite loop. */
3180 if (EQ (xprompt
, prompt
))
3182 args
[0] = build_string ("Please answer y or n. ");
3184 xprompt
= Fconcat (2, args
);
3189 if (! noninteractive
)
3191 cursor_in_echo_area
= -1;
3192 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3196 unbind_to (count
, Qnil
);
3197 return answer
? Qt
: Qnil
;
3200 /* This is how C code calls `yes-or-no-p' and allows the user
3203 Anything that calls this function must protect from GC! */
3206 do_yes_or_no_p (prompt
)
3209 return call1 (intern ("yes-or-no-p"), prompt
);
3212 /* Anything that calls this function must protect from GC! */
3214 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3215 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3216 Takes one argument, which is the string to display to ask the question.
3217 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3218 The user must confirm the answer with RET,
3219 and can edit it until it has been confirmed.
3221 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3222 is nil, and `use-dialog-box' is non-nil. */)
3226 register Lisp_Object ans
;
3227 Lisp_Object args
[2];
3228 struct gcpro gcpro1
;
3230 CHECK_STRING (prompt
);
3233 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3237 Lisp_Object pane
, menu
, obj
;
3238 redisplay_preserve_echo_area (4);
3239 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3240 Fcons (Fcons (build_string ("No"), Qnil
),
3243 menu
= Fcons (prompt
, pane
);
3244 obj
= Fx_popup_dialog (Qt
, menu
);
3248 #endif /* HAVE_MENUS */
3251 args
[1] = build_string ("(yes or no) ");
3252 prompt
= Fconcat (2, args
);
3258 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3259 Qyes_or_no_p_history
, Qnil
,
3261 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3266 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3274 message ("Please answer yes or no.");
3275 Fsleep_for (make_number (2), Qnil
);
3279 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3280 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3282 Each of the three load averages is multiplied by 100, then converted
3285 When USE-FLOATS is non-nil, floats will be used instead of integers.
3286 These floats are not multiplied by 100.
3288 If the 5-minute or 15-minute load averages are not available, return a
3289 shortened list, containing only those averages which are available.
3291 An error is thrown if the load average can't be obtained. In some
3292 cases making it work would require Emacs being installed setuid or
3293 setgid so that it can read kernel information, and that usually isn't
3296 Lisp_Object use_floats
;
3299 int loads
= getloadavg (load_ave
, 3);
3300 Lisp_Object ret
= Qnil
;
3303 error ("load-average not implemented for this operating system");
3307 Lisp_Object load
= (NILP (use_floats
) ?
3308 make_number ((int) (100.0 * load_ave
[loads
]))
3309 : make_float (load_ave
[loads
]));
3310 ret
= Fcons (load
, ret
);
3316 Lisp_Object Vfeatures
, Qsubfeatures
;
3317 extern Lisp_Object Vafter_load_alist
;
3319 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3320 doc
: /* Returns t if FEATURE is present in this Emacs.
3322 Use this to conditionalize execution of lisp code based on the
3323 presence or absence of emacs or environment extensions.
3324 Use `provide' to declare that a feature is available. This function
3325 looks at the value of the variable `features'. The optional argument
3326 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3327 (feature
, subfeature
)
3328 Lisp_Object feature
, subfeature
;
3330 register Lisp_Object tem
;
3331 CHECK_SYMBOL (feature
);
3332 tem
= Fmemq (feature
, Vfeatures
);
3333 if (!NILP (tem
) && !NILP (subfeature
))
3334 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3335 return (NILP (tem
)) ? Qnil
: Qt
;
3338 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3339 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3340 The optional argument SUBFEATURES should be a list of symbols listing
3341 particular subfeatures supported in this version of FEATURE. */)
3342 (feature
, subfeatures
)
3343 Lisp_Object feature
, subfeatures
;
3345 register Lisp_Object tem
;
3346 CHECK_SYMBOL (feature
);
3347 CHECK_LIST (subfeatures
);
3348 if (!NILP (Vautoload_queue
))
3349 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3350 tem
= Fmemq (feature
, Vfeatures
);
3352 Vfeatures
= Fcons (feature
, Vfeatures
);
3353 if (!NILP (subfeatures
))
3354 Fput (feature
, Qsubfeatures
, subfeatures
);
3355 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3357 /* Run any load-hooks for this file. */
3358 tem
= Fassq (feature
, Vafter_load_alist
);
3360 Fprogn (XCDR (tem
));
3365 /* `require' and its subroutines. */
3367 /* List of features currently being require'd, innermost first. */
3369 Lisp_Object require_nesting_list
;
3372 require_unwind (old_value
)
3373 Lisp_Object old_value
;
3375 return require_nesting_list
= old_value
;
3378 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3379 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3380 If FEATURE is not a member of the list `features', then the feature
3381 is not loaded; so load the file FILENAME.
3382 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3383 and `load' will try to load this name appended with the suffix `.elc' or
3384 `.el', in that order. The name without appended suffix will not be used.
3385 If the optional third argument NOERROR is non-nil,
3386 then return nil if the file is not found instead of signaling an error.
3387 Normally the return value is FEATURE.
3388 The normal messages at start and end of loading FILENAME are suppressed. */)
3389 (feature
, filename
, noerror
)
3390 Lisp_Object feature
, filename
, noerror
;
3392 register Lisp_Object tem
;
3393 struct gcpro gcpro1
, gcpro2
;
3395 CHECK_SYMBOL (feature
);
3397 tem
= Fmemq (feature
, Vfeatures
);
3401 int count
= SPECPDL_INDEX ();
3404 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3406 /* This is to make sure that loadup.el gives a clear picture
3407 of what files are preloaded and when. */
3408 if (! NILP (Vpurify_flag
))
3409 error ("(require %s) while preparing to dump",
3410 SDATA (SYMBOL_NAME (feature
)));
3412 /* A certain amount of recursive `require' is legitimate,
3413 but if we require the same feature recursively 3 times,
3415 tem
= require_nesting_list
;
3416 while (! NILP (tem
))
3418 if (! NILP (Fequal (feature
, XCAR (tem
))))
3423 error ("Recursive `require' for feature `%s'",
3424 SDATA (SYMBOL_NAME (feature
)));
3426 /* Update the list for any nested `require's that occur. */
3427 record_unwind_protect (require_unwind
, require_nesting_list
);
3428 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3430 /* Value saved here is to be restored into Vautoload_queue */
3431 record_unwind_protect (un_autoload
, Vautoload_queue
);
3432 Vautoload_queue
= Qt
;
3434 /* Load the file. */
3435 GCPRO2 (feature
, filename
);
3436 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3437 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3440 /* If load failed entirely, return nil. */
3442 return unbind_to (count
, Qnil
);
3444 tem
= Fmemq (feature
, Vfeatures
);
3446 error ("Required feature `%s' was not provided",
3447 SDATA (SYMBOL_NAME (feature
)));
3449 /* Once loading finishes, don't undo it. */
3450 Vautoload_queue
= Qt
;
3451 feature
= unbind_to (count
, feature
);
3457 /* Primitives for work of the "widget" library.
3458 In an ideal world, this section would not have been necessary.
3459 However, lisp function calls being as slow as they are, it turns
3460 out that some functions in the widget library (wid-edit.el) are the
3461 bottleneck of Widget operation. Here is their translation to C,
3462 for the sole reason of efficiency. */
3464 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3465 doc
: /* Return non-nil if PLIST has the property PROP.
3466 PLIST is a property list, which is a list of the form
3467 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3468 Unlike `plist-get', this allows you to distinguish between a missing
3469 property and a property with the value nil.
3470 The value is actually the tail of PLIST whose car is PROP. */)
3472 Lisp_Object plist
, prop
;
3474 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3477 plist
= XCDR (plist
);
3478 plist
= CDR (plist
);
3483 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3484 doc
: /* In WIDGET, set PROPERTY to VALUE.
3485 The value can later be retrieved with `widget-get'. */)
3486 (widget
, property
, value
)
3487 Lisp_Object widget
, property
, value
;
3489 CHECK_CONS (widget
);
3490 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3494 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3495 doc
: /* In WIDGET, get the value of PROPERTY.
3496 The value could either be specified when the widget was created, or
3497 later with `widget-put'. */)
3499 Lisp_Object widget
, property
;
3507 CHECK_CONS (widget
);
3508 tmp
= Fplist_member (XCDR (widget
), property
);
3514 tmp
= XCAR (widget
);
3517 widget
= Fget (tmp
, Qwidget_type
);
3521 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3522 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3523 ARGS are passed as extra arguments to the function.
3524 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3529 /* This function can GC. */
3530 Lisp_Object newargs
[3];
3531 struct gcpro gcpro1
, gcpro2
;
3534 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3535 newargs
[1] = args
[0];
3536 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3537 GCPRO2 (newargs
[0], newargs
[2]);
3538 result
= Fapply (3, newargs
);
3543 #ifdef HAVE_LANGINFO_CODESET
3544 #include <langinfo.h>
3547 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3548 doc
: /* Access locale data ITEM for the current C locale, if available.
3549 ITEM should be one of the following:
3551 `codeset', returning the character set as a string (locale item CODESET);
3553 `days', returning a 7-element vector of day names (locale items DAY_n);
3555 `months', returning a 12-element vector of month names (locale items MON_n);
3557 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3558 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3560 If the system can't provide such information through a call to
3561 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3563 See also Info node `(libc)Locales'.
3565 The data read from the system are decoded using `locale-coding-system'. */)
3570 #ifdef HAVE_LANGINFO_CODESET
3572 if (EQ (item
, Qcodeset
))
3574 str
= nl_langinfo (CODESET
);
3575 return build_string (str
);
3578 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3580 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3581 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3583 synchronize_system_time_locale ();
3584 for (i
= 0; i
< 7; i
++)
3586 str
= nl_langinfo (days
[i
]);
3587 val
= make_unibyte_string (str
, strlen (str
));
3588 /* Fixme: Is this coding system necessarily right, even if
3589 it is consistent with CODESET? If not, what to do? */
3590 Faset (v
, make_number (i
),
3591 code_convert_string_norecord (val
, Vlocale_coding_system
,
3598 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3600 struct Lisp_Vector
*p
= allocate_vector (12);
3601 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3602 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3604 synchronize_system_time_locale ();
3605 for (i
= 0; i
< 12; i
++)
3607 str
= nl_langinfo (months
[i
]);
3608 val
= make_unibyte_string (str
, strlen (str
));
3610 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3612 XSETVECTOR (val
, p
);
3616 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3617 but is in the locale files. This could be used by ps-print. */
3619 else if (EQ (item
, Qpaper
))
3621 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3622 make_number (nl_langinfo (PAPER_HEIGHT
)));
3624 #endif /* PAPER_WIDTH */
3625 #endif /* HAVE_LANGINFO_CODESET*/
3629 /* base64 encode/decode functions (RFC 2045).
3630 Based on code from GNU recode. */
3632 #define MIME_LINE_LENGTH 76
3634 #define IS_ASCII(Character) \
3636 #define IS_BASE64(Character) \
3637 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3638 #define IS_BASE64_IGNORABLE(Character) \
3639 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3640 || (Character) == '\f' || (Character) == '\r')
3642 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3643 character or return retval if there are no characters left to
3645 #define READ_QUADRUPLET_BYTE(retval) \
3650 if (nchars_return) \
3651 *nchars_return = nchars; \
3656 while (IS_BASE64_IGNORABLE (c))
3658 /* Don't use alloca for regions larger than this, lest we overflow
3660 #define MAX_ALLOCA 16*1024
3662 /* Table of characters coding the 64 values. */
3663 static char base64_value_to_char
[64] =
3665 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3666 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3667 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3668 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3669 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3670 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3671 '8', '9', '+', '/' /* 60-63 */
3674 /* Table of base64 values for first 128 characters. */
3675 static short base64_char_to_value
[128] =
3677 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3678 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3679 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3680 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3681 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3682 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3683 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3684 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3685 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3686 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3687 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3688 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3689 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3692 /* The following diagram shows the logical steps by which three octets
3693 get transformed into four base64 characters.
3695 .--------. .--------. .--------.
3696 |aaaaaabb| |bbbbcccc| |ccdddddd|
3697 `--------' `--------' `--------'
3699 .--------+--------+--------+--------.
3700 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3701 `--------+--------+--------+--------'
3703 .--------+--------+--------+--------.
3704 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3705 `--------+--------+--------+--------'
3707 The octets are divided into 6 bit chunks, which are then encoded into
3708 base64 characters. */
3711 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3712 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3714 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3716 doc
: /* Base64-encode the region between BEG and END.
3717 Return the length of the encoded text.
3718 Optional third argument NO-LINE-BREAK means do not break long lines
3719 into shorter lines. */)
3720 (beg
, end
, no_line_break
)
3721 Lisp_Object beg
, end
, no_line_break
;
3724 int allength
, length
;
3725 int ibeg
, iend
, encoded_length
;
3728 validate_region (&beg
, &end
);
3730 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3731 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3732 move_gap_both (XFASTINT (beg
), ibeg
);
3734 /* We need to allocate enough room for encoding the text.
3735 We need 33 1/3% more space, plus a newline every 76
3736 characters, and then we round up. */
3737 length
= iend
- ibeg
;
3738 allength
= length
+ length
/3 + 1;
3739 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3741 if (allength
<= MAX_ALLOCA
)
3742 encoded
= (char *) alloca (allength
);
3744 encoded
= (char *) xmalloc (allength
);
3745 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3746 NILP (no_line_break
),
3747 !NILP (current_buffer
->enable_multibyte_characters
));
3748 if (encoded_length
> allength
)
3751 if (encoded_length
< 0)
3753 /* The encoding wasn't possible. */
3754 if (length
> MAX_ALLOCA
)
3756 error ("Multibyte character in data for base64 encoding");
3759 /* Now we have encoded the region, so we insert the new contents
3760 and delete the old. (Insert first in order to preserve markers.) */
3761 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3762 insert (encoded
, encoded_length
);
3763 if (allength
> MAX_ALLOCA
)
3765 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3767 /* If point was outside of the region, restore it exactly; else just
3768 move to the beginning of the region. */
3769 if (old_pos
>= XFASTINT (end
))
3770 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3771 else if (old_pos
> XFASTINT (beg
))
3772 old_pos
= XFASTINT (beg
);
3775 /* We return the length of the encoded text. */
3776 return make_number (encoded_length
);
3779 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3781 doc
: /* Base64-encode STRING and return the result.
3782 Optional second argument NO-LINE-BREAK means do not break long lines
3783 into shorter lines. */)
3784 (string
, no_line_break
)
3785 Lisp_Object string
, no_line_break
;
3787 int allength
, length
, encoded_length
;
3789 Lisp_Object encoded_string
;
3791 CHECK_STRING (string
);
3793 /* We need to allocate enough room for encoding the text.
3794 We need 33 1/3% more space, plus a newline every 76
3795 characters, and then we round up. */
3796 length
= SBYTES (string
);
3797 allength
= length
+ length
/3 + 1;
3798 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3800 /* We need to allocate enough room for decoding the text. */
3801 if (allength
<= MAX_ALLOCA
)
3802 encoded
= (char *) alloca (allength
);
3804 encoded
= (char *) xmalloc (allength
);
3806 encoded_length
= base64_encode_1 (SDATA (string
),
3807 encoded
, length
, NILP (no_line_break
),
3808 STRING_MULTIBYTE (string
));
3809 if (encoded_length
> allength
)
3812 if (encoded_length
< 0)
3814 /* The encoding wasn't possible. */
3815 if (length
> MAX_ALLOCA
)
3817 error ("Multibyte character in data for base64 encoding");
3820 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3821 if (allength
> MAX_ALLOCA
)
3824 return encoded_string
;
3828 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3835 int counter
= 0, i
= 0;
3845 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3853 /* Wrap line every 76 characters. */
3857 if (counter
< MIME_LINE_LENGTH
/ 4)
3866 /* Process first byte of a triplet. */
3868 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3869 value
= (0x03 & c
) << 4;
3871 /* Process second byte of a triplet. */
3875 *e
++ = base64_value_to_char
[value
];
3883 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3891 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3892 value
= (0x0f & c
) << 2;
3894 /* Process third byte of a triplet. */
3898 *e
++ = base64_value_to_char
[value
];
3905 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3913 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3914 *e
++ = base64_value_to_char
[0x3f & c
];
3921 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3923 doc
: /* Base64-decode the region between BEG and END.
3924 Return the length of the decoded text.
3925 If the region can't be decoded, signal an error and don't modify the buffer. */)
3927 Lisp_Object beg
, end
;
3929 int ibeg
, iend
, length
, allength
;
3934 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3936 validate_region (&beg
, &end
);
3938 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3939 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3941 length
= iend
- ibeg
;
3943 /* We need to allocate enough room for decoding the text. If we are
3944 working on a multibyte buffer, each decoded code may occupy at
3946 allength
= multibyte
? length
* 2 : length
;
3947 if (allength
<= MAX_ALLOCA
)
3948 decoded
= (char *) alloca (allength
);
3950 decoded
= (char *) xmalloc (allength
);
3952 move_gap_both (XFASTINT (beg
), ibeg
);
3953 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3954 multibyte
, &inserted_chars
);
3955 if (decoded_length
> allength
)
3958 if (decoded_length
< 0)
3960 /* The decoding wasn't possible. */
3961 if (allength
> MAX_ALLOCA
)
3963 error ("Invalid base64 data");
3966 /* Now we have decoded the region, so we insert the new contents
3967 and delete the old. (Insert first in order to preserve markers.) */
3968 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3969 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3970 if (allength
> MAX_ALLOCA
)
3972 /* Delete the original text. */
3973 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3974 iend
+ decoded_length
, 1);
3976 /* If point was outside of the region, restore it exactly; else just
3977 move to the beginning of the region. */
3978 if (old_pos
>= XFASTINT (end
))
3979 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3980 else if (old_pos
> XFASTINT (beg
))
3981 old_pos
= XFASTINT (beg
);
3982 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3984 return make_number (inserted_chars
);
3987 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3989 doc
: /* Base64-decode STRING and return the result. */)
3994 int length
, decoded_length
;
3995 Lisp_Object decoded_string
;
3997 CHECK_STRING (string
);
3999 length
= SBYTES (string
);
4000 /* We need to allocate enough room for decoding the text. */
4001 if (length
<= MAX_ALLOCA
)
4002 decoded
= (char *) alloca (length
);
4004 decoded
= (char *) xmalloc (length
);
4006 /* The decoded result should be unibyte. */
4007 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4009 if (decoded_length
> length
)
4011 else if (decoded_length
>= 0)
4012 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4014 decoded_string
= Qnil
;
4016 if (length
> MAX_ALLOCA
)
4018 if (!STRINGP (decoded_string
))
4019 error ("Invalid base64 data");
4021 return decoded_string
;
4024 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4025 MULTIBYTE is nonzero, the decoded result should be in multibyte
4026 form. If NCHARS_RETRUN is not NULL, store the number of produced
4027 characters in *NCHARS_RETURN. */
4030 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4040 unsigned long value
;
4045 /* Process first byte of a quadruplet. */
4047 READ_QUADRUPLET_BYTE (e
-to
);
4051 value
= base64_char_to_value
[c
] << 18;
4053 /* Process second byte of a quadruplet. */
4055 READ_QUADRUPLET_BYTE (-1);
4059 value
|= base64_char_to_value
[c
] << 12;
4061 c
= (unsigned char) (value
>> 16);
4063 e
+= CHAR_STRING (c
, e
);
4068 /* Process third byte of a quadruplet. */
4070 READ_QUADRUPLET_BYTE (-1);
4074 READ_QUADRUPLET_BYTE (-1);
4083 value
|= base64_char_to_value
[c
] << 6;
4085 c
= (unsigned char) (0xff & value
>> 8);
4087 e
+= CHAR_STRING (c
, e
);
4092 /* Process fourth byte of a quadruplet. */
4094 READ_QUADRUPLET_BYTE (-1);
4101 value
|= base64_char_to_value
[c
];
4103 c
= (unsigned char) (0xff & value
);
4105 e
+= CHAR_STRING (c
, e
);
4114 /***********************************************************************
4116 ***** Hash Tables *****
4118 ***********************************************************************/
4120 /* Implemented by gerd@gnu.org. This hash table implementation was
4121 inspired by CMUCL hash tables. */
4125 1. For small tables, association lists are probably faster than
4126 hash tables because they have lower overhead.
4128 For uses of hash tables where the O(1) behavior of table
4129 operations is not a requirement, it might therefore be a good idea
4130 not to hash. Instead, we could just do a linear search in the
4131 key_and_value vector of the hash table. This could be done
4132 if a `:linear-search t' argument is given to make-hash-table. */
4135 /* The list of all weak hash tables. Don't staticpro this one. */
4137 Lisp_Object Vweak_hash_tables
;
4139 /* Various symbols. */
4141 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4142 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4143 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4145 /* Function prototypes. */
4147 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4148 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4149 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4150 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4151 Lisp_Object
, unsigned));
4152 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4153 Lisp_Object
, unsigned));
4154 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4155 unsigned, Lisp_Object
, unsigned));
4156 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4157 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4158 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4159 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4161 static unsigned sxhash_string
P_ ((unsigned char *, int));
4162 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4163 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4164 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4165 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4169 /***********************************************************************
4171 ***********************************************************************/
4173 /* If OBJ is a Lisp hash table, return a pointer to its struct
4174 Lisp_Hash_Table. Otherwise, signal an error. */
4176 static struct Lisp_Hash_Table
*
4177 check_hash_table (obj
)
4180 CHECK_HASH_TABLE (obj
);
4181 return XHASH_TABLE (obj
);
4185 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4189 next_almost_prime (n
)
4202 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4203 which USED[I] is non-zero. If found at index I in ARGS, set
4204 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4205 -1. This function is used to extract a keyword/argument pair from
4206 a DEFUN parameter list. */
4209 get_key_arg (key
, nargs
, args
, used
)
4217 for (i
= 0; i
< nargs
- 1; ++i
)
4218 if (!used
[i
] && EQ (args
[i
], key
))
4233 /* Return a Lisp vector which has the same contents as VEC but has
4234 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4235 vector that are not copied from VEC are set to INIT. */
4238 larger_vector (vec
, new_size
, init
)
4243 struct Lisp_Vector
*v
;
4246 xassert (VECTORP (vec
));
4247 old_size
= XVECTOR (vec
)->size
;
4248 xassert (new_size
>= old_size
);
4250 v
= allocate_vector (new_size
);
4251 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4252 old_size
* sizeof *v
->contents
);
4253 for (i
= old_size
; i
< new_size
; ++i
)
4254 v
->contents
[i
] = init
;
4255 XSETVECTOR (vec
, v
);
4260 /***********************************************************************
4262 ***********************************************************************/
4264 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4265 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4266 KEY2 are the same. */
4269 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4270 struct Lisp_Hash_Table
*h
;
4271 Lisp_Object key1
, key2
;
4272 unsigned hash1
, hash2
;
4274 return (FLOATP (key1
)
4276 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4280 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4281 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4282 KEY2 are the same. */
4285 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4286 struct Lisp_Hash_Table
*h
;
4287 Lisp_Object key1
, key2
;
4288 unsigned hash1
, hash2
;
4290 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4294 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4295 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4296 if KEY1 and KEY2 are the same. */
4299 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4300 struct Lisp_Hash_Table
*h
;
4301 Lisp_Object key1
, key2
;
4302 unsigned hash1
, hash2
;
4306 Lisp_Object args
[3];
4308 args
[0] = h
->user_cmp_function
;
4311 return !NILP (Ffuncall (3, args
));
4318 /* Value is a hash code for KEY for use in hash table H which uses
4319 `eq' to compare keys. The hash code returned is guaranteed to fit
4320 in a Lisp integer. */
4324 struct Lisp_Hash_Table
*h
;
4327 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4328 xassert ((hash
& ~INTMASK
) == 0);
4333 /* Value is a hash code for KEY for use in hash table H which uses
4334 `eql' to compare keys. The hash code returned is guaranteed to fit
4335 in a Lisp integer. */
4339 struct Lisp_Hash_Table
*h
;
4344 hash
= sxhash (key
, 0);
4346 hash
= XUINT (key
) ^ XGCTYPE (key
);
4347 xassert ((hash
& ~INTMASK
) == 0);
4352 /* Value is a hash code for KEY for use in hash table H which uses
4353 `equal' to compare keys. The hash code returned is guaranteed to fit
4354 in a Lisp integer. */
4357 hashfn_equal (h
, key
)
4358 struct Lisp_Hash_Table
*h
;
4361 unsigned hash
= sxhash (key
, 0);
4362 xassert ((hash
& ~INTMASK
) == 0);
4367 /* Value is a hash code for KEY for use in hash table H which uses as
4368 user-defined function to compare keys. The hash code returned is
4369 guaranteed to fit in a Lisp integer. */
4372 hashfn_user_defined (h
, key
)
4373 struct Lisp_Hash_Table
*h
;
4376 Lisp_Object args
[2], hash
;
4378 args
[0] = h
->user_hash_function
;
4380 hash
= Ffuncall (2, args
);
4381 if (!INTEGERP (hash
))
4383 list2 (build_string ("Invalid hash code returned from \
4384 user-supplied hash function"),
4386 return XUINT (hash
);
4390 /* Create and initialize a new hash table.
4392 TEST specifies the test the hash table will use to compare keys.
4393 It must be either one of the predefined tests `eq', `eql' or
4394 `equal' or a symbol denoting a user-defined test named TEST with
4395 test and hash functions USER_TEST and USER_HASH.
4397 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4399 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4400 new size when it becomes full is computed by adding REHASH_SIZE to
4401 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4402 table's new size is computed by multiplying its old size with
4405 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4406 be resized when the ratio of (number of entries in the table) /
4407 (table size) is >= REHASH_THRESHOLD.
4409 WEAK specifies the weakness of the table. If non-nil, it must be
4410 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4413 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4414 user_test
, user_hash
)
4415 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4416 Lisp_Object user_test
, user_hash
;
4418 struct Lisp_Hash_Table
*h
;
4420 int index_size
, i
, sz
;
4422 /* Preconditions. */
4423 xassert (SYMBOLP (test
));
4424 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4425 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4426 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4427 xassert (FLOATP (rehash_threshold
)
4428 && XFLOATINT (rehash_threshold
) > 0
4429 && XFLOATINT (rehash_threshold
) <= 1.0);
4431 if (XFASTINT (size
) == 0)
4432 size
= make_number (1);
4434 /* Allocate a table and initialize it. */
4435 h
= allocate_hash_table ();
4437 /* Initialize hash table slots. */
4438 sz
= XFASTINT (size
);
4441 if (EQ (test
, Qeql
))
4443 h
->cmpfn
= cmpfn_eql
;
4444 h
->hashfn
= hashfn_eql
;
4446 else if (EQ (test
, Qeq
))
4449 h
->hashfn
= hashfn_eq
;
4451 else if (EQ (test
, Qequal
))
4453 h
->cmpfn
= cmpfn_equal
;
4454 h
->hashfn
= hashfn_equal
;
4458 h
->user_cmp_function
= user_test
;
4459 h
->user_hash_function
= user_hash
;
4460 h
->cmpfn
= cmpfn_user_defined
;
4461 h
->hashfn
= hashfn_user_defined
;
4465 h
->rehash_threshold
= rehash_threshold
;
4466 h
->rehash_size
= rehash_size
;
4467 h
->count
= make_number (0);
4468 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4469 h
->hash
= Fmake_vector (size
, Qnil
);
4470 h
->next
= Fmake_vector (size
, Qnil
);
4471 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4472 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4473 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4475 /* Set up the free list. */
4476 for (i
= 0; i
< sz
- 1; ++i
)
4477 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4478 h
->next_free
= make_number (0);
4480 XSET_HASH_TABLE (table
, h
);
4481 xassert (HASH_TABLE_P (table
));
4482 xassert (XHASH_TABLE (table
) == h
);
4484 /* Maybe add this hash table to the list of all weak hash tables. */
4486 h
->next_weak
= Qnil
;
4489 h
->next_weak
= Vweak_hash_tables
;
4490 Vweak_hash_tables
= table
;
4497 /* Return a copy of hash table H1. Keys and values are not copied,
4498 only the table itself is. */
4501 copy_hash_table (h1
)
4502 struct Lisp_Hash_Table
*h1
;
4505 struct Lisp_Hash_Table
*h2
;
4506 struct Lisp_Vector
*next
;
4508 h2
= allocate_hash_table ();
4509 next
= h2
->vec_next
;
4510 bcopy (h1
, h2
, sizeof *h2
);
4511 h2
->vec_next
= next
;
4512 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4513 h2
->hash
= Fcopy_sequence (h1
->hash
);
4514 h2
->next
= Fcopy_sequence (h1
->next
);
4515 h2
->index
= Fcopy_sequence (h1
->index
);
4516 XSET_HASH_TABLE (table
, h2
);
4518 /* Maybe add this hash table to the list of all weak hash tables. */
4519 if (!NILP (h2
->weak
))
4521 h2
->next_weak
= Vweak_hash_tables
;
4522 Vweak_hash_tables
= table
;
4529 /* Resize hash table H if it's too full. If H cannot be resized
4530 because it's already too large, throw an error. */
4533 maybe_resize_hash_table (h
)
4534 struct Lisp_Hash_Table
*h
;
4536 if (NILP (h
->next_free
))
4538 int old_size
= HASH_TABLE_SIZE (h
);
4539 int i
, new_size
, index_size
;
4541 if (INTEGERP (h
->rehash_size
))
4542 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4544 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4545 new_size
= max (old_size
+ 1, new_size
);
4546 index_size
= next_almost_prime ((int)
4548 / XFLOATINT (h
->rehash_threshold
)));
4549 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4550 error ("Hash table too large to resize");
4552 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4553 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4554 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4555 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4557 /* Update the free list. Do it so that new entries are added at
4558 the end of the free list. This makes some operations like
4560 for (i
= old_size
; i
< new_size
- 1; ++i
)
4561 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4563 if (!NILP (h
->next_free
))
4565 Lisp_Object last
, next
;
4567 last
= h
->next_free
;
4568 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4572 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4575 XSETFASTINT (h
->next_free
, old_size
);
4578 for (i
= 0; i
< old_size
; ++i
)
4579 if (!NILP (HASH_HASH (h
, i
)))
4581 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4582 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4583 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4584 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4590 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4591 the hash code of KEY. Value is the index of the entry in H
4592 matching KEY, or -1 if not found. */
4595 hash_lookup (h
, key
, hash
)
4596 struct Lisp_Hash_Table
*h
;
4601 int start_of_bucket
;
4604 hash_code
= h
->hashfn (h
, key
);
4608 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4609 idx
= HASH_INDEX (h
, start_of_bucket
);
4611 /* We need not gcpro idx since it's either an integer or nil. */
4614 int i
= XFASTINT (idx
);
4615 if (EQ (key
, HASH_KEY (h
, i
))
4617 && h
->cmpfn (h
, key
, hash_code
,
4618 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4620 idx
= HASH_NEXT (h
, i
);
4623 return NILP (idx
) ? -1 : XFASTINT (idx
);
4627 /* Put an entry into hash table H that associates KEY with VALUE.
4628 HASH is a previously computed hash code of KEY.
4629 Value is the index of the entry in H matching KEY. */
4632 hash_put (h
, key
, value
, hash
)
4633 struct Lisp_Hash_Table
*h
;
4634 Lisp_Object key
, value
;
4637 int start_of_bucket
, i
;
4639 xassert ((hash
& ~INTMASK
) == 0);
4641 /* Increment count after resizing because resizing may fail. */
4642 maybe_resize_hash_table (h
);
4643 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4645 /* Store key/value in the key_and_value vector. */
4646 i
= XFASTINT (h
->next_free
);
4647 h
->next_free
= HASH_NEXT (h
, i
);
4648 HASH_KEY (h
, i
) = key
;
4649 HASH_VALUE (h
, i
) = value
;
4651 /* Remember its hash code. */
4652 HASH_HASH (h
, i
) = make_number (hash
);
4654 /* Add new entry to its collision chain. */
4655 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4656 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4657 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4662 /* Remove the entry matching KEY from hash table H, if there is one. */
4665 hash_remove (h
, key
)
4666 struct Lisp_Hash_Table
*h
;
4670 int start_of_bucket
;
4671 Lisp_Object idx
, prev
;
4673 hash_code
= h
->hashfn (h
, key
);
4674 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4675 idx
= HASH_INDEX (h
, start_of_bucket
);
4678 /* We need not gcpro idx, prev since they're either integers or nil. */
4681 int i
= XFASTINT (idx
);
4683 if (EQ (key
, HASH_KEY (h
, i
))
4685 && h
->cmpfn (h
, key
, hash_code
,
4686 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4688 /* Take entry out of collision chain. */
4690 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4692 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4694 /* Clear slots in key_and_value and add the slots to
4696 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4697 HASH_NEXT (h
, i
) = h
->next_free
;
4698 h
->next_free
= make_number (i
);
4699 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4700 xassert (XINT (h
->count
) >= 0);
4706 idx
= HASH_NEXT (h
, i
);
4712 /* Clear hash table H. */
4716 struct Lisp_Hash_Table
*h
;
4718 if (XFASTINT (h
->count
) > 0)
4720 int i
, size
= HASH_TABLE_SIZE (h
);
4722 for (i
= 0; i
< size
; ++i
)
4724 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4725 HASH_KEY (h
, i
) = Qnil
;
4726 HASH_VALUE (h
, i
) = Qnil
;
4727 HASH_HASH (h
, i
) = Qnil
;
4730 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4731 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4733 h
->next_free
= make_number (0);
4734 h
->count
= make_number (0);
4740 /************************************************************************
4742 ************************************************************************/
4744 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4745 entries from the table that don't survive the current GC.
4746 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4747 non-zero if anything was marked. */
4750 sweep_weak_table (h
, remove_entries_p
)
4751 struct Lisp_Hash_Table
*h
;
4752 int remove_entries_p
;
4754 int bucket
, n
, marked
;
4756 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4759 for (bucket
= 0; bucket
< n
; ++bucket
)
4761 Lisp_Object idx
, next
, prev
;
4763 /* Follow collision chain, removing entries that
4764 don't survive this garbage collection. */
4766 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4768 int i
= XFASTINT (idx
);
4769 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4770 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4773 if (EQ (h
->weak
, Qkey
))
4774 remove_p
= !key_known_to_survive_p
;
4775 else if (EQ (h
->weak
, Qvalue
))
4776 remove_p
= !value_known_to_survive_p
;
4777 else if (EQ (h
->weak
, Qkey_or_value
))
4778 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4779 else if (EQ (h
->weak
, Qkey_and_value
))
4780 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4784 next
= HASH_NEXT (h
, i
);
4786 if (remove_entries_p
)
4790 /* Take out of collision chain. */
4792 HASH_INDEX (h
, bucket
) = next
;
4794 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4796 /* Add to free list. */
4797 HASH_NEXT (h
, i
) = h
->next_free
;
4800 /* Clear key, value, and hash. */
4801 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4802 HASH_HASH (h
, i
) = Qnil
;
4804 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4811 /* Make sure key and value survive. */
4812 if (!key_known_to_survive_p
)
4814 mark_object (HASH_KEY (h
, i
));
4818 if (!value_known_to_survive_p
)
4820 mark_object (HASH_VALUE (h
, i
));
4831 /* Remove elements from weak hash tables that don't survive the
4832 current garbage collection. Remove weak tables that don't survive
4833 from Vweak_hash_tables. Called from gc_sweep. */
4836 sweep_weak_hash_tables ()
4838 Lisp_Object table
, used
, next
;
4839 struct Lisp_Hash_Table
*h
;
4842 /* Mark all keys and values that are in use. Keep on marking until
4843 there is no more change. This is necessary for cases like
4844 value-weak table A containing an entry X -> Y, where Y is used in a
4845 key-weak table B, Z -> Y. If B comes after A in the list of weak
4846 tables, X -> Y might be removed from A, although when looking at B
4847 one finds that it shouldn't. */
4851 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4853 h
= XHASH_TABLE (table
);
4854 if (h
->size
& ARRAY_MARK_FLAG
)
4855 marked
|= sweep_weak_table (h
, 0);
4860 /* Remove tables and entries that aren't used. */
4861 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4863 h
= XHASH_TABLE (table
);
4864 next
= h
->next_weak
;
4866 if (h
->size
& ARRAY_MARK_FLAG
)
4868 /* TABLE is marked as used. Sweep its contents. */
4869 if (XFASTINT (h
->count
) > 0)
4870 sweep_weak_table (h
, 1);
4872 /* Add table to the list of used weak hash tables. */
4873 h
->next_weak
= used
;
4878 Vweak_hash_tables
= used
;
4883 /***********************************************************************
4884 Hash Code Computation
4885 ***********************************************************************/
4887 /* Maximum depth up to which to dive into Lisp structures. */
4889 #define SXHASH_MAX_DEPTH 3
4891 /* Maximum length up to which to take list and vector elements into
4894 #define SXHASH_MAX_LEN 7
4896 /* Combine two integers X and Y for hashing. */
4898 #define SXHASH_COMBINE(X, Y) \
4899 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4903 /* Return a hash for string PTR which has length LEN. The hash
4904 code returned is guaranteed to fit in a Lisp integer. */
4907 sxhash_string (ptr
, len
)
4911 unsigned char *p
= ptr
;
4912 unsigned char *end
= p
+ len
;
4921 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4924 return hash
& INTMASK
;
4928 /* Return a hash for list LIST. DEPTH is the current depth in the
4929 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4932 sxhash_list (list
, depth
)
4939 if (depth
< SXHASH_MAX_DEPTH
)
4941 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4942 list
= XCDR (list
), ++i
)
4944 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4945 hash
= SXHASH_COMBINE (hash
, hash2
);
4952 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4953 the Lisp structure. */
4956 sxhash_vector (vec
, depth
)
4960 unsigned hash
= XVECTOR (vec
)->size
;
4963 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4964 for (i
= 0; i
< n
; ++i
)
4966 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4967 hash
= SXHASH_COMBINE (hash
, hash2
);
4974 /* Return a hash for bool-vector VECTOR. */
4977 sxhash_bool_vector (vec
)
4980 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4983 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4984 for (i
= 0; i
< n
; ++i
)
4985 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4991 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4992 structure. Value is an unsigned integer clipped to INTMASK. */
5001 if (depth
> SXHASH_MAX_DEPTH
)
5004 switch (XTYPE (obj
))
5011 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
5012 SCHARS (SYMBOL_NAME (obj
)));
5020 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5023 /* This can be everything from a vector to an overlay. */
5024 case Lisp_Vectorlike
:
5026 /* According to the CL HyperSpec, two arrays are equal only if
5027 they are `eq', except for strings and bit-vectors. In
5028 Emacs, this works differently. We have to compare element
5030 hash
= sxhash_vector (obj
, depth
);
5031 else if (BOOL_VECTOR_P (obj
))
5032 hash
= sxhash_bool_vector (obj
);
5034 /* Others are `equal' if they are `eq', so let's take their
5040 hash
= sxhash_list (obj
, depth
);
5045 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5046 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5047 for (hash
= 0; p
< e
; ++p
)
5048 hash
= SXHASH_COMBINE (hash
, *p
);
5056 return hash
& INTMASK
;
5061 /***********************************************************************
5063 ***********************************************************************/
5066 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5067 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5071 unsigned hash
= sxhash (obj
, 0);;
5072 return make_number (hash
);
5076 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5077 doc
: /* Create and return a new hash table.
5079 Arguments are specified as keyword/argument pairs. The following
5080 arguments are defined:
5082 :test TEST -- TEST must be a symbol that specifies how to compare
5083 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5084 `equal'. User-supplied test and hash functions can be specified via
5085 `define-hash-table-test'.
5087 :size SIZE -- A hint as to how many elements will be put in the table.
5090 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5091 fills up. If REHASH-SIZE is an integer, add that many space. If it
5092 is a float, it must be > 1.0, and the new size is computed by
5093 multiplying the old size with that factor. Default is 1.5.
5095 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5096 Resize the hash table when ratio of the number of entries in the
5097 table. Default is 0.8.
5099 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5100 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5101 returned is a weak table. Key/value pairs are removed from a weak
5102 hash table when there are no non-weak references pointing to their
5103 key, value, one of key or value, or both key and value, depending on
5104 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5107 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5112 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5113 Lisp_Object user_test
, user_hash
;
5117 /* The vector `used' is used to keep track of arguments that
5118 have been consumed. */
5119 used
= (char *) alloca (nargs
* sizeof *used
);
5120 bzero (used
, nargs
* sizeof *used
);
5122 /* See if there's a `:test TEST' among the arguments. */
5123 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5124 test
= i
< 0 ? Qeql
: args
[i
];
5125 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5127 /* See if it is a user-defined test. */
5130 prop
= Fget (test
, Qhash_table_test
);
5131 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5132 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5134 user_test
= XCAR (prop
);
5135 user_hash
= XCAR (XCDR (prop
));
5138 user_test
= user_hash
= Qnil
;
5140 /* See if there's a `:size SIZE' argument. */
5141 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5142 size
= i
< 0 ? Qnil
: args
[i
];
5144 size
= make_number (DEFAULT_HASH_SIZE
);
5145 else if (!INTEGERP (size
) || XINT (size
) < 0)
5147 list2 (build_string ("Invalid hash table size"),
5150 /* Look for `:rehash-size SIZE'. */
5151 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5152 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5153 if (!NUMBERP (rehash_size
)
5154 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5155 || XFLOATINT (rehash_size
) <= 1.0)
5157 list2 (build_string ("Invalid hash table rehash size"),
5160 /* Look for `:rehash-threshold THRESHOLD'. */
5161 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5162 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5163 if (!FLOATP (rehash_threshold
)
5164 || XFLOATINT (rehash_threshold
) <= 0.0
5165 || XFLOATINT (rehash_threshold
) > 1.0)
5167 list2 (build_string ("Invalid hash table rehash threshold"),
5170 /* Look for `:weakness WEAK'. */
5171 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5172 weak
= i
< 0 ? Qnil
: args
[i
];
5174 weak
= Qkey_and_value
;
5177 && !EQ (weak
, Qvalue
)
5178 && !EQ (weak
, Qkey_or_value
)
5179 && !EQ (weak
, Qkey_and_value
))
5180 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5183 /* Now, all args should have been used up, or there's a problem. */
5184 for (i
= 0; i
< nargs
; ++i
)
5187 list2 (build_string ("Invalid argument list"), args
[i
]));
5189 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5190 user_test
, user_hash
);
5194 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5195 doc
: /* Return a copy of hash table TABLE. */)
5199 return copy_hash_table (check_hash_table (table
));
5203 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5204 doc
: /* Return the number of elements in TABLE. */)
5208 return check_hash_table (table
)->count
;
5212 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5213 Shash_table_rehash_size
, 1, 1, 0,
5214 doc
: /* Return the current rehash size of TABLE. */)
5218 return check_hash_table (table
)->rehash_size
;
5222 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5223 Shash_table_rehash_threshold
, 1, 1, 0,
5224 doc
: /* Return the current rehash threshold of TABLE. */)
5228 return check_hash_table (table
)->rehash_threshold
;
5232 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5233 doc
: /* Return the size of TABLE.
5234 The size can be used as an argument to `make-hash-table' to create
5235 a hash table than can hold as many elements of TABLE holds
5236 without need for resizing. */)
5240 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5241 return make_number (HASH_TABLE_SIZE (h
));
5245 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5246 doc
: /* Return the test TABLE uses. */)
5250 return check_hash_table (table
)->test
;
5254 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5256 doc
: /* Return the weakness of TABLE. */)
5260 return check_hash_table (table
)->weak
;
5264 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5265 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5269 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5273 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5274 doc
: /* Clear hash table TABLE. */)
5278 hash_clear (check_hash_table (table
));
5283 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5284 doc
: /* Look up KEY in TABLE and return its associated value.
5285 If KEY is not found, return DFLT which defaults to nil. */)
5287 Lisp_Object key
, table
, dflt
;
5289 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5290 int i
= hash_lookup (h
, key
, NULL
);
5291 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5295 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5296 doc
: /* Associate KEY with VALUE in hash table TABLE.
5297 If KEY is already present in table, replace its current value with
5300 Lisp_Object key
, value
, table
;
5302 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5306 i
= hash_lookup (h
, key
, &hash
);
5308 HASH_VALUE (h
, i
) = value
;
5310 hash_put (h
, key
, value
, hash
);
5316 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5317 doc
: /* Remove KEY from TABLE. */)
5319 Lisp_Object key
, table
;
5321 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5322 hash_remove (h
, key
);
5327 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5328 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5329 FUNCTION is called with 2 arguments KEY and VALUE. */)
5331 Lisp_Object function
, table
;
5333 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5334 Lisp_Object args
[3];
5337 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5338 if (!NILP (HASH_HASH (h
, i
)))
5341 args
[1] = HASH_KEY (h
, i
);
5342 args
[2] = HASH_VALUE (h
, i
);
5350 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5351 Sdefine_hash_table_test
, 3, 3, 0,
5352 doc
: /* Define a new hash table test with name NAME, a symbol.
5354 In hash tables created with NAME specified as test, use TEST to
5355 compare keys, and HASH for computing hash codes of keys.
5357 TEST must be a function taking two arguments and returning non-nil if
5358 both arguments are the same. HASH must be a function taking one
5359 argument and return an integer that is the hash code of the argument.
5360 Hash code computation should use the whole value range of integers,
5361 including negative integers. */)
5363 Lisp_Object name
, test
, hash
;
5365 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5370 /************************************************************************
5372 ************************************************************************/
5377 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5378 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5380 A message digest is a cryptographic checksum of a document, and the
5381 algorithm to calculate it is defined in RFC 1321.
5383 The two optional arguments START and END are character positions
5384 specifying for which part of OBJECT the message digest should be
5385 computed. If nil or omitted, the digest is computed for the whole
5388 The MD5 message digest is computed from the result of encoding the
5389 text in a coding system, not directly from the internal Emacs form of
5390 the text. The optional fourth argument CODING-SYSTEM specifies which
5391 coding system to encode the text with. It should be the same coding
5392 system that you used or will use when actually writing the text into a
5395 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5396 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5397 system would be chosen by default for writing this text into a file.
5399 If OBJECT is a string, the most preferred coding system (see the
5400 command `prefer-coding-system') is used.
5402 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5403 guesswork fails. Normally, an error is signaled in such case. */)
5404 (object
, start
, end
, coding_system
, noerror
)
5405 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5407 unsigned char digest
[16];
5408 unsigned char value
[33];
5412 int start_char
= 0, end_char
= 0;
5413 int start_byte
= 0, end_byte
= 0;
5415 register struct buffer
*bp
;
5418 if (STRINGP (object
))
5420 if (NILP (coding_system
))
5422 /* Decide the coding-system to encode the data with. */
5424 if (STRING_MULTIBYTE (object
))
5425 /* use default, we can't guess correct value */
5426 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5428 coding_system
= Qraw_text
;
5431 if (NILP (Fcoding_system_p (coding_system
)))
5433 /* Invalid coding system. */
5435 if (!NILP (noerror
))
5436 coding_system
= Qraw_text
;
5439 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5442 if (STRING_MULTIBYTE (object
))
5443 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5445 size
= SCHARS (object
);
5446 size_byte
= SBYTES (object
);
5450 CHECK_NUMBER (start
);
5452 start_char
= XINT (start
);
5457 start_byte
= string_char_to_byte (object
, start_char
);
5463 end_byte
= size_byte
;
5469 end_char
= XINT (end
);
5474 end_byte
= string_char_to_byte (object
, end_char
);
5477 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5478 args_out_of_range_3 (object
, make_number (start_char
),
5479 make_number (end_char
));
5483 struct buffer
*prev
= current_buffer
;
5485 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5487 CHECK_BUFFER (object
);
5489 bp
= XBUFFER (object
);
5490 if (bp
!= current_buffer
)
5491 set_buffer_internal (bp
);
5497 CHECK_NUMBER_COERCE_MARKER (start
);
5505 CHECK_NUMBER_COERCE_MARKER (end
);
5510 temp
= b
, b
= e
, e
= temp
;
5512 if (!(BEGV
<= b
&& e
<= ZV
))
5513 args_out_of_range (start
, end
);
5515 if (NILP (coding_system
))
5517 /* Decide the coding-system to encode the data with.
5518 See fileio.c:Fwrite-region */
5520 if (!NILP (Vcoding_system_for_write
))
5521 coding_system
= Vcoding_system_for_write
;
5524 int force_raw_text
= 0;
5526 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5527 if (NILP (coding_system
)
5528 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5530 coding_system
= Qnil
;
5531 if (NILP (current_buffer
->enable_multibyte_characters
))
5535 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5537 /* Check file-coding-system-alist. */
5538 Lisp_Object args
[4], val
;
5540 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5541 args
[3] = Fbuffer_file_name(object
);
5542 val
= Ffind_operation_coding_system (4, args
);
5543 if (CONSP (val
) && !NILP (XCDR (val
)))
5544 coding_system
= XCDR (val
);
5547 if (NILP (coding_system
)
5548 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5550 /* If we still have not decided a coding system, use the
5551 default value of buffer-file-coding-system. */
5552 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5556 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5557 /* Confirm that VAL can surely encode the current region. */
5558 coding_system
= call4 (Vselect_safe_coding_system_function
,
5559 make_number (b
), make_number (e
),
5560 coding_system
, Qnil
);
5563 coding_system
= Qraw_text
;
5566 if (NILP (Fcoding_system_p (coding_system
)))
5568 /* Invalid coding system. */
5570 if (!NILP (noerror
))
5571 coding_system
= Qraw_text
;
5574 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5578 object
= make_buffer_string (b
, e
, 0);
5579 if (prev
!= current_buffer
)
5580 set_buffer_internal (prev
);
5581 /* Discard the unwind protect for recovering the current
5585 if (STRING_MULTIBYTE (object
))
5586 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5589 md5_buffer (SDATA (object
) + start_byte
,
5590 SBYTES (object
) - (size_byte
- end_byte
),
5593 for (i
= 0; i
< 16; i
++)
5594 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5597 return make_string (value
, 32);
5604 /* Hash table stuff. */
5605 Qhash_table_p
= intern ("hash-table-p");
5606 staticpro (&Qhash_table_p
);
5607 Qeq
= intern ("eq");
5609 Qeql
= intern ("eql");
5611 Qequal
= intern ("equal");
5612 staticpro (&Qequal
);
5613 QCtest
= intern (":test");
5614 staticpro (&QCtest
);
5615 QCsize
= intern (":size");
5616 staticpro (&QCsize
);
5617 QCrehash_size
= intern (":rehash-size");
5618 staticpro (&QCrehash_size
);
5619 QCrehash_threshold
= intern (":rehash-threshold");
5620 staticpro (&QCrehash_threshold
);
5621 QCweakness
= intern (":weakness");
5622 staticpro (&QCweakness
);
5623 Qkey
= intern ("key");
5625 Qvalue
= intern ("value");
5626 staticpro (&Qvalue
);
5627 Qhash_table_test
= intern ("hash-table-test");
5628 staticpro (&Qhash_table_test
);
5629 Qkey_or_value
= intern ("key-or-value");
5630 staticpro (&Qkey_or_value
);
5631 Qkey_and_value
= intern ("key-and-value");
5632 staticpro (&Qkey_and_value
);
5635 defsubr (&Smake_hash_table
);
5636 defsubr (&Scopy_hash_table
);
5637 defsubr (&Shash_table_count
);
5638 defsubr (&Shash_table_rehash_size
);
5639 defsubr (&Shash_table_rehash_threshold
);
5640 defsubr (&Shash_table_size
);
5641 defsubr (&Shash_table_test
);
5642 defsubr (&Shash_table_weakness
);
5643 defsubr (&Shash_table_p
);
5644 defsubr (&Sclrhash
);
5645 defsubr (&Sgethash
);
5646 defsubr (&Sputhash
);
5647 defsubr (&Sremhash
);
5648 defsubr (&Smaphash
);
5649 defsubr (&Sdefine_hash_table_test
);
5651 Qstring_lessp
= intern ("string-lessp");
5652 staticpro (&Qstring_lessp
);
5653 Qprovide
= intern ("provide");
5654 staticpro (&Qprovide
);
5655 Qrequire
= intern ("require");
5656 staticpro (&Qrequire
);
5657 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5658 staticpro (&Qyes_or_no_p_history
);
5659 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5660 staticpro (&Qcursor_in_echo_area
);
5661 Qwidget_type
= intern ("widget-type");
5662 staticpro (&Qwidget_type
);
5664 staticpro (&string_char_byte_cache_string
);
5665 string_char_byte_cache_string
= Qnil
;
5667 require_nesting_list
= Qnil
;
5668 staticpro (&require_nesting_list
);
5670 Fset (Qyes_or_no_p_history
, Qnil
);
5672 DEFVAR_LISP ("features", &Vfeatures
,
5673 doc
: /* A list of symbols which are the features of the executing emacs.
5674 Used by `featurep' and `require', and altered by `provide'. */);
5676 Qsubfeatures
= intern ("subfeatures");
5677 staticpro (&Qsubfeatures
);
5679 #ifdef HAVE_LANGINFO_CODESET
5680 Qcodeset
= intern ("codeset");
5681 staticpro (&Qcodeset
);
5682 Qdays
= intern ("days");
5684 Qmonths
= intern ("months");
5685 staticpro (&Qmonths
);
5686 Qpaper
= intern ("paper");
5687 staticpro (&Qpaper
);
5688 #endif /* HAVE_LANGINFO_CODESET */
5690 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5691 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5692 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5693 invoked by mouse clicks and mouse menu items. */);
5696 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5697 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5698 This applies to commands from menus and tool bar buttons. The value of
5699 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5700 used if both `use-dialog-box' and this variable are non-nil. */);
5701 use_file_dialog
= 1;
5703 defsubr (&Sidentity
);
5706 defsubr (&Ssafe_length
);
5707 defsubr (&Sstring_bytes
);
5708 defsubr (&Sstring_equal
);
5709 defsubr (&Scompare_strings
);
5710 defsubr (&Sstring_lessp
);
5713 defsubr (&Svconcat
);
5714 defsubr (&Scopy_sequence
);
5715 defsubr (&Sstring_make_multibyte
);
5716 defsubr (&Sstring_make_unibyte
);
5717 defsubr (&Sstring_as_multibyte
);
5718 defsubr (&Sstring_as_unibyte
);
5719 defsubr (&Sstring_to_multibyte
);
5720 defsubr (&Scopy_alist
);
5721 defsubr (&Ssubstring
);
5722 defsubr (&Ssubstring_no_properties
);
5734 defsubr (&Snreverse
);
5735 defsubr (&Sreverse
);
5737 defsubr (&Splist_get
);
5739 defsubr (&Splist_put
);
5741 defsubr (&Slax_plist_get
);
5742 defsubr (&Slax_plist_put
);
5744 defsubr (&Sequal_including_properties
);
5745 defsubr (&Sfillarray
);
5746 defsubr (&Sclear_string
);
5747 defsubr (&Schar_table_subtype
);
5748 defsubr (&Schar_table_parent
);
5749 defsubr (&Sset_char_table_parent
);
5750 defsubr (&Schar_table_extra_slot
);
5751 defsubr (&Sset_char_table_extra_slot
);
5752 defsubr (&Schar_table_range
);
5753 defsubr (&Sset_char_table_range
);
5754 defsubr (&Sset_char_table_default
);
5755 defsubr (&Soptimize_char_table
);
5756 defsubr (&Smap_char_table
);
5760 defsubr (&Smapconcat
);
5761 defsubr (&Sy_or_n_p
);
5762 defsubr (&Syes_or_no_p
);
5763 defsubr (&Sload_average
);
5764 defsubr (&Sfeaturep
);
5765 defsubr (&Srequire
);
5766 defsubr (&Sprovide
);
5767 defsubr (&Splist_member
);
5768 defsubr (&Swidget_put
);
5769 defsubr (&Swidget_get
);
5770 defsubr (&Swidget_apply
);
5771 defsubr (&Sbase64_encode_region
);
5772 defsubr (&Sbase64_decode_region
);
5773 defsubr (&Sbase64_encode_string
);
5774 defsubr (&Sbase64_decode_string
);
5776 defsubr (&Slocale_info
);
5783 Vweak_hash_tables
= Qnil
;
5786 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5787 (do not change this comment) */