1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 02, 03, 2004
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* On Mac OS X, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 /* Nonzero enables use of a file dialog for file name
63 questions asked by mouse commands. */
66 extern int minibuffer_auto_raise
;
67 extern Lisp_Object minibuf_window
;
68 extern Lisp_Object Vlocale_coding_system
;
70 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
71 Lisp_Object Qyes_or_no_p_history
;
72 Lisp_Object Qcursor_in_echo_area
;
73 Lisp_Object Qwidget_type
;
74 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
76 extern Lisp_Object Qinput_method_function
;
78 static int internal_equal ();
80 extern long get_random ();
81 extern void seed_random ();
87 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
88 doc
: /* Return the argument unchanged. */)
95 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
96 doc
: /* Return a pseudo-random number.
97 All integers representable in Lisp are equally likely.
98 On most systems, this is 29 bits' worth.
99 With positive integer argument N, return random number in interval [0,N).
100 With argument t, set the random number seed from the current time and pid. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (n
) && XFASTINT (n
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (n
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
145 if (STRINGP (sequence
))
146 XSETFASTINT (val
, SCHARS (sequence
));
147 else if (VECTORP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
149 else if (SUB_CHAR_TABLE_P (sequence
))
150 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
151 else if (CHAR_TABLE_P (sequence
))
152 XSETFASTINT (val
, MAX_CHAR
);
153 else if (BOOL_VECTOR_P (sequence
))
154 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
155 else if (COMPILEDP (sequence
))
156 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
157 else if (CONSP (sequence
))
160 while (CONSP (sequence
))
162 sequence
= XCDR (sequence
);
165 if (!CONSP (sequence
))
168 sequence
= XCDR (sequence
);
173 if (!NILP (sequence
))
174 wrong_type_argument (Qlistp
, sequence
);
176 val
= make_number (i
);
178 else if (NILP (sequence
))
179 XSETFASTINT (val
, 0);
182 sequence
= wrong_type_argument (Qsequencep
, sequence
);
188 /* This does not check for quits. That is safe
189 since it must terminate. */
191 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
192 doc
: /* Return the length of a list, but avoid error or infinite loop.
193 This function never gets an error. If LIST is not really a list,
194 it returns 0. If LIST is circular, it returns a finite value
195 which is at least the number of distinct elements. */)
199 Lisp_Object tail
, halftail
, length
;
202 /* halftail is used to detect circular lists. */
204 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
206 if (EQ (tail
, halftail
) && len
!= 0)
210 halftail
= XCDR (halftail
);
213 XSETINT (length
, len
);
217 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
218 doc
: /* Return the number of bytes in STRING.
219 If STRING is a multibyte string, this is greater than the length of STRING. */)
223 CHECK_STRING (string
);
224 return make_number (SBYTES (string
));
227 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
228 doc
: /* Return t if two strings have identical contents.
229 Case is significant, but text properties are ignored.
230 Symbols are also allowed; their print names are used instead. */)
232 register Lisp_Object s1
, s2
;
235 s1
= SYMBOL_NAME (s1
);
237 s2
= SYMBOL_NAME (s2
);
241 if (SCHARS (s1
) != SCHARS (s2
)
242 || SBYTES (s1
) != SBYTES (s2
)
243 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
248 DEFUN ("compare-strings", Fcompare_strings
,
249 Scompare_strings
, 6, 7, 0,
250 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
251 In string STR1, skip the first START1 characters and stop at END1.
252 In string STR2, skip the first START2 characters and stop at END2.
253 END1 and END2 default to the full lengths of the respective strings.
255 Case is significant in this comparison if IGNORE-CASE is nil.
256 Unibyte strings are converted to multibyte for comparison.
258 The value is t if the strings (or specified portions) match.
259 If string STR1 is less, the value is a negative number N;
260 - 1 - N is the number of characters that match at the beginning.
261 If string STR1 is greater, the value is a positive number N;
262 N - 1 is the number of characters that match at the beginning. */)
263 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
264 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
266 register int end1_char
, end2_char
;
267 register int i1
, i1_byte
, i2
, i2_byte
;
272 start1
= make_number (0);
274 start2
= make_number (0);
275 CHECK_NATNUM (start1
);
276 CHECK_NATNUM (start2
);
285 i1_byte
= string_char_to_byte (str1
, i1
);
286 i2_byte
= string_char_to_byte (str2
, i2
);
288 end1_char
= SCHARS (str1
);
289 if (! NILP (end1
) && end1_char
> XINT (end1
))
290 end1_char
= XINT (end1
);
292 end2_char
= SCHARS (str2
);
293 if (! NILP (end2
) && end2_char
> XINT (end2
))
294 end2_char
= XINT (end2
);
296 while (i1
< end1_char
&& i2
< end2_char
)
298 /* When we find a mismatch, we must compare the
299 characters, not just the bytes. */
302 if (STRING_MULTIBYTE (str1
))
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
306 c1
= SREF (str1
, i1
++);
307 c1
= unibyte_char_to_multibyte (c1
);
310 if (STRING_MULTIBYTE (str2
))
311 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
314 c2
= SREF (str2
, i2
++);
315 c2
= unibyte_char_to_multibyte (c2
);
321 if (! NILP (ignore_case
))
325 tem
= Fupcase (make_number (c1
));
327 tem
= Fupcase (make_number (c2
));
334 /* Note that I1 has already been incremented
335 past the character that we are comparing;
336 hence we don't add or subtract 1 here. */
338 return make_number (- i1
+ XINT (start1
));
340 return make_number (i1
- XINT (start1
));
344 return make_number (i1
- XINT (start1
) + 1);
346 return make_number (- i1
+ XINT (start1
) - 1);
351 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
352 doc
: /* Return t if first arg string is less than second in lexicographic order.
354 Symbols are also allowed; their print names are used instead. */)
356 register Lisp_Object s1
, s2
;
359 register int i1
, i1_byte
, i2
, i2_byte
;
362 s1
= SYMBOL_NAME (s1
);
364 s2
= SYMBOL_NAME (s2
);
368 i1
= i1_byte
= i2
= i2_byte
= 0;
371 if (end
> SCHARS (s2
))
376 /* When we find a mismatch, we must compare the
377 characters, not just the bytes. */
380 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
381 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
384 return c1
< c2
? Qt
: Qnil
;
386 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
389 static Lisp_Object
concat ();
400 return concat (2, args
, Lisp_String
, 0);
402 return concat (2, &s1
, Lisp_String
, 0);
403 #endif /* NO_ARG_ARRAY */
409 Lisp_Object s1
, s2
, s3
;
416 return concat (3, args
, Lisp_String
, 0);
418 return concat (3, &s1
, Lisp_String
, 0);
419 #endif /* NO_ARG_ARRAY */
422 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
423 doc
: /* Concatenate all the arguments and make the result a list.
424 The result is a list whose elements are the elements of all the arguments.
425 Each argument may be a list, vector or string.
426 The last argument is not copied, just used as the tail of the new list.
427 usage: (append &rest SEQUENCES) */)
432 return concat (nargs
, args
, Lisp_Cons
, 1);
435 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
436 doc
: /* Concatenate all the arguments and make the result a string.
437 The result is a string whose elements are the elements of all the arguments.
438 Each argument may be a string or a list or vector of characters (integers).
439 usage: (concat &rest SEQUENCES) */)
444 return concat (nargs
, args
, Lisp_String
, 0);
447 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
448 doc
: /* Concatenate all the arguments and make the result a vector.
449 The result is a vector whose elements are the elements of all the arguments.
450 Each argument may be a list, vector or string.
451 usage: (vconcat &rest SEQUENCES) */)
456 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
459 /* Return a copy of a sub char table ARG. The elements except for a
460 nested sub char table are not copied. */
462 copy_sub_char_table (arg
)
465 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
468 /* Copy all the contents. */
469 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
470 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
471 /* Recursively copy any sub char-tables in the ordinary slots. */
472 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
473 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
474 XCHAR_TABLE (copy
)->contents
[i
]
475 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
481 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
482 doc
: /* Return a copy of a list, vector, string or char-table.
483 The elements of a list or vector are not copied; they are shared
484 with the original. */)
488 if (NILP (arg
)) return arg
;
490 if (CHAR_TABLE_P (arg
))
495 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
496 /* Copy all the slots, including the extra ones. */
497 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
498 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
499 * sizeof (Lisp_Object
)));
501 /* Recursively copy any sub char tables in the ordinary slots
502 for multibyte characters. */
503 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
504 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
505 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
506 XCHAR_TABLE (copy
)->contents
[i
]
507 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
512 if (BOOL_VECTOR_P (arg
))
516 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
517 / BOOL_VECTOR_BITS_PER_CHAR
);
519 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
520 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
525 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
526 arg
= wrong_type_argument (Qsequencep
, arg
);
527 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
530 /* In string STR of length LEN, see if bytes before STR[I] combine
531 with bytes after STR[I] to form a single character. If so, return
532 the number of bytes after STR[I] which combine in this way.
533 Otherwize, return 0. */
536 count_combining (str
, len
, i
)
540 int j
= i
- 1, bytes
;
542 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
544 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
545 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
547 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
548 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
551 /* This structure holds information of an argument of `concat' that is
552 a string and has text properties to be copied. */
555 int argnum
; /* refer to ARGS (arguments of `concat') */
556 int from
; /* refer to ARGS[argnum] (argument string) */
557 int to
; /* refer to VAL (the target string) */
561 concat (nargs
, args
, target_type
, last_special
)
564 enum Lisp_Type target_type
;
568 register Lisp_Object tail
;
569 register Lisp_Object
this;
571 int toindex_byte
= 0;
572 register int result_len
;
573 register int result_len_byte
;
575 Lisp_Object last_tail
;
578 /* When we make a multibyte string, we can't copy text properties
579 while concatinating each string because the length of resulting
580 string can't be decided until we finish the whole concatination.
581 So, we record strings that have text properties to be copied
582 here, and copy the text properties after the concatination. */
583 struct textprop_rec
*textprops
= NULL
;
584 /* Number of elments in textprops. */
585 int num_textprops
= 0;
589 /* In append, the last arg isn't treated like the others */
590 if (last_special
&& nargs
> 0)
593 last_tail
= args
[nargs
];
598 /* Canonicalize each argument. */
599 for (argnum
= 0; argnum
< nargs
; argnum
++)
602 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
603 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
605 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
609 /* Compute total length in chars of arguments in RESULT_LEN.
610 If desired output is a string, also compute length in bytes
611 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
612 whether the result should be a multibyte string. */
616 for (argnum
= 0; argnum
< nargs
; argnum
++)
620 len
= XFASTINT (Flength (this));
621 if (target_type
== Lisp_String
)
623 /* We must count the number of bytes needed in the string
624 as well as the number of characters. */
630 for (i
= 0; i
< len
; i
++)
632 ch
= XVECTOR (this)->contents
[i
];
634 wrong_type_argument (Qintegerp
, ch
);
635 this_len_byte
= CHAR_BYTES (XINT (ch
));
636 result_len_byte
+= this_len_byte
;
637 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
640 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
641 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
642 else if (CONSP (this))
643 for (; CONSP (this); this = XCDR (this))
647 wrong_type_argument (Qintegerp
, ch
);
648 this_len_byte
= CHAR_BYTES (XINT (ch
));
649 result_len_byte
+= this_len_byte
;
650 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
653 else if (STRINGP (this))
655 if (STRING_MULTIBYTE (this))
658 result_len_byte
+= SBYTES (this);
661 result_len_byte
+= count_size_as_multibyte (SDATA (this),
669 if (! some_multibyte
)
670 result_len_byte
= result_len
;
672 /* Create the output object. */
673 if (target_type
== Lisp_Cons
)
674 val
= Fmake_list (make_number (result_len
), Qnil
);
675 else if (target_type
== Lisp_Vectorlike
)
676 val
= Fmake_vector (make_number (result_len
), Qnil
);
677 else if (some_multibyte
)
678 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
680 val
= make_uninit_string (result_len
);
682 /* In `append', if all but last arg are nil, return last arg. */
683 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
686 /* Copy the contents of the args into the result. */
688 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
690 toindex
= 0, toindex_byte
= 0;
695 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
697 for (argnum
= 0; argnum
< nargs
; argnum
++)
701 register unsigned int thisindex
= 0;
702 register unsigned int thisindex_byte
= 0;
706 thislen
= Flength (this), thisleni
= XINT (thislen
);
708 /* Between strings of the same kind, copy fast. */
709 if (STRINGP (this) && STRINGP (val
)
710 && STRING_MULTIBYTE (this) == some_multibyte
)
712 int thislen_byte
= SBYTES (this);
715 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
717 combined
= (some_multibyte
&& toindex_byte
> 0
718 ? count_combining (SDATA (val
),
719 toindex_byte
+ thislen_byte
,
722 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
724 textprops
[num_textprops
].argnum
= argnum
;
725 /* We ignore text properties on characters being combined. */
726 textprops
[num_textprops
].from
= combined
;
727 textprops
[num_textprops
++].to
= toindex
;
729 toindex_byte
+= thislen_byte
;
730 toindex
+= thisleni
- combined
;
731 STRING_SET_CHARS (val
, SCHARS (val
) - combined
);
733 /* Copy a single-byte string to a multibyte string. */
734 else if (STRINGP (this) && STRINGP (val
))
736 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
738 textprops
[num_textprops
].argnum
= argnum
;
739 textprops
[num_textprops
].from
= 0;
740 textprops
[num_textprops
++].to
= toindex
;
742 toindex_byte
+= copy_text (SDATA (this),
743 SDATA (val
) + toindex_byte
,
744 SCHARS (this), 0, 1);
748 /* Copy element by element. */
751 register Lisp_Object elt
;
753 /* Fetch next element of `this' arg into `elt', or break if
754 `this' is exhausted. */
755 if (NILP (this)) break;
757 elt
= XCAR (this), this = XCDR (this);
758 else if (thisindex
>= thisleni
)
760 else if (STRINGP (this))
763 if (STRING_MULTIBYTE (this))
765 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
768 XSETFASTINT (elt
, c
);
772 XSETFASTINT (elt
, SREF (this, thisindex
++));
774 && (XINT (elt
) >= 0240
775 || (XINT (elt
) >= 0200
776 && ! NILP (Vnonascii_translation_table
)))
777 && XINT (elt
) < 0400)
779 c
= unibyte_char_to_multibyte (XINT (elt
));
784 else if (BOOL_VECTOR_P (this))
787 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
788 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
795 elt
= XVECTOR (this)->contents
[thisindex
++];
797 /* Store this element into the result. */
804 else if (VECTORP (val
))
805 XVECTOR (val
)->contents
[toindex
++] = elt
;
809 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
813 += CHAR_STRING (XINT (elt
),
814 SDATA (val
) + toindex_byte
);
816 SSET (val
, toindex_byte
++, XINT (elt
));
819 && count_combining (SDATA (val
),
820 toindex_byte
, toindex_byte
- 1))
821 STRING_SET_CHARS (val
, SCHARS (val
) - 1);
826 /* If we have any multibyte characters,
827 we already decided to make a multibyte string. */
830 /* P exists as a variable
831 to avoid a bug on the Masscomp C compiler. */
832 unsigned char *p
= SDATA (val
) + toindex_byte
;
834 toindex_byte
+= CHAR_STRING (c
, p
);
841 XSETCDR (prev
, last_tail
);
843 if (num_textprops
> 0)
846 int last_to_end
= -1;
848 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
850 this = args
[textprops
[argnum
].argnum
];
851 props
= text_property_list (this,
853 make_number (SCHARS (this)),
855 /* If successive arguments have properites, be sure that the
856 value of `composition' property be the copy. */
857 if (last_to_end
== textprops
[argnum
].to
)
858 make_composition_value_copy (props
);
859 add_text_properties_from_list (val
, props
,
860 make_number (textprops
[argnum
].to
));
861 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
867 static Lisp_Object string_char_byte_cache_string
;
868 static int string_char_byte_cache_charpos
;
869 static int string_char_byte_cache_bytepos
;
872 clear_string_char_byte_cache ()
874 string_char_byte_cache_string
= Qnil
;
877 /* Return the character index corresponding to CHAR_INDEX in STRING. */
880 string_char_to_byte (string
, char_index
)
885 int best_below
, best_below_byte
;
886 int best_above
, best_above_byte
;
888 best_below
= best_below_byte
= 0;
889 best_above
= SCHARS (string
);
890 best_above_byte
= SBYTES (string
);
891 if (best_above
== best_above_byte
)
894 if (EQ (string
, string_char_byte_cache_string
))
896 if (string_char_byte_cache_charpos
< char_index
)
898 best_below
= string_char_byte_cache_charpos
;
899 best_below_byte
= string_char_byte_cache_bytepos
;
903 best_above
= string_char_byte_cache_charpos
;
904 best_above_byte
= string_char_byte_cache_bytepos
;
908 if (char_index
- best_below
< best_above
- char_index
)
910 while (best_below
< char_index
)
913 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
914 best_below
, best_below_byte
);
917 i_byte
= best_below_byte
;
921 while (best_above
> char_index
)
923 unsigned char *pend
= SDATA (string
) + best_above_byte
;
924 unsigned char *pbeg
= pend
- best_above_byte
;
925 unsigned char *p
= pend
- 1;
928 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
929 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
930 if (bytes
== pend
- p
)
931 best_above_byte
-= bytes
;
932 else if (bytes
> pend
- p
)
933 best_above_byte
-= (pend
- p
);
939 i_byte
= best_above_byte
;
942 string_char_byte_cache_bytepos
= i_byte
;
943 string_char_byte_cache_charpos
= i
;
944 string_char_byte_cache_string
= string
;
949 /* Return the character index corresponding to BYTE_INDEX in STRING. */
952 string_byte_to_char (string
, byte_index
)
957 int best_below
, best_below_byte
;
958 int best_above
, best_above_byte
;
960 best_below
= best_below_byte
= 0;
961 best_above
= SCHARS (string
);
962 best_above_byte
= SBYTES (string
);
963 if (best_above
== best_above_byte
)
966 if (EQ (string
, string_char_byte_cache_string
))
968 if (string_char_byte_cache_bytepos
< byte_index
)
970 best_below
= string_char_byte_cache_charpos
;
971 best_below_byte
= string_char_byte_cache_bytepos
;
975 best_above
= string_char_byte_cache_charpos
;
976 best_above_byte
= string_char_byte_cache_bytepos
;
980 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
982 while (best_below_byte
< byte_index
)
985 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
986 best_below
, best_below_byte
);
989 i_byte
= best_below_byte
;
993 while (best_above_byte
> byte_index
)
995 unsigned char *pend
= SDATA (string
) + best_above_byte
;
996 unsigned char *pbeg
= pend
- best_above_byte
;
997 unsigned char *p
= pend
- 1;
1000 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
1001 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
1002 if (bytes
== pend
- p
)
1003 best_above_byte
-= bytes
;
1004 else if (bytes
> pend
- p
)
1005 best_above_byte
-= (pend
- p
);
1011 i_byte
= best_above_byte
;
1014 string_char_byte_cache_bytepos
= i_byte
;
1015 string_char_byte_cache_charpos
= i
;
1016 string_char_byte_cache_string
= string
;
1021 /* Convert STRING to a multibyte string.
1022 Single-byte characters 0240 through 0377 are converted
1023 by adding nonascii_insert_offset to each. */
1026 string_make_multibyte (string
)
1032 if (STRING_MULTIBYTE (string
))
1035 nbytes
= count_size_as_multibyte (SDATA (string
),
1037 /* If all the chars are ASCII, they won't need any more bytes
1038 once converted. In that case, we can return STRING itself. */
1039 if (nbytes
== SBYTES (string
))
1042 buf
= (unsigned char *) alloca (nbytes
);
1043 copy_text (SDATA (string
), buf
, SBYTES (string
),
1046 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1050 /* Convert STRING to a multibyte string without changing each
1051 character codes. Thus, characters 0200 trough 0237 are converted
1052 to eight-bit-control characters, and characters 0240 through 0377
1053 are converted eight-bit-graphic characters. */
1056 string_to_multibyte (string
)
1062 if (STRING_MULTIBYTE (string
))
1065 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1066 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1067 any more bytes once converted. */
1068 if (nbytes
== SBYTES (string
))
1069 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1071 buf
= (unsigned char *) alloca (nbytes
);
1072 bcopy (SDATA (string
), buf
, SBYTES (string
));
1073 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1075 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1079 /* Convert STRING to a single-byte string. */
1082 string_make_unibyte (string
)
1087 if (! STRING_MULTIBYTE (string
))
1090 buf
= (unsigned char *) alloca (SCHARS (string
));
1092 copy_text (SDATA (string
), buf
, SBYTES (string
),
1095 return make_unibyte_string (buf
, SCHARS (string
));
1098 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1100 doc
: /* Return the multibyte equivalent of STRING.
1101 If STRING is unibyte and contains non-ASCII characters, the function
1102 `unibyte-char-to-multibyte' is used to convert each unibyte character
1103 to a multibyte character. In this case, the returned string is a
1104 newly created string with no text properties. If STRING is multibyte
1105 or entirely ASCII, it is returned unchanged. In particular, when
1106 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1107 \(When the characters are all ASCII, Emacs primitives will treat the
1108 string the same way whether it is unibyte or multibyte.) */)
1112 CHECK_STRING (string
);
1114 return string_make_multibyte (string
);
1117 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1119 doc
: /* Return the unibyte equivalent of STRING.
1120 Multibyte character codes are converted to unibyte according to
1121 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1122 If the lookup in the translation table fails, this function takes just
1123 the low 8 bits of each character. */)
1127 CHECK_STRING (string
);
1129 return string_make_unibyte (string
);
1132 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1134 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1135 If STRING is unibyte, the result is STRING itself.
1136 Otherwise it is a newly created string, with no text properties.
1137 If STRING is multibyte and contains a character of charset
1138 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1139 corresponding single byte. */)
1143 CHECK_STRING (string
);
1145 if (STRING_MULTIBYTE (string
))
1147 int bytes
= SBYTES (string
);
1148 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1150 bcopy (SDATA (string
), str
, bytes
);
1151 bytes
= str_as_unibyte (str
, bytes
);
1152 string
= make_unibyte_string (str
, bytes
);
1158 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1160 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1161 If STRING is multibyte, the result is STRING itself.
1162 Otherwise it is a newly created string, with no text properties.
1163 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1164 part of a multibyte form), it is converted to the corresponding
1165 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1169 CHECK_STRING (string
);
1171 if (! STRING_MULTIBYTE (string
))
1173 Lisp_Object new_string
;
1176 parse_str_as_multibyte (SDATA (string
),
1179 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1180 bcopy (SDATA (string
), SDATA (new_string
),
1182 if (nbytes
!= SBYTES (string
))
1183 str_as_multibyte (SDATA (new_string
), nbytes
,
1184 SBYTES (string
), NULL
);
1185 string
= new_string
;
1186 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1191 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1193 doc
: /* Return a multibyte string with the same individual chars as STRING.
1194 If STRING is multibyte, the result is STRING itself.
1195 Otherwise it is a newly created string, with no text properties.
1196 Characters 0200 through 0237 are converted to eight-bit-control
1197 characters of the same character code. Characters 0240 through 0377
1198 are converted to eight-bit-graphic characters of the same character
1203 CHECK_STRING (string
);
1205 return string_to_multibyte (string
);
1209 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1210 doc
: /* Return a copy of ALIST.
1211 This is an alist which represents the same mapping from objects to objects,
1212 but does not share the alist structure with ALIST.
1213 The objects mapped (cars and cdrs of elements of the alist)
1214 are shared, however.
1215 Elements of ALIST that are not conses are also shared. */)
1219 register Lisp_Object tem
;
1224 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1225 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1227 register Lisp_Object car
;
1231 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1236 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1237 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1238 TO may be nil or omitted; then the substring runs to the end of STRING.
1239 FROM and TO start at 0. If either is negative, it counts from the end.
1241 This function allows vectors as well as strings. */)
1244 register Lisp_Object from
, to
;
1249 int from_char
, to_char
;
1250 int from_byte
= 0, to_byte
= 0;
1252 if (! (STRINGP (string
) || VECTORP (string
)))
1253 wrong_type_argument (Qarrayp
, string
);
1255 CHECK_NUMBER (from
);
1257 if (STRINGP (string
))
1259 size
= SCHARS (string
);
1260 size_byte
= SBYTES (string
);
1263 size
= XVECTOR (string
)->size
;
1268 to_byte
= size_byte
;
1274 to_char
= XINT (to
);
1278 if (STRINGP (string
))
1279 to_byte
= string_char_to_byte (string
, to_char
);
1282 from_char
= XINT (from
);
1285 if (STRINGP (string
))
1286 from_byte
= string_char_to_byte (string
, from_char
);
1288 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1289 args_out_of_range_3 (string
, make_number (from_char
),
1290 make_number (to_char
));
1292 if (STRINGP (string
))
1294 res
= make_specified_string (SDATA (string
) + from_byte
,
1295 to_char
- from_char
, to_byte
- from_byte
,
1296 STRING_MULTIBYTE (string
));
1297 copy_text_properties (make_number (from_char
), make_number (to_char
),
1298 string
, make_number (0), res
, Qnil
);
1301 res
= Fvector (to_char
- from_char
,
1302 XVECTOR (string
)->contents
+ from_char
);
1308 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1309 doc
: /* Return a substring of STRING, without text properties.
1310 It starts at index FROM and ending before TO.
1311 TO may be nil or omitted; then the substring runs to the end of STRING.
1312 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1313 If FROM or TO is negative, it counts from the end.
1315 With one argument, just copy STRING without its properties. */)
1318 register Lisp_Object from
, to
;
1320 int size
, size_byte
;
1321 int from_char
, to_char
;
1322 int from_byte
, to_byte
;
1324 CHECK_STRING (string
);
1326 size
= SCHARS (string
);
1327 size_byte
= SBYTES (string
);
1330 from_char
= from_byte
= 0;
1333 CHECK_NUMBER (from
);
1334 from_char
= XINT (from
);
1338 from_byte
= string_char_to_byte (string
, from_char
);
1344 to_byte
= size_byte
;
1350 to_char
= XINT (to
);
1354 to_byte
= string_char_to_byte (string
, to_char
);
1357 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1358 args_out_of_range_3 (string
, make_number (from_char
),
1359 make_number (to_char
));
1361 return make_specified_string (SDATA (string
) + from_byte
,
1362 to_char
- from_char
, to_byte
- from_byte
,
1363 STRING_MULTIBYTE (string
));
1366 /* Extract a substring of STRING, giving start and end positions
1367 both in characters and in bytes. */
1370 substring_both (string
, from
, from_byte
, to
, to_byte
)
1372 int from
, from_byte
, to
, to_byte
;
1378 if (! (STRINGP (string
) || VECTORP (string
)))
1379 wrong_type_argument (Qarrayp
, string
);
1381 if (STRINGP (string
))
1383 size
= SCHARS (string
);
1384 size_byte
= SBYTES (string
);
1387 size
= XVECTOR (string
)->size
;
1389 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1390 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1392 if (STRINGP (string
))
1394 res
= make_specified_string (SDATA (string
) + from_byte
,
1395 to
- from
, to_byte
- from_byte
,
1396 STRING_MULTIBYTE (string
));
1397 copy_text_properties (make_number (from
), make_number (to
),
1398 string
, make_number (0), res
, Qnil
);
1401 res
= Fvector (to
- from
,
1402 XVECTOR (string
)->contents
+ from
);
1407 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1408 doc
: /* Take cdr N times on LIST, returns the result. */)
1411 register Lisp_Object list
;
1413 register int i
, num
;
1416 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1420 wrong_type_argument (Qlistp
, list
);
1426 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1427 doc
: /* Return the Nth element of LIST.
1428 N counts from zero. If LIST is not that long, nil is returned. */)
1430 Lisp_Object n
, list
;
1432 return Fcar (Fnthcdr (n
, list
));
1435 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1436 doc
: /* Return element of SEQUENCE at index N. */)
1438 register Lisp_Object sequence
, n
;
1443 if (CONSP (sequence
) || NILP (sequence
))
1444 return Fcar (Fnthcdr (n
, sequence
));
1445 else if (STRINGP (sequence
) || VECTORP (sequence
)
1446 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1447 return Faref (sequence
, n
);
1449 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1453 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1454 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1455 The value is actually the tail of LIST whose car is ELT. */)
1457 register Lisp_Object elt
;
1460 register Lisp_Object tail
;
1461 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1463 register Lisp_Object tem
;
1465 wrong_type_argument (Qlistp
, list
);
1467 if (! NILP (Fequal (elt
, tem
)))
1474 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1475 doc
: /* Return non-nil if ELT is an element of LIST.
1476 Comparison done with EQ. The value is actually the tail of LIST
1477 whose car is ELT. */)
1479 Lisp_Object elt
, list
;
1483 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1487 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1491 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1498 if (!CONSP (list
) && !NILP (list
))
1499 list
= wrong_type_argument (Qlistp
, list
);
1504 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1505 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1506 The value is actually the first element of LIST whose car is KEY.
1507 Elements of LIST that are not conses are ignored. */)
1509 Lisp_Object key
, list
;
1516 || (CONSP (XCAR (list
))
1517 && EQ (XCAR (XCAR (list
)), key
)))
1522 || (CONSP (XCAR (list
))
1523 && EQ (XCAR (XCAR (list
)), key
)))
1528 || (CONSP (XCAR (list
))
1529 && EQ (XCAR (XCAR (list
)), key
)))
1537 result
= XCAR (list
);
1538 else if (NILP (list
))
1541 result
= wrong_type_argument (Qlistp
, list
);
1546 /* Like Fassq but never report an error and do not allow quits.
1547 Use only on lists known never to be circular. */
1550 assq_no_quit (key
, list
)
1551 Lisp_Object key
, list
;
1554 && (!CONSP (XCAR (list
))
1555 || !EQ (XCAR (XCAR (list
)), key
)))
1558 return CONSP (list
) ? XCAR (list
) : Qnil
;
1561 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1562 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1563 The value is actually the first element of LIST whose car equals KEY. */)
1565 Lisp_Object key
, list
;
1567 Lisp_Object result
, car
;
1572 || (CONSP (XCAR (list
))
1573 && (car
= XCAR (XCAR (list
)),
1574 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1579 || (CONSP (XCAR (list
))
1580 && (car
= XCAR (XCAR (list
)),
1581 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1586 || (CONSP (XCAR (list
))
1587 && (car
= XCAR (XCAR (list
)),
1588 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1596 result
= XCAR (list
);
1597 else if (NILP (list
))
1600 result
= wrong_type_argument (Qlistp
, list
);
1605 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1606 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1607 The value is actually the first element of LIST whose cdr is KEY. */)
1609 register Lisp_Object key
;
1617 || (CONSP (XCAR (list
))
1618 && EQ (XCDR (XCAR (list
)), key
)))
1623 || (CONSP (XCAR (list
))
1624 && EQ (XCDR (XCAR (list
)), key
)))
1629 || (CONSP (XCAR (list
))
1630 && EQ (XCDR (XCAR (list
)), key
)))
1639 else if (CONSP (list
))
1640 result
= XCAR (list
);
1642 result
= wrong_type_argument (Qlistp
, list
);
1647 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1648 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1649 The value is actually the first element of LIST whose cdr equals KEY. */)
1651 Lisp_Object key
, list
;
1653 Lisp_Object result
, cdr
;
1658 || (CONSP (XCAR (list
))
1659 && (cdr
= XCDR (XCAR (list
)),
1660 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1665 || (CONSP (XCAR (list
))
1666 && (cdr
= XCDR (XCAR (list
)),
1667 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1672 || (CONSP (XCAR (list
))
1673 && (cdr
= XCDR (XCAR (list
)),
1674 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1682 result
= XCAR (list
);
1683 else if (NILP (list
))
1686 result
= wrong_type_argument (Qlistp
, list
);
1691 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1692 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1693 The modified LIST is returned. Comparison is done with `eq'.
1694 If the first member of LIST is ELT, there is no way to remove it by side effect;
1695 therefore, write `(setq foo (delq element foo))'
1696 to be sure of changing the value of `foo'. */)
1698 register Lisp_Object elt
;
1701 register Lisp_Object tail
, prev
;
1702 register Lisp_Object tem
;
1706 while (!NILP (tail
))
1709 wrong_type_argument (Qlistp
, list
);
1716 Fsetcdr (prev
, XCDR (tail
));
1726 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1727 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1728 SEQ must be a list, a vector, or a string.
1729 The modified SEQ is returned. Comparison is done with `equal'.
1730 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1731 is not a side effect; it is simply using a different sequence.
1732 Therefore, write `(setq foo (delete element foo))'
1733 to be sure of changing the value of `foo'. */)
1735 Lisp_Object elt
, seq
;
1741 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1742 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1745 if (n
!= ASIZE (seq
))
1747 struct Lisp_Vector
*p
= allocate_vector (n
);
1749 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1750 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1751 p
->contents
[n
++] = AREF (seq
, i
);
1753 XSETVECTOR (seq
, p
);
1756 else if (STRINGP (seq
))
1758 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1761 for (i
= nchars
= nbytes
= ibyte
= 0;
1763 ++i
, ibyte
+= cbytes
)
1765 if (STRING_MULTIBYTE (seq
))
1767 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1768 SBYTES (seq
) - ibyte
);
1769 cbytes
= CHAR_BYTES (c
);
1777 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1784 if (nchars
!= SCHARS (seq
))
1788 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1789 if (!STRING_MULTIBYTE (seq
))
1790 STRING_SET_UNIBYTE (tem
);
1792 for (i
= nchars
= nbytes
= ibyte
= 0;
1794 ++i
, ibyte
+= cbytes
)
1796 if (STRING_MULTIBYTE (seq
))
1798 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1799 SBYTES (seq
) - ibyte
);
1800 cbytes
= CHAR_BYTES (c
);
1808 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1810 unsigned char *from
= SDATA (seq
) + ibyte
;
1811 unsigned char *to
= SDATA (tem
) + nbytes
;
1817 for (n
= cbytes
; n
--; )
1827 Lisp_Object tail
, prev
;
1829 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1832 wrong_type_argument (Qlistp
, seq
);
1834 if (!NILP (Fequal (elt
, XCAR (tail
))))
1839 Fsetcdr (prev
, XCDR (tail
));
1850 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1851 doc
: /* Reverse LIST by modifying cdr pointers.
1852 Return the reversed list. */)
1856 register Lisp_Object prev
, tail
, next
;
1858 if (NILP (list
)) return list
;
1861 while (!NILP (tail
))
1865 wrong_type_argument (Qlistp
, list
);
1867 Fsetcdr (tail
, prev
);
1874 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1875 doc
: /* Reverse LIST, copying. Return the reversed list.
1876 See also the function `nreverse', which is used more often. */)
1882 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1885 new = Fcons (XCAR (list
), new);
1888 wrong_type_argument (Qconsp
, list
);
1892 Lisp_Object
merge ();
1894 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1895 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1896 Returns the sorted list. LIST is modified by side effects.
1897 PREDICATE is called with two elements of LIST, and should return t
1898 if the first element is "less" than the second. */)
1900 Lisp_Object list
, predicate
;
1902 Lisp_Object front
, back
;
1903 register Lisp_Object len
, tem
;
1904 struct gcpro gcpro1
, gcpro2
;
1905 register int length
;
1908 len
= Flength (list
);
1909 length
= XINT (len
);
1913 XSETINT (len
, (length
/ 2) - 1);
1914 tem
= Fnthcdr (len
, list
);
1916 Fsetcdr (tem
, Qnil
);
1918 GCPRO2 (front
, back
);
1919 front
= Fsort (front
, predicate
);
1920 back
= Fsort (back
, predicate
);
1922 return merge (front
, back
, predicate
);
1926 merge (org_l1
, org_l2
, pred
)
1927 Lisp_Object org_l1
, org_l2
;
1931 register Lisp_Object tail
;
1933 register Lisp_Object l1
, l2
;
1934 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1941 /* It is sufficient to protect org_l1 and org_l2.
1942 When l1 and l2 are updated, we copy the new values
1943 back into the org_ vars. */
1944 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1964 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1980 Fsetcdr (tail
, tem
);
1986 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1987 doc
: /* Extract a value from a property list.
1988 PLIST is a property list, which is a list of the form
1989 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1990 corresponding to the given PROP, or nil if PROP is not
1991 one of the properties on the list. */)
1999 CONSP (tail
) && CONSP (XCDR (tail
));
2000 tail
= XCDR (XCDR (tail
)))
2002 if (EQ (prop
, XCAR (tail
)))
2003 return XCAR (XCDR (tail
));
2005 /* This function can be called asynchronously
2006 (setup_coding_system). Don't QUIT in that case. */
2007 if (!interrupt_input_blocked
)
2012 wrong_type_argument (Qlistp
, prop
);
2017 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2018 doc
: /* Return the value of SYMBOL's PROPNAME property.
2019 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2021 Lisp_Object symbol
, propname
;
2023 CHECK_SYMBOL (symbol
);
2024 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2027 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2028 doc
: /* Change value in PLIST of PROP to VAL.
2029 PLIST is a property list, which is a list of the form
2030 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2031 If PROP is already a property on the list, its value is set to VAL,
2032 otherwise the new PROP VAL pair is added. The new plist is returned;
2033 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2034 The PLIST is modified by side effects. */)
2037 register Lisp_Object prop
;
2040 register Lisp_Object tail
, prev
;
2041 Lisp_Object newcell
;
2043 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2044 tail
= XCDR (XCDR (tail
)))
2046 if (EQ (prop
, XCAR (tail
)))
2048 Fsetcar (XCDR (tail
), val
);
2055 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2059 Fsetcdr (XCDR (prev
), newcell
);
2063 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2064 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2065 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2066 (symbol
, propname
, value
)
2067 Lisp_Object symbol
, propname
, value
;
2069 CHECK_SYMBOL (symbol
);
2070 XSYMBOL (symbol
)->plist
2071 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2075 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2076 doc
: /* Extract a value from a property list, comparing with `equal'.
2077 PLIST is a property list, which is a list of the form
2078 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2079 corresponding to the given PROP, or nil if PROP is not
2080 one of the properties on the list. */)
2088 CONSP (tail
) && CONSP (XCDR (tail
));
2089 tail
= XCDR (XCDR (tail
)))
2091 if (! NILP (Fequal (prop
, XCAR (tail
))))
2092 return XCAR (XCDR (tail
));
2098 wrong_type_argument (Qlistp
, prop
);
2103 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2104 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2105 PLIST is a property list, which is a list of the form
2106 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2107 If PROP is already a property on the list, its value is set to VAL,
2108 otherwise the new PROP VAL pair is added. The new plist is returned;
2109 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2110 The PLIST is modified by side effects. */)
2113 register Lisp_Object prop
;
2116 register Lisp_Object tail
, prev
;
2117 Lisp_Object newcell
;
2119 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2120 tail
= XCDR (XCDR (tail
)))
2122 if (! NILP (Fequal (prop
, XCAR (tail
))))
2124 Fsetcar (XCDR (tail
), val
);
2131 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2135 Fsetcdr (XCDR (prev
), newcell
);
2139 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2140 doc
: /* Return t if the two args are the same Lisp object.
2141 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2143 Lisp_Object obj1
, obj2
;
2146 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2148 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2151 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2152 doc
: /* Return t if two Lisp objects have similar structure and contents.
2153 They must have the same data type.
2154 Conses are compared by comparing the cars and the cdrs.
2155 Vectors and strings are compared element by element.
2156 Numbers are compared by value, but integers cannot equal floats.
2157 (Use `=' if you want integers and floats to be able to be equal.)
2158 Symbols must match exactly. */)
2160 register Lisp_Object o1
, o2
;
2162 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2165 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2166 doc
: /* Return t if two Lisp objects have similar structure and contents.
2167 This is like `equal' except that it compares the text properties
2168 of strings. (`equal' ignores text properties.) */)
2170 register Lisp_Object o1
, o2
;
2172 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2175 /* DEPTH is current depth of recursion. Signal an error if it
2177 PROPS, if non-nil, means compare string text properties too. */
2180 internal_equal (o1
, o2
, depth
, props
)
2181 register Lisp_Object o1
, o2
;
2185 error ("Stack overflow in equal");
2191 if (XTYPE (o1
) != XTYPE (o2
))
2200 d1
= extract_float (o1
);
2201 d2
= extract_float (o2
);
2202 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2203 though they are not =. */
2204 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2208 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2215 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2219 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2221 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2224 o1
= XOVERLAY (o1
)->plist
;
2225 o2
= XOVERLAY (o2
)->plist
;
2230 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2231 && (XMARKER (o1
)->buffer
== 0
2232 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2236 case Lisp_Vectorlike
:
2239 EMACS_INT size
= XVECTOR (o1
)->size
;
2240 /* Pseudovectors have the type encoded in the size field, so this test
2241 actually checks that the objects have the same type as well as the
2243 if (XVECTOR (o2
)->size
!= size
)
2245 /* Boolvectors are compared much like strings. */
2246 if (BOOL_VECTOR_P (o1
))
2249 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2250 / BOOL_VECTOR_BITS_PER_CHAR
);
2252 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2254 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2259 if (WINDOW_CONFIGURATIONP (o1
))
2260 return compare_window_configurations (o1
, o2
, 0);
2262 /* Aside from them, only true vectors, char-tables, and compiled
2263 functions are sensible to compare, so eliminate the others now. */
2264 if (size
& PSEUDOVECTOR_FLAG
)
2266 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2268 size
&= PSEUDOVECTOR_SIZE_MASK
;
2270 for (i
= 0; i
< size
; i
++)
2273 v1
= XVECTOR (o1
)->contents
[i
];
2274 v2
= XVECTOR (o2
)->contents
[i
];
2275 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2283 if (SCHARS (o1
) != SCHARS (o2
))
2285 if (SBYTES (o1
) != SBYTES (o2
))
2287 if (bcmp (SDATA (o1
), SDATA (o2
),
2290 if (props
&& !compare_string_intervals (o1
, o2
))
2296 case Lisp_Type_Limit
:
2303 extern Lisp_Object
Fmake_char_internal ();
2305 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2306 doc
: /* Store each element of ARRAY with ITEM.
2307 ARRAY is a vector, string, char-table, or bool-vector. */)
2309 Lisp_Object array
, item
;
2311 register int size
, index
, charval
;
2313 if (VECTORP (array
))
2315 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2316 size
= XVECTOR (array
)->size
;
2317 for (index
= 0; index
< size
; index
++)
2320 else if (CHAR_TABLE_P (array
))
2322 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2323 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2324 for (index
= 0; index
< size
; index
++)
2326 XCHAR_TABLE (array
)->defalt
= Qnil
;
2328 else if (STRINGP (array
))
2330 register unsigned char *p
= SDATA (array
);
2331 CHECK_NUMBER (item
);
2332 charval
= XINT (item
);
2333 size
= SCHARS (array
);
2334 if (STRING_MULTIBYTE (array
))
2336 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2337 int len
= CHAR_STRING (charval
, str
);
2338 int size_byte
= SBYTES (array
);
2339 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2342 if (size
!= size_byte
)
2345 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2346 if (len
!= this_len
)
2347 error ("Attempt to change byte length of a string");
2350 for (i
= 0; i
< size_byte
; i
++)
2351 *p
++ = str
[i
% len
];
2354 for (index
= 0; index
< size
; index
++)
2357 else if (BOOL_VECTOR_P (array
))
2359 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2361 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2362 / BOOL_VECTOR_BITS_PER_CHAR
);
2364 charval
= (! NILP (item
) ? -1 : 0);
2365 for (index
= 0; index
< size_in_chars
- 1; index
++)
2367 if (index
< size_in_chars
)
2369 /* Mask out bits beyond the vector size. */
2370 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2371 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2377 array
= wrong_type_argument (Qarrayp
, array
);
2383 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2385 doc
: /* Clear the contents of STRING.
2386 This makes STRING unibyte and may change its length. */)
2390 int len
= SBYTES (string
);
2391 bzero (SDATA (string
), len
);
2392 STRING_SET_CHARS (string
, len
);
2393 STRING_SET_UNIBYTE (string
);
2397 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2399 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2401 Lisp_Object char_table
;
2403 CHECK_CHAR_TABLE (char_table
);
2405 return XCHAR_TABLE (char_table
)->purpose
;
2408 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2410 doc
: /* Return the parent char-table of CHAR-TABLE.
2411 The value is either nil or another char-table.
2412 If CHAR-TABLE holds nil for a given character,
2413 then the actual applicable value is inherited from the parent char-table
2414 \(or from its parents, if necessary). */)
2416 Lisp_Object char_table
;
2418 CHECK_CHAR_TABLE (char_table
);
2420 return XCHAR_TABLE (char_table
)->parent
;
2423 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2425 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2426 Return PARENT. PARENT must be either nil or another char-table. */)
2427 (char_table
, parent
)
2428 Lisp_Object char_table
, parent
;
2432 CHECK_CHAR_TABLE (char_table
);
2436 CHECK_CHAR_TABLE (parent
);
2438 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2439 if (EQ (temp
, char_table
))
2440 error ("Attempt to make a chartable be its own parent");
2443 XCHAR_TABLE (char_table
)->parent
= parent
;
2448 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2450 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2452 Lisp_Object char_table
, n
;
2454 CHECK_CHAR_TABLE (char_table
);
2457 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2458 args_out_of_range (char_table
, n
);
2460 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2463 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2464 Sset_char_table_extra_slot
,
2466 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2467 (char_table
, n
, value
)
2468 Lisp_Object char_table
, n
, value
;
2470 CHECK_CHAR_TABLE (char_table
);
2473 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2474 args_out_of_range (char_table
, n
);
2476 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2479 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2481 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2482 RANGE should be nil (for the default value)
2483 a vector which identifies a character set or a row of a character set,
2484 a character set name, or a character code. */)
2486 Lisp_Object char_table
, range
;
2488 CHECK_CHAR_TABLE (char_table
);
2490 if (EQ (range
, Qnil
))
2491 return XCHAR_TABLE (char_table
)->defalt
;
2492 else if (INTEGERP (range
))
2493 return Faref (char_table
, range
);
2494 else if (SYMBOLP (range
))
2496 Lisp_Object charset_info
;
2498 charset_info
= Fget (range
, Qcharset
);
2499 CHECK_VECTOR (charset_info
);
2501 return Faref (char_table
,
2502 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2505 else if (VECTORP (range
))
2507 if (XVECTOR (range
)->size
== 1)
2508 return Faref (char_table
,
2509 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2512 int size
= XVECTOR (range
)->size
;
2513 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2514 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2515 size
<= 1 ? Qnil
: val
[1],
2516 size
<= 2 ? Qnil
: val
[2]);
2517 return Faref (char_table
, ch
);
2521 error ("Invalid RANGE argument to `char-table-range'");
2525 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2527 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2528 RANGE should be t (for all characters), nil (for the default value),
2529 a character set, a vector which identifies a character set, a row of a
2530 character set, or a character code. Return VALUE. */)
2531 (char_table
, range
, value
)
2532 Lisp_Object char_table
, range
, value
;
2536 CHECK_CHAR_TABLE (char_table
);
2539 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2540 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2541 else if (EQ (range
, Qnil
))
2542 XCHAR_TABLE (char_table
)->defalt
= value
;
2543 else if (SYMBOLP (range
))
2545 Lisp_Object charset_info
;
2548 charset_info
= Fget (range
, Qcharset
);
2549 if (! VECTORP (charset_info
)
2550 || ! NATNUMP (AREF (charset_info
, 0))
2551 || (charset_id
= XINT (AREF (charset_info
, 0)),
2552 ! CHARSET_DEFINED_P (charset_id
)))
2553 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2555 if (charset_id
== CHARSET_ASCII
)
2556 for (i
= 0; i
< 128; i
++)
2557 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2558 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2559 for (i
= 128; i
< 160; i
++)
2560 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2561 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2562 for (i
= 160; i
< 256; i
++)
2563 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2565 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2567 else if (INTEGERP (range
))
2568 Faset (char_table
, range
, value
);
2569 else if (VECTORP (range
))
2571 if (XVECTOR (range
)->size
== 1)
2572 return Faset (char_table
,
2573 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2577 int size
= XVECTOR (range
)->size
;
2578 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2579 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2580 size
<= 1 ? Qnil
: val
[1],
2581 size
<= 2 ? Qnil
: val
[2]);
2582 return Faset (char_table
, ch
, value
);
2586 error ("Invalid RANGE argument to `set-char-table-range'");
2591 DEFUN ("set-char-table-default", Fset_char_table_default
,
2592 Sset_char_table_default
, 3, 3, 0,
2593 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2594 The generic character specifies the group of characters.
2595 See also the documentation of `make-char'. */)
2596 (char_table
, ch
, value
)
2597 Lisp_Object char_table
, ch
, value
;
2599 int c
, charset
, code1
, code2
;
2602 CHECK_CHAR_TABLE (char_table
);
2606 SPLIT_CHAR (c
, charset
, code1
, code2
);
2608 /* Since we may want to set the default value for a character set
2609 not yet defined, we check only if the character set is in the
2610 valid range or not, instead of it is already defined or not. */
2611 if (! CHARSET_VALID_P (charset
))
2612 invalid_character (c
);
2614 if (charset
== CHARSET_ASCII
)
2615 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2617 /* Even if C is not a generic char, we had better behave as if a
2618 generic char is specified. */
2619 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2621 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2624 if (SUB_CHAR_TABLE_P (temp
))
2625 XCHAR_TABLE (temp
)->defalt
= value
;
2627 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2630 if (SUB_CHAR_TABLE_P (temp
))
2633 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2634 = make_sub_char_table (temp
));
2635 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2636 if (SUB_CHAR_TABLE_P (temp
))
2637 XCHAR_TABLE (temp
)->defalt
= value
;
2639 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2643 /* Look up the element in TABLE at index CH,
2644 and return it as an integer.
2645 If the element is nil, return CH itself.
2646 (Actually we do that for any non-integer.) */
2649 char_table_translate (table
, ch
)
2654 value
= Faref (table
, make_number (ch
));
2655 if (! INTEGERP (value
))
2657 return XINT (value
);
2661 optimize_sub_char_table (table
, chars
)
2669 from
= 33, to
= 127;
2671 from
= 32, to
= 128;
2673 if (!SUB_CHAR_TABLE_P (*table
))
2675 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2676 for (; from
< to
; from
++)
2677 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2682 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2683 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2691 CHECK_CHAR_TABLE (table
);
2693 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2695 elt
= XCHAR_TABLE (table
)->contents
[i
];
2696 if (!SUB_CHAR_TABLE_P (elt
))
2698 dim
= CHARSET_DIMENSION (i
- 128);
2700 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2701 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2702 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2708 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2709 character or group of characters that share a value.
2710 DEPTH is the current depth in the originally specified
2711 chartable, and INDICES contains the vector indices
2712 for the levels our callers have descended.
2714 ARG is passed to C_FUNCTION when that is called. */
2717 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2718 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2719 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2726 /* At first, handle ASCII and 8-bit European characters. */
2727 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2729 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2731 elt
= XCHAR_TABLE (subtable
)->defalt
;
2733 elt
= Faref (subtable
, make_number (i
));
2735 (*c_function
) (arg
, make_number (i
), elt
);
2737 call2 (function
, make_number (i
), elt
);
2739 #if 0 /* If the char table has entries for higher characters,
2740 we should report them. */
2741 if (NILP (current_buffer
->enable_multibyte_characters
))
2744 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2748 int charset
= XFASTINT (indices
[0]) - 128;
2751 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2752 if (CHARSET_CHARS (charset
) == 94)
2761 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2762 XSETFASTINT (indices
[depth
], i
);
2763 charset
= XFASTINT (indices
[0]) - 128;
2765 && (!CHARSET_DEFINED_P (charset
)
2766 || charset
== CHARSET_8_BIT_CONTROL
2767 || charset
== CHARSET_8_BIT_GRAPHIC
))
2770 if (SUB_CHAR_TABLE_P (elt
))
2773 error ("Too deep char table");
2774 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2780 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2781 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2782 c
= MAKE_CHAR (charset
, c1
, c2
);
2785 elt
= XCHAR_TABLE (subtable
)->defalt
;
2787 elt
= Faref (table
, make_number (c
));
2790 (*c_function
) (arg
, make_number (c
), elt
);
2792 call2 (function
, make_number (c
), elt
);
2797 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2799 void_call2 (a
, b
, c
)
2800 Lisp_Object a
, b
, c
;
2805 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2807 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2808 FUNCTION is called with two arguments--a key and a value.
2809 The key is always a possible IDX argument to `aref'. */)
2810 (function
, char_table
)
2811 Lisp_Object function
, char_table
;
2813 /* The depth of char table is at most 3. */
2814 Lisp_Object indices
[3];
2816 CHECK_CHAR_TABLE (char_table
);
2818 /* When Lisp_Object is represented as a union, `call2' cannot directly
2819 be passed to map_char_table because it returns a Lisp_Object rather
2820 than returning nothing.
2821 Casting leads to crashes on some architectures. -stef */
2822 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2826 /* Return a value for character C in char-table TABLE. Store the
2827 actual index for that value in *IDX. Ignore the default value of
2831 char_table_ref_and_index (table
, c
, idx
)
2835 int charset
, c1
, c2
;
2838 if (SINGLE_BYTE_CHAR_P (c
))
2841 return XCHAR_TABLE (table
)->contents
[c
];
2843 SPLIT_CHAR (c
, charset
, c1
, c2
);
2844 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2845 *idx
= MAKE_CHAR (charset
, 0, 0);
2846 if (!SUB_CHAR_TABLE_P (elt
))
2848 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2849 return XCHAR_TABLE (elt
)->defalt
;
2850 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2851 *idx
= MAKE_CHAR (charset
, c1
, 0);
2852 if (!SUB_CHAR_TABLE_P (elt
))
2854 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2855 return XCHAR_TABLE (elt
)->defalt
;
2857 return XCHAR_TABLE (elt
)->contents
[c2
];
2867 Lisp_Object args
[2];
2870 return Fnconc (2, args
);
2872 return Fnconc (2, &s1
);
2873 #endif /* NO_ARG_ARRAY */
2876 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2877 doc
: /* Concatenate any number of lists by altering them.
2878 Only the last argument is not altered, and need not be a list.
2879 usage: (nconc &rest LISTS) */)
2884 register int argnum
;
2885 register Lisp_Object tail
, tem
, val
;
2889 for (argnum
= 0; argnum
< nargs
; argnum
++)
2892 if (NILP (tem
)) continue;
2897 if (argnum
+ 1 == nargs
) break;
2900 tem
= wrong_type_argument (Qlistp
, tem
);
2909 tem
= args
[argnum
+ 1];
2910 Fsetcdr (tail
, tem
);
2912 args
[argnum
+ 1] = tail
;
2918 /* This is the guts of all mapping functions.
2919 Apply FN to each element of SEQ, one by one,
2920 storing the results into elements of VALS, a C vector of Lisp_Objects.
2921 LENI is the length of VALS, which should also be the length of SEQ. */
2924 mapcar1 (leni
, vals
, fn
, seq
)
2927 Lisp_Object fn
, seq
;
2929 register Lisp_Object tail
;
2932 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2936 /* Don't let vals contain any garbage when GC happens. */
2937 for (i
= 0; i
< leni
; i
++)
2940 GCPRO3 (dummy
, fn
, seq
);
2942 gcpro1
.nvars
= leni
;
2946 /* We need not explicitly protect `tail' because it is used only on lists, and
2947 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2951 for (i
= 0; i
< leni
; i
++)
2953 dummy
= XVECTOR (seq
)->contents
[i
];
2954 dummy
= call1 (fn
, dummy
);
2959 else if (BOOL_VECTOR_P (seq
))
2961 for (i
= 0; i
< leni
; i
++)
2964 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
2965 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
2970 dummy
= call1 (fn
, dummy
);
2975 else if (STRINGP (seq
))
2979 for (i
= 0, i_byte
= 0; i
< leni
;)
2984 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2985 XSETFASTINT (dummy
, c
);
2986 dummy
= call1 (fn
, dummy
);
2988 vals
[i_before
] = dummy
;
2991 else /* Must be a list, since Flength did not get an error */
2994 for (i
= 0; i
< leni
; i
++)
2996 dummy
= call1 (fn
, Fcar (tail
));
3006 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3007 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3008 In between each pair of results, stick in SEPARATOR. Thus, " " as
3009 SEPARATOR results in spaces between the values returned by FUNCTION.
3010 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3011 (function
, sequence
, separator
)
3012 Lisp_Object function
, sequence
, separator
;
3017 register Lisp_Object
*args
;
3019 struct gcpro gcpro1
;
3021 len
= Flength (sequence
);
3023 nargs
= leni
+ leni
- 1;
3024 if (nargs
< 0) return build_string ("");
3026 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
3029 mapcar1 (leni
, args
, function
, sequence
);
3032 for (i
= leni
- 1; i
>= 0; i
--)
3033 args
[i
+ i
] = args
[i
];
3035 for (i
= 1; i
< nargs
; i
+= 2)
3036 args
[i
] = separator
;
3038 return Fconcat (nargs
, args
);
3041 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3042 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3043 The result is a list just as long as SEQUENCE.
3044 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3045 (function
, sequence
)
3046 Lisp_Object function
, sequence
;
3048 register Lisp_Object len
;
3050 register Lisp_Object
*args
;
3052 len
= Flength (sequence
);
3053 leni
= XFASTINT (len
);
3054 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
3056 mapcar1 (leni
, args
, function
, sequence
);
3058 return Flist (leni
, args
);
3061 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3062 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3063 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3064 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3065 (function
, sequence
)
3066 Lisp_Object function
, sequence
;
3070 leni
= XFASTINT (Flength (sequence
));
3071 mapcar1 (leni
, 0, function
, sequence
);
3076 /* Anything that calls this function must protect from GC! */
3078 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3079 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3080 Takes one argument, which is the string to display to ask the question.
3081 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3082 No confirmation of the answer is requested; a single character is enough.
3083 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3084 the bindings in `query-replace-map'; see the documentation of that variable
3085 for more information. In this case, the useful bindings are `act', `skip',
3086 `recenter', and `quit'.\)
3088 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3089 is nil and `use-dialog-box' is non-nil. */)
3093 register Lisp_Object obj
, key
, def
, map
;
3094 register int answer
;
3095 Lisp_Object xprompt
;
3096 Lisp_Object args
[2];
3097 struct gcpro gcpro1
, gcpro2
;
3098 int count
= SPECPDL_INDEX ();
3100 specbind (Qcursor_in_echo_area
, Qt
);
3102 map
= Fsymbol_value (intern ("query-replace-map"));
3104 CHECK_STRING (prompt
);
3106 GCPRO2 (prompt
, xprompt
);
3108 #ifdef HAVE_X_WINDOWS
3109 if (display_hourglass_p
)
3110 cancel_hourglass ();
3117 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3121 Lisp_Object pane
, menu
;
3122 redisplay_preserve_echo_area (3);
3123 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3124 Fcons (Fcons (build_string ("No"), Qnil
),
3126 menu
= Fcons (prompt
, pane
);
3127 obj
= Fx_popup_dialog (Qt
, menu
);
3128 answer
= !NILP (obj
);
3131 #endif /* HAVE_MENUS */
3132 cursor_in_echo_area
= 1;
3133 choose_minibuf_frame ();
3136 Lisp_Object pargs
[3];
3138 /* Colorize prompt according to `minibuffer-prompt' face. */
3139 pargs
[0] = build_string ("%s(y or n) ");
3140 pargs
[1] = intern ("face");
3141 pargs
[2] = intern ("minibuffer-prompt");
3142 args
[0] = Fpropertize (3, pargs
);
3147 if (minibuffer_auto_raise
)
3149 Lisp_Object mini_frame
;
3151 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3153 Fraise_frame (mini_frame
);
3156 obj
= read_filtered_event (1, 0, 0, 0);
3157 cursor_in_echo_area
= 0;
3158 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3161 key
= Fmake_vector (make_number (1), obj
);
3162 def
= Flookup_key (map
, key
, Qt
);
3164 if (EQ (def
, intern ("skip")))
3169 else if (EQ (def
, intern ("act")))
3174 else if (EQ (def
, intern ("recenter")))
3180 else if (EQ (def
, intern ("quit")))
3182 /* We want to exit this command for exit-prefix,
3183 and this is the only way to do it. */
3184 else if (EQ (def
, intern ("exit-prefix")))
3189 /* If we don't clear this, then the next call to read_char will
3190 return quit_char again, and we'll enter an infinite loop. */
3195 if (EQ (xprompt
, prompt
))
3197 args
[0] = build_string ("Please answer y or n. ");
3199 xprompt
= Fconcat (2, args
);
3204 if (! noninteractive
)
3206 cursor_in_echo_area
= -1;
3207 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3211 unbind_to (count
, Qnil
);
3212 return answer
? Qt
: Qnil
;
3215 /* This is how C code calls `yes-or-no-p' and allows the user
3218 Anything that calls this function must protect from GC! */
3221 do_yes_or_no_p (prompt
)
3224 return call1 (intern ("yes-or-no-p"), prompt
);
3227 /* Anything that calls this function must protect from GC! */
3229 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3230 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3231 Takes one argument, which is the string to display to ask the question.
3232 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3233 The user must confirm the answer with RET,
3234 and can edit it until it has been confirmed.
3236 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3237 is nil, and `use-dialog-box' is non-nil. */)
3241 register Lisp_Object ans
;
3242 Lisp_Object args
[2];
3243 struct gcpro gcpro1
;
3245 CHECK_STRING (prompt
);
3248 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3252 Lisp_Object pane
, menu
, obj
;
3253 redisplay_preserve_echo_area (4);
3254 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3255 Fcons (Fcons (build_string ("No"), Qnil
),
3258 menu
= Fcons (prompt
, pane
);
3259 obj
= Fx_popup_dialog (Qt
, menu
);
3263 #endif /* HAVE_MENUS */
3266 args
[1] = build_string ("(yes or no) ");
3267 prompt
= Fconcat (2, args
);
3273 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3274 Qyes_or_no_p_history
, Qnil
,
3276 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3281 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3289 message ("Please answer yes or no.");
3290 Fsleep_for (make_number (2), Qnil
);
3294 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3295 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3297 Each of the three load averages is multiplied by 100, then converted
3300 When USE-FLOATS is non-nil, floats will be used instead of integers.
3301 These floats are not multiplied by 100.
3303 If the 5-minute or 15-minute load averages are not available, return a
3304 shortened list, containing only those averages which are available.
3306 An error is thrown if the load average can't be obtained. In some
3307 cases making it work would require Emacs being installed setuid or
3308 setgid so that it can read kernel information, and that usually isn't
3311 Lisp_Object use_floats
;
3314 int loads
= getloadavg (load_ave
, 3);
3315 Lisp_Object ret
= Qnil
;
3318 error ("load-average not implemented for this operating system");
3322 Lisp_Object load
= (NILP (use_floats
) ?
3323 make_number ((int) (100.0 * load_ave
[loads
]))
3324 : make_float (load_ave
[loads
]));
3325 ret
= Fcons (load
, ret
);
3331 Lisp_Object Vfeatures
, Qsubfeatures
;
3332 extern Lisp_Object Vafter_load_alist
;
3334 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3335 doc
: /* Returns t if FEATURE is present in this Emacs.
3337 Use this to conditionalize execution of lisp code based on the
3338 presence or absence of emacs or environment extensions.
3339 Use `provide' to declare that a feature is available. This function
3340 looks at the value of the variable `features'. The optional argument
3341 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3342 (feature
, subfeature
)
3343 Lisp_Object feature
, subfeature
;
3345 register Lisp_Object tem
;
3346 CHECK_SYMBOL (feature
);
3347 tem
= Fmemq (feature
, Vfeatures
);
3348 if (!NILP (tem
) && !NILP (subfeature
))
3349 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3350 return (NILP (tem
)) ? Qnil
: Qt
;
3353 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3354 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3355 The optional argument SUBFEATURES should be a list of symbols listing
3356 particular subfeatures supported in this version of FEATURE. */)
3357 (feature
, subfeatures
)
3358 Lisp_Object feature
, subfeatures
;
3360 register Lisp_Object tem
;
3361 CHECK_SYMBOL (feature
);
3362 CHECK_LIST (subfeatures
);
3363 if (!NILP (Vautoload_queue
))
3364 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3365 tem
= Fmemq (feature
, Vfeatures
);
3367 Vfeatures
= Fcons (feature
, Vfeatures
);
3368 if (!NILP (subfeatures
))
3369 Fput (feature
, Qsubfeatures
, subfeatures
);
3370 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3372 /* Run any load-hooks for this file. */
3373 tem
= Fassq (feature
, Vafter_load_alist
);
3375 Fprogn (XCDR (tem
));
3380 /* `require' and its subroutines. */
3382 /* List of features currently being require'd, innermost first. */
3384 Lisp_Object require_nesting_list
;
3387 require_unwind (old_value
)
3388 Lisp_Object old_value
;
3390 return require_nesting_list
= old_value
;
3393 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3394 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3395 If FEATURE is not a member of the list `features', then the feature
3396 is not loaded; so load the file FILENAME.
3397 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3398 and `load' will try to load this name appended with the suffix `.elc' or
3399 `.el', in that order. The name without appended suffix will not be used.
3400 If the optional third argument NOERROR is non-nil,
3401 then return nil if the file is not found instead of signaling an error.
3402 Normally the return value is FEATURE.
3403 The normal messages at start and end of loading FILENAME are suppressed. */)
3404 (feature
, filename
, noerror
)
3405 Lisp_Object feature
, filename
, noerror
;
3407 register Lisp_Object tem
;
3408 struct gcpro gcpro1
, gcpro2
;
3410 CHECK_SYMBOL (feature
);
3412 tem
= Fmemq (feature
, Vfeatures
);
3416 int count
= SPECPDL_INDEX ();
3419 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3421 /* This is to make sure that loadup.el gives a clear picture
3422 of what files are preloaded and when. */
3423 if (! NILP (Vpurify_flag
))
3424 error ("(require %s) while preparing to dump",
3425 SDATA (SYMBOL_NAME (feature
)));
3427 /* A certain amount of recursive `require' is legitimate,
3428 but if we require the same feature recursively 3 times,
3430 tem
= require_nesting_list
;
3431 while (! NILP (tem
))
3433 if (! NILP (Fequal (feature
, XCAR (tem
))))
3438 error ("Recursive `require' for feature `%s'",
3439 SDATA (SYMBOL_NAME (feature
)));
3441 /* Update the list for any nested `require's that occur. */
3442 record_unwind_protect (require_unwind
, require_nesting_list
);
3443 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3445 /* Value saved here is to be restored into Vautoload_queue */
3446 record_unwind_protect (un_autoload
, Vautoload_queue
);
3447 Vautoload_queue
= Qt
;
3449 /* Load the file. */
3450 GCPRO2 (feature
, filename
);
3451 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3452 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3455 /* If load failed entirely, return nil. */
3457 return unbind_to (count
, Qnil
);
3459 tem
= Fmemq (feature
, Vfeatures
);
3461 error ("Required feature `%s' was not provided",
3462 SDATA (SYMBOL_NAME (feature
)));
3464 /* Once loading finishes, don't undo it. */
3465 Vautoload_queue
= Qt
;
3466 feature
= unbind_to (count
, feature
);
3472 /* Primitives for work of the "widget" library.
3473 In an ideal world, this section would not have been necessary.
3474 However, lisp function calls being as slow as they are, it turns
3475 out that some functions in the widget library (wid-edit.el) are the
3476 bottleneck of Widget operation. Here is their translation to C,
3477 for the sole reason of efficiency. */
3479 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3480 doc
: /* Return non-nil if PLIST has the property PROP.
3481 PLIST is a property list, which is a list of the form
3482 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3483 Unlike `plist-get', this allows you to distinguish between a missing
3484 property and a property with the value nil.
3485 The value is actually the tail of PLIST whose car is PROP. */)
3487 Lisp_Object plist
, prop
;
3489 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3492 plist
= XCDR (plist
);
3493 plist
= CDR (plist
);
3498 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3499 doc
: /* In WIDGET, set PROPERTY to VALUE.
3500 The value can later be retrieved with `widget-get'. */)
3501 (widget
, property
, value
)
3502 Lisp_Object widget
, property
, value
;
3504 CHECK_CONS (widget
);
3505 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3509 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3510 doc
: /* In WIDGET, get the value of PROPERTY.
3511 The value could either be specified when the widget was created, or
3512 later with `widget-put'. */)
3514 Lisp_Object widget
, property
;
3522 CHECK_CONS (widget
);
3523 tmp
= Fplist_member (XCDR (widget
), property
);
3529 tmp
= XCAR (widget
);
3532 widget
= Fget (tmp
, Qwidget_type
);
3536 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3537 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3538 ARGS are passed as extra arguments to the function.
3539 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3544 /* This function can GC. */
3545 Lisp_Object newargs
[3];
3546 struct gcpro gcpro1
, gcpro2
;
3549 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3550 newargs
[1] = args
[0];
3551 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3552 GCPRO2 (newargs
[0], newargs
[2]);
3553 result
= Fapply (3, newargs
);
3558 #ifdef HAVE_LANGINFO_CODESET
3559 #include <langinfo.h>
3562 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3563 doc
: /* Access locale data ITEM for the current C locale, if available.
3564 ITEM should be one of the following:
3566 `codeset', returning the character set as a string (locale item CODESET);
3568 `days', returning a 7-element vector of day names (locale items DAY_n);
3570 `months', returning a 12-element vector of month names (locale items MON_n);
3572 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3573 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3575 If the system can't provide such information through a call to
3576 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3578 See also Info node `(libc)Locales'.
3580 The data read from the system are decoded using `locale-coding-system'. */)
3585 #ifdef HAVE_LANGINFO_CODESET
3587 if (EQ (item
, Qcodeset
))
3589 str
= nl_langinfo (CODESET
);
3590 return build_string (str
);
3593 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3595 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3596 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3598 synchronize_system_time_locale ();
3599 for (i
= 0; i
< 7; i
++)
3601 str
= nl_langinfo (days
[i
]);
3602 val
= make_unibyte_string (str
, strlen (str
));
3603 /* Fixme: Is this coding system necessarily right, even if
3604 it is consistent with CODESET? If not, what to do? */
3605 Faset (v
, make_number (i
),
3606 code_convert_string_norecord (val
, Vlocale_coding_system
,
3613 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3615 struct Lisp_Vector
*p
= allocate_vector (12);
3616 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3617 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3619 synchronize_system_time_locale ();
3620 for (i
= 0; i
< 12; i
++)
3622 str
= nl_langinfo (months
[i
]);
3623 val
= make_unibyte_string (str
, strlen (str
));
3625 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3627 XSETVECTOR (val
, p
);
3631 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3632 but is in the locale files. This could be used by ps-print. */
3634 else if (EQ (item
, Qpaper
))
3636 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3637 make_number (nl_langinfo (PAPER_HEIGHT
)));
3639 #endif /* PAPER_WIDTH */
3640 #endif /* HAVE_LANGINFO_CODESET*/
3644 /* base64 encode/decode functions (RFC 2045).
3645 Based on code from GNU recode. */
3647 #define MIME_LINE_LENGTH 76
3649 #define IS_ASCII(Character) \
3651 #define IS_BASE64(Character) \
3652 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3653 #define IS_BASE64_IGNORABLE(Character) \
3654 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3655 || (Character) == '\f' || (Character) == '\r')
3657 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3658 character or return retval if there are no characters left to
3660 #define READ_QUADRUPLET_BYTE(retval) \
3665 if (nchars_return) \
3666 *nchars_return = nchars; \
3671 while (IS_BASE64_IGNORABLE (c))
3673 /* Don't use alloca for regions larger than this, lest we overflow
3675 #define MAX_ALLOCA 16*1024
3677 /* Table of characters coding the 64 values. */
3678 static char base64_value_to_char
[64] =
3680 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3681 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3682 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3683 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3684 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3685 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3686 '8', '9', '+', '/' /* 60-63 */
3689 /* Table of base64 values for first 128 characters. */
3690 static short base64_char_to_value
[128] =
3692 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3693 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3694 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3695 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3696 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3697 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3698 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3699 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3700 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3701 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3702 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3703 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3704 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3707 /* The following diagram shows the logical steps by which three octets
3708 get transformed into four base64 characters.
3710 .--------. .--------. .--------.
3711 |aaaaaabb| |bbbbcccc| |ccdddddd|
3712 `--------' `--------' `--------'
3714 .--------+--------+--------+--------.
3715 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3716 `--------+--------+--------+--------'
3718 .--------+--------+--------+--------.
3719 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3720 `--------+--------+--------+--------'
3722 The octets are divided into 6 bit chunks, which are then encoded into
3723 base64 characters. */
3726 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3727 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3729 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3731 doc
: /* Base64-encode the region between BEG and END.
3732 Return the length of the encoded text.
3733 Optional third argument NO-LINE-BREAK means do not break long lines
3734 into shorter lines. */)
3735 (beg
, end
, no_line_break
)
3736 Lisp_Object beg
, end
, no_line_break
;
3739 int allength
, length
;
3740 int ibeg
, iend
, encoded_length
;
3743 validate_region (&beg
, &end
);
3745 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3746 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3747 move_gap_both (XFASTINT (beg
), ibeg
);
3749 /* We need to allocate enough room for encoding the text.
3750 We need 33 1/3% more space, plus a newline every 76
3751 characters, and then we round up. */
3752 length
= iend
- ibeg
;
3753 allength
= length
+ length
/3 + 1;
3754 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3756 if (allength
<= MAX_ALLOCA
)
3757 encoded
= (char *) alloca (allength
);
3759 encoded
= (char *) xmalloc (allength
);
3760 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3761 NILP (no_line_break
),
3762 !NILP (current_buffer
->enable_multibyte_characters
));
3763 if (encoded_length
> allength
)
3766 if (encoded_length
< 0)
3768 /* The encoding wasn't possible. */
3769 if (length
> MAX_ALLOCA
)
3771 error ("Multibyte character in data for base64 encoding");
3774 /* Now we have encoded the region, so we insert the new contents
3775 and delete the old. (Insert first in order to preserve markers.) */
3776 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3777 insert (encoded
, encoded_length
);
3778 if (allength
> MAX_ALLOCA
)
3780 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3782 /* If point was outside of the region, restore it exactly; else just
3783 move to the beginning of the region. */
3784 if (old_pos
>= XFASTINT (end
))
3785 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3786 else if (old_pos
> XFASTINT (beg
))
3787 old_pos
= XFASTINT (beg
);
3790 /* We return the length of the encoded text. */
3791 return make_number (encoded_length
);
3794 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3796 doc
: /* Base64-encode STRING and return the result.
3797 Optional second argument NO-LINE-BREAK means do not break long lines
3798 into shorter lines. */)
3799 (string
, no_line_break
)
3800 Lisp_Object string
, no_line_break
;
3802 int allength
, length
, encoded_length
;
3804 Lisp_Object encoded_string
;
3806 CHECK_STRING (string
);
3808 /* We need to allocate enough room for encoding the text.
3809 We need 33 1/3% more space, plus a newline every 76
3810 characters, and then we round up. */
3811 length
= SBYTES (string
);
3812 allength
= length
+ length
/3 + 1;
3813 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3815 /* We need to allocate enough room for decoding the text. */
3816 if (allength
<= MAX_ALLOCA
)
3817 encoded
= (char *) alloca (allength
);
3819 encoded
= (char *) xmalloc (allength
);
3821 encoded_length
= base64_encode_1 (SDATA (string
),
3822 encoded
, length
, NILP (no_line_break
),
3823 STRING_MULTIBYTE (string
));
3824 if (encoded_length
> allength
)
3827 if (encoded_length
< 0)
3829 /* The encoding wasn't possible. */
3830 if (length
> MAX_ALLOCA
)
3832 error ("Multibyte character in data for base64 encoding");
3835 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3836 if (allength
> MAX_ALLOCA
)
3839 return encoded_string
;
3843 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3850 int counter
= 0, i
= 0;
3860 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3868 /* Wrap line every 76 characters. */
3872 if (counter
< MIME_LINE_LENGTH
/ 4)
3881 /* Process first byte of a triplet. */
3883 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3884 value
= (0x03 & c
) << 4;
3886 /* Process second byte of a triplet. */
3890 *e
++ = base64_value_to_char
[value
];
3898 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3906 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3907 value
= (0x0f & c
) << 2;
3909 /* Process third byte of a triplet. */
3913 *e
++ = base64_value_to_char
[value
];
3920 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3928 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3929 *e
++ = base64_value_to_char
[0x3f & c
];
3936 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3938 doc
: /* Base64-decode the region between BEG and END.
3939 Return the length of the decoded text.
3940 If the region can't be decoded, signal an error and don't modify the buffer. */)
3942 Lisp_Object beg
, end
;
3944 int ibeg
, iend
, length
, allength
;
3949 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3951 validate_region (&beg
, &end
);
3953 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3954 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3956 length
= iend
- ibeg
;
3958 /* We need to allocate enough room for decoding the text. If we are
3959 working on a multibyte buffer, each decoded code may occupy at
3961 allength
= multibyte
? length
* 2 : length
;
3962 if (allength
<= MAX_ALLOCA
)
3963 decoded
= (char *) alloca (allength
);
3965 decoded
= (char *) xmalloc (allength
);
3967 move_gap_both (XFASTINT (beg
), ibeg
);
3968 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3969 multibyte
, &inserted_chars
);
3970 if (decoded_length
> allength
)
3973 if (decoded_length
< 0)
3975 /* The decoding wasn't possible. */
3976 if (allength
> MAX_ALLOCA
)
3978 error ("Invalid base64 data");
3981 /* Now we have decoded the region, so we insert the new contents
3982 and delete the old. (Insert first in order to preserve markers.) */
3983 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3984 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3985 if (allength
> MAX_ALLOCA
)
3987 /* Delete the original text. */
3988 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3989 iend
+ decoded_length
, 1);
3991 /* If point was outside of the region, restore it exactly; else just
3992 move to the beginning of the region. */
3993 if (old_pos
>= XFASTINT (end
))
3994 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3995 else if (old_pos
> XFASTINT (beg
))
3996 old_pos
= XFASTINT (beg
);
3997 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3999 return make_number (inserted_chars
);
4002 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4004 doc
: /* Base64-decode STRING and return the result. */)
4009 int length
, decoded_length
;
4010 Lisp_Object decoded_string
;
4012 CHECK_STRING (string
);
4014 length
= SBYTES (string
);
4015 /* We need to allocate enough room for decoding the text. */
4016 if (length
<= MAX_ALLOCA
)
4017 decoded
= (char *) alloca (length
);
4019 decoded
= (char *) xmalloc (length
);
4021 /* The decoded result should be unibyte. */
4022 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4024 if (decoded_length
> length
)
4026 else if (decoded_length
>= 0)
4027 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4029 decoded_string
= Qnil
;
4031 if (length
> MAX_ALLOCA
)
4033 if (!STRINGP (decoded_string
))
4034 error ("Invalid base64 data");
4036 return decoded_string
;
4039 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4040 MULTIBYTE is nonzero, the decoded result should be in multibyte
4041 form. If NCHARS_RETRUN is not NULL, store the number of produced
4042 characters in *NCHARS_RETURN. */
4045 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4055 unsigned long value
;
4060 /* Process first byte of a quadruplet. */
4062 READ_QUADRUPLET_BYTE (e
-to
);
4066 value
= base64_char_to_value
[c
] << 18;
4068 /* Process second byte of a quadruplet. */
4070 READ_QUADRUPLET_BYTE (-1);
4074 value
|= base64_char_to_value
[c
] << 12;
4076 c
= (unsigned char) (value
>> 16);
4078 e
+= CHAR_STRING (c
, e
);
4083 /* Process third byte of a quadruplet. */
4085 READ_QUADRUPLET_BYTE (-1);
4089 READ_QUADRUPLET_BYTE (-1);
4098 value
|= base64_char_to_value
[c
] << 6;
4100 c
= (unsigned char) (0xff & value
>> 8);
4102 e
+= CHAR_STRING (c
, e
);
4107 /* Process fourth byte of a quadruplet. */
4109 READ_QUADRUPLET_BYTE (-1);
4116 value
|= base64_char_to_value
[c
];
4118 c
= (unsigned char) (0xff & value
);
4120 e
+= CHAR_STRING (c
, e
);
4129 /***********************************************************************
4131 ***** Hash Tables *****
4133 ***********************************************************************/
4135 /* Implemented by gerd@gnu.org. This hash table implementation was
4136 inspired by CMUCL hash tables. */
4140 1. For small tables, association lists are probably faster than
4141 hash tables because they have lower overhead.
4143 For uses of hash tables where the O(1) behavior of table
4144 operations is not a requirement, it might therefore be a good idea
4145 not to hash. Instead, we could just do a linear search in the
4146 key_and_value vector of the hash table. This could be done
4147 if a `:linear-search t' argument is given to make-hash-table. */
4150 /* The list of all weak hash tables. Don't staticpro this one. */
4152 Lisp_Object Vweak_hash_tables
;
4154 /* Various symbols. */
4156 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4157 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4158 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4160 /* Function prototypes. */
4162 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4163 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4164 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4165 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4166 Lisp_Object
, unsigned));
4167 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4168 Lisp_Object
, unsigned));
4169 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4170 unsigned, Lisp_Object
, unsigned));
4171 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4172 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4173 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4174 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4176 static unsigned sxhash_string
P_ ((unsigned char *, int));
4177 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4178 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4179 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4180 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4184 /***********************************************************************
4186 ***********************************************************************/
4188 /* If OBJ is a Lisp hash table, return a pointer to its struct
4189 Lisp_Hash_Table. Otherwise, signal an error. */
4191 static struct Lisp_Hash_Table
*
4192 check_hash_table (obj
)
4195 CHECK_HASH_TABLE (obj
);
4196 return XHASH_TABLE (obj
);
4200 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4204 next_almost_prime (n
)
4217 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4218 which USED[I] is non-zero. If found at index I in ARGS, set
4219 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4220 -1. This function is used to extract a keyword/argument pair from
4221 a DEFUN parameter list. */
4224 get_key_arg (key
, nargs
, args
, used
)
4232 for (i
= 0; i
< nargs
- 1; ++i
)
4233 if (!used
[i
] && EQ (args
[i
], key
))
4248 /* Return a Lisp vector which has the same contents as VEC but has
4249 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4250 vector that are not copied from VEC are set to INIT. */
4253 larger_vector (vec
, new_size
, init
)
4258 struct Lisp_Vector
*v
;
4261 xassert (VECTORP (vec
));
4262 old_size
= XVECTOR (vec
)->size
;
4263 xassert (new_size
>= old_size
);
4265 v
= allocate_vector (new_size
);
4266 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4267 old_size
* sizeof *v
->contents
);
4268 for (i
= old_size
; i
< new_size
; ++i
)
4269 v
->contents
[i
] = init
;
4270 XSETVECTOR (vec
, v
);
4275 /***********************************************************************
4277 ***********************************************************************/
4279 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4280 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4281 KEY2 are the same. */
4284 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4285 struct Lisp_Hash_Table
*h
;
4286 Lisp_Object key1
, key2
;
4287 unsigned hash1
, hash2
;
4289 return (FLOATP (key1
)
4291 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4295 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4296 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4297 KEY2 are the same. */
4300 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4301 struct Lisp_Hash_Table
*h
;
4302 Lisp_Object key1
, key2
;
4303 unsigned hash1
, hash2
;
4305 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4309 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4310 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4311 if KEY1 and KEY2 are the same. */
4314 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4315 struct Lisp_Hash_Table
*h
;
4316 Lisp_Object key1
, key2
;
4317 unsigned hash1
, hash2
;
4321 Lisp_Object args
[3];
4323 args
[0] = h
->user_cmp_function
;
4326 return !NILP (Ffuncall (3, args
));
4333 /* Value is a hash code for KEY for use in hash table H which uses
4334 `eq' to compare keys. The hash code returned is guaranteed to fit
4335 in a Lisp integer. */
4339 struct Lisp_Hash_Table
*h
;
4342 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4343 xassert ((hash
& ~INTMASK
) == 0);
4348 /* Value is a hash code for KEY for use in hash table H which uses
4349 `eql' to compare keys. The hash code returned is guaranteed to fit
4350 in a Lisp integer. */
4354 struct Lisp_Hash_Table
*h
;
4359 hash
= sxhash (key
, 0);
4361 hash
= XUINT (key
) ^ XGCTYPE (key
);
4362 xassert ((hash
& ~INTMASK
) == 0);
4367 /* Value is a hash code for KEY for use in hash table H which uses
4368 `equal' to compare keys. The hash code returned is guaranteed to fit
4369 in a Lisp integer. */
4372 hashfn_equal (h
, key
)
4373 struct Lisp_Hash_Table
*h
;
4376 unsigned hash
= sxhash (key
, 0);
4377 xassert ((hash
& ~INTMASK
) == 0);
4382 /* Value is a hash code for KEY for use in hash table H which uses as
4383 user-defined function to compare keys. The hash code returned is
4384 guaranteed to fit in a Lisp integer. */
4387 hashfn_user_defined (h
, key
)
4388 struct Lisp_Hash_Table
*h
;
4391 Lisp_Object args
[2], hash
;
4393 args
[0] = h
->user_hash_function
;
4395 hash
= Ffuncall (2, args
);
4396 if (!INTEGERP (hash
))
4398 list2 (build_string ("Invalid hash code returned from \
4399 user-supplied hash function"),
4401 return XUINT (hash
);
4405 /* Create and initialize a new hash table.
4407 TEST specifies the test the hash table will use to compare keys.
4408 It must be either one of the predefined tests `eq', `eql' or
4409 `equal' or a symbol denoting a user-defined test named TEST with
4410 test and hash functions USER_TEST and USER_HASH.
4412 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4414 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4415 new size when it becomes full is computed by adding REHASH_SIZE to
4416 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4417 table's new size is computed by multiplying its old size with
4420 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4421 be resized when the ratio of (number of entries in the table) /
4422 (table size) is >= REHASH_THRESHOLD.
4424 WEAK specifies the weakness of the table. If non-nil, it must be
4425 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4428 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4429 user_test
, user_hash
)
4430 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4431 Lisp_Object user_test
, user_hash
;
4433 struct Lisp_Hash_Table
*h
;
4435 int index_size
, i
, sz
;
4437 /* Preconditions. */
4438 xassert (SYMBOLP (test
));
4439 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4440 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4441 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4442 xassert (FLOATP (rehash_threshold
)
4443 && XFLOATINT (rehash_threshold
) > 0
4444 && XFLOATINT (rehash_threshold
) <= 1.0);
4446 if (XFASTINT (size
) == 0)
4447 size
= make_number (1);
4449 /* Allocate a table and initialize it. */
4450 h
= allocate_hash_table ();
4452 /* Initialize hash table slots. */
4453 sz
= XFASTINT (size
);
4456 if (EQ (test
, Qeql
))
4458 h
->cmpfn
= cmpfn_eql
;
4459 h
->hashfn
= hashfn_eql
;
4461 else if (EQ (test
, Qeq
))
4464 h
->hashfn
= hashfn_eq
;
4466 else if (EQ (test
, Qequal
))
4468 h
->cmpfn
= cmpfn_equal
;
4469 h
->hashfn
= hashfn_equal
;
4473 h
->user_cmp_function
= user_test
;
4474 h
->user_hash_function
= user_hash
;
4475 h
->cmpfn
= cmpfn_user_defined
;
4476 h
->hashfn
= hashfn_user_defined
;
4480 h
->rehash_threshold
= rehash_threshold
;
4481 h
->rehash_size
= rehash_size
;
4482 h
->count
= make_number (0);
4483 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4484 h
->hash
= Fmake_vector (size
, Qnil
);
4485 h
->next
= Fmake_vector (size
, Qnil
);
4486 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4487 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4488 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4490 /* Set up the free list. */
4491 for (i
= 0; i
< sz
- 1; ++i
)
4492 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4493 h
->next_free
= make_number (0);
4495 XSET_HASH_TABLE (table
, h
);
4496 xassert (HASH_TABLE_P (table
));
4497 xassert (XHASH_TABLE (table
) == h
);
4499 /* Maybe add this hash table to the list of all weak hash tables. */
4501 h
->next_weak
= Qnil
;
4504 h
->next_weak
= Vweak_hash_tables
;
4505 Vweak_hash_tables
= table
;
4512 /* Return a copy of hash table H1. Keys and values are not copied,
4513 only the table itself is. */
4516 copy_hash_table (h1
)
4517 struct Lisp_Hash_Table
*h1
;
4520 struct Lisp_Hash_Table
*h2
;
4521 struct Lisp_Vector
*next
;
4523 h2
= allocate_hash_table ();
4524 next
= h2
->vec_next
;
4525 bcopy (h1
, h2
, sizeof *h2
);
4526 h2
->vec_next
= next
;
4527 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4528 h2
->hash
= Fcopy_sequence (h1
->hash
);
4529 h2
->next
= Fcopy_sequence (h1
->next
);
4530 h2
->index
= Fcopy_sequence (h1
->index
);
4531 XSET_HASH_TABLE (table
, h2
);
4533 /* Maybe add this hash table to the list of all weak hash tables. */
4534 if (!NILP (h2
->weak
))
4536 h2
->next_weak
= Vweak_hash_tables
;
4537 Vweak_hash_tables
= table
;
4544 /* Resize hash table H if it's too full. If H cannot be resized
4545 because it's already too large, throw an error. */
4548 maybe_resize_hash_table (h
)
4549 struct Lisp_Hash_Table
*h
;
4551 if (NILP (h
->next_free
))
4553 int old_size
= HASH_TABLE_SIZE (h
);
4554 int i
, new_size
, index_size
;
4556 if (INTEGERP (h
->rehash_size
))
4557 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4559 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4560 new_size
= max (old_size
+ 1, new_size
);
4561 index_size
= next_almost_prime ((int)
4563 / XFLOATINT (h
->rehash_threshold
)));
4564 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4565 error ("Hash table too large to resize");
4567 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4568 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4569 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4570 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4572 /* Update the free list. Do it so that new entries are added at
4573 the end of the free list. This makes some operations like
4575 for (i
= old_size
; i
< new_size
- 1; ++i
)
4576 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4578 if (!NILP (h
->next_free
))
4580 Lisp_Object last
, next
;
4582 last
= h
->next_free
;
4583 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4587 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4590 XSETFASTINT (h
->next_free
, old_size
);
4593 for (i
= 0; i
< old_size
; ++i
)
4594 if (!NILP (HASH_HASH (h
, i
)))
4596 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4597 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4598 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4599 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4605 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4606 the hash code of KEY. Value is the index of the entry in H
4607 matching KEY, or -1 if not found. */
4610 hash_lookup (h
, key
, hash
)
4611 struct Lisp_Hash_Table
*h
;
4616 int start_of_bucket
;
4619 hash_code
= h
->hashfn (h
, key
);
4623 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4624 idx
= HASH_INDEX (h
, start_of_bucket
);
4626 /* We need not gcpro idx since it's either an integer or nil. */
4629 int i
= XFASTINT (idx
);
4630 if (EQ (key
, HASH_KEY (h
, i
))
4632 && h
->cmpfn (h
, key
, hash_code
,
4633 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4635 idx
= HASH_NEXT (h
, i
);
4638 return NILP (idx
) ? -1 : XFASTINT (idx
);
4642 /* Put an entry into hash table H that associates KEY with VALUE.
4643 HASH is a previously computed hash code of KEY.
4644 Value is the index of the entry in H matching KEY. */
4647 hash_put (h
, key
, value
, hash
)
4648 struct Lisp_Hash_Table
*h
;
4649 Lisp_Object key
, value
;
4652 int start_of_bucket
, i
;
4654 xassert ((hash
& ~INTMASK
) == 0);
4656 /* Increment count after resizing because resizing may fail. */
4657 maybe_resize_hash_table (h
);
4658 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4660 /* Store key/value in the key_and_value vector. */
4661 i
= XFASTINT (h
->next_free
);
4662 h
->next_free
= HASH_NEXT (h
, i
);
4663 HASH_KEY (h
, i
) = key
;
4664 HASH_VALUE (h
, i
) = value
;
4666 /* Remember its hash code. */
4667 HASH_HASH (h
, i
) = make_number (hash
);
4669 /* Add new entry to its collision chain. */
4670 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4671 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4672 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4677 /* Remove the entry matching KEY from hash table H, if there is one. */
4680 hash_remove (h
, key
)
4681 struct Lisp_Hash_Table
*h
;
4685 int start_of_bucket
;
4686 Lisp_Object idx
, prev
;
4688 hash_code
= h
->hashfn (h
, key
);
4689 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4690 idx
= HASH_INDEX (h
, start_of_bucket
);
4693 /* We need not gcpro idx, prev since they're either integers or nil. */
4696 int i
= XFASTINT (idx
);
4698 if (EQ (key
, HASH_KEY (h
, i
))
4700 && h
->cmpfn (h
, key
, hash_code
,
4701 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4703 /* Take entry out of collision chain. */
4705 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4707 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4709 /* Clear slots in key_and_value and add the slots to
4711 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4712 HASH_NEXT (h
, i
) = h
->next_free
;
4713 h
->next_free
= make_number (i
);
4714 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4715 xassert (XINT (h
->count
) >= 0);
4721 idx
= HASH_NEXT (h
, i
);
4727 /* Clear hash table H. */
4731 struct Lisp_Hash_Table
*h
;
4733 if (XFASTINT (h
->count
) > 0)
4735 int i
, size
= HASH_TABLE_SIZE (h
);
4737 for (i
= 0; i
< size
; ++i
)
4739 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4740 HASH_KEY (h
, i
) = Qnil
;
4741 HASH_VALUE (h
, i
) = Qnil
;
4742 HASH_HASH (h
, i
) = Qnil
;
4745 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4746 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4748 h
->next_free
= make_number (0);
4749 h
->count
= make_number (0);
4755 /************************************************************************
4757 ************************************************************************/
4759 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4760 entries from the table that don't survive the current GC.
4761 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4762 non-zero if anything was marked. */
4765 sweep_weak_table (h
, remove_entries_p
)
4766 struct Lisp_Hash_Table
*h
;
4767 int remove_entries_p
;
4769 int bucket
, n
, marked
;
4771 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4774 for (bucket
= 0; bucket
< n
; ++bucket
)
4776 Lisp_Object idx
, next
, prev
;
4778 /* Follow collision chain, removing entries that
4779 don't survive this garbage collection. */
4781 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4783 int i
= XFASTINT (idx
);
4784 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4785 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4788 if (EQ (h
->weak
, Qkey
))
4789 remove_p
= !key_known_to_survive_p
;
4790 else if (EQ (h
->weak
, Qvalue
))
4791 remove_p
= !value_known_to_survive_p
;
4792 else if (EQ (h
->weak
, Qkey_or_value
))
4793 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4794 else if (EQ (h
->weak
, Qkey_and_value
))
4795 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4799 next
= HASH_NEXT (h
, i
);
4801 if (remove_entries_p
)
4805 /* Take out of collision chain. */
4807 HASH_INDEX (h
, bucket
) = next
;
4809 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4811 /* Add to free list. */
4812 HASH_NEXT (h
, i
) = h
->next_free
;
4815 /* Clear key, value, and hash. */
4816 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4817 HASH_HASH (h
, i
) = Qnil
;
4819 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4826 /* Make sure key and value survive. */
4827 if (!key_known_to_survive_p
)
4829 mark_object (HASH_KEY (h
, i
));
4833 if (!value_known_to_survive_p
)
4835 mark_object (HASH_VALUE (h
, i
));
4846 /* Remove elements from weak hash tables that don't survive the
4847 current garbage collection. Remove weak tables that don't survive
4848 from Vweak_hash_tables. Called from gc_sweep. */
4851 sweep_weak_hash_tables ()
4853 Lisp_Object table
, used
, next
;
4854 struct Lisp_Hash_Table
*h
;
4857 /* Mark all keys and values that are in use. Keep on marking until
4858 there is no more change. This is necessary for cases like
4859 value-weak table A containing an entry X -> Y, where Y is used in a
4860 key-weak table B, Z -> Y. If B comes after A in the list of weak
4861 tables, X -> Y might be removed from A, although when looking at B
4862 one finds that it shouldn't. */
4866 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4868 h
= XHASH_TABLE (table
);
4869 if (h
->size
& ARRAY_MARK_FLAG
)
4870 marked
|= sweep_weak_table (h
, 0);
4875 /* Remove tables and entries that aren't used. */
4876 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4878 h
= XHASH_TABLE (table
);
4879 next
= h
->next_weak
;
4881 if (h
->size
& ARRAY_MARK_FLAG
)
4883 /* TABLE is marked as used. Sweep its contents. */
4884 if (XFASTINT (h
->count
) > 0)
4885 sweep_weak_table (h
, 1);
4887 /* Add table to the list of used weak hash tables. */
4888 h
->next_weak
= used
;
4893 Vweak_hash_tables
= used
;
4898 /***********************************************************************
4899 Hash Code Computation
4900 ***********************************************************************/
4902 /* Maximum depth up to which to dive into Lisp structures. */
4904 #define SXHASH_MAX_DEPTH 3
4906 /* Maximum length up to which to take list and vector elements into
4909 #define SXHASH_MAX_LEN 7
4911 /* Combine two integers X and Y for hashing. */
4913 #define SXHASH_COMBINE(X, Y) \
4914 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4918 /* Return a hash for string PTR which has length LEN. The hash
4919 code returned is guaranteed to fit in a Lisp integer. */
4922 sxhash_string (ptr
, len
)
4926 unsigned char *p
= ptr
;
4927 unsigned char *end
= p
+ len
;
4936 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4939 return hash
& INTMASK
;
4943 /* Return a hash for list LIST. DEPTH is the current depth in the
4944 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4947 sxhash_list (list
, depth
)
4954 if (depth
< SXHASH_MAX_DEPTH
)
4956 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4957 list
= XCDR (list
), ++i
)
4959 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4960 hash
= SXHASH_COMBINE (hash
, hash2
);
4967 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4968 the Lisp structure. */
4971 sxhash_vector (vec
, depth
)
4975 unsigned hash
= XVECTOR (vec
)->size
;
4978 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4979 for (i
= 0; i
< n
; ++i
)
4981 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4982 hash
= SXHASH_COMBINE (hash
, hash2
);
4989 /* Return a hash for bool-vector VECTOR. */
4992 sxhash_bool_vector (vec
)
4995 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4998 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4999 for (i
= 0; i
< n
; ++i
)
5000 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5006 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5007 structure. Value is an unsigned integer clipped to INTMASK. */
5016 if (depth
> SXHASH_MAX_DEPTH
)
5019 switch (XTYPE (obj
))
5026 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
5027 SCHARS (SYMBOL_NAME (obj
)));
5035 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5038 /* This can be everything from a vector to an overlay. */
5039 case Lisp_Vectorlike
:
5041 /* According to the CL HyperSpec, two arrays are equal only if
5042 they are `eq', except for strings and bit-vectors. In
5043 Emacs, this works differently. We have to compare element
5045 hash
= sxhash_vector (obj
, depth
);
5046 else if (BOOL_VECTOR_P (obj
))
5047 hash
= sxhash_bool_vector (obj
);
5049 /* Others are `equal' if they are `eq', so let's take their
5055 hash
= sxhash_list (obj
, depth
);
5060 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5061 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5062 for (hash
= 0; p
< e
; ++p
)
5063 hash
= SXHASH_COMBINE (hash
, *p
);
5071 return hash
& INTMASK
;
5076 /***********************************************************************
5078 ***********************************************************************/
5081 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5082 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5086 unsigned hash
= sxhash (obj
, 0);;
5087 return make_number (hash
);
5091 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5092 doc
: /* Create and return a new hash table.
5094 Arguments are specified as keyword/argument pairs. The following
5095 arguments are defined:
5097 :test TEST -- TEST must be a symbol that specifies how to compare
5098 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5099 `equal'. User-supplied test and hash functions can be specified via
5100 `define-hash-table-test'.
5102 :size SIZE -- A hint as to how many elements will be put in the table.
5105 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5106 fills up. If REHASH-SIZE is an integer, add that many space. If it
5107 is a float, it must be > 1.0, and the new size is computed by
5108 multiplying the old size with that factor. Default is 1.5.
5110 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5111 Resize the hash table when ratio of the number of entries in the
5112 table. Default is 0.8.
5114 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5115 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5116 returned is a weak table. Key/value pairs are removed from a weak
5117 hash table when there are no non-weak references pointing to their
5118 key, value, one of key or value, or both key and value, depending on
5119 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5122 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5127 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5128 Lisp_Object user_test
, user_hash
;
5132 /* The vector `used' is used to keep track of arguments that
5133 have been consumed. */
5134 used
= (char *) alloca (nargs
* sizeof *used
);
5135 bzero (used
, nargs
* sizeof *used
);
5137 /* See if there's a `:test TEST' among the arguments. */
5138 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5139 test
= i
< 0 ? Qeql
: args
[i
];
5140 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5142 /* See if it is a user-defined test. */
5145 prop
= Fget (test
, Qhash_table_test
);
5146 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5147 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5149 user_test
= XCAR (prop
);
5150 user_hash
= XCAR (XCDR (prop
));
5153 user_test
= user_hash
= Qnil
;
5155 /* See if there's a `:size SIZE' argument. */
5156 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5157 size
= i
< 0 ? Qnil
: args
[i
];
5159 size
= make_number (DEFAULT_HASH_SIZE
);
5160 else if (!INTEGERP (size
) || XINT (size
) < 0)
5162 list2 (build_string ("Invalid hash table size"),
5165 /* Look for `:rehash-size SIZE'. */
5166 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5167 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5168 if (!NUMBERP (rehash_size
)
5169 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5170 || XFLOATINT (rehash_size
) <= 1.0)
5172 list2 (build_string ("Invalid hash table rehash size"),
5175 /* Look for `:rehash-threshold THRESHOLD'. */
5176 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5177 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5178 if (!FLOATP (rehash_threshold
)
5179 || XFLOATINT (rehash_threshold
) <= 0.0
5180 || XFLOATINT (rehash_threshold
) > 1.0)
5182 list2 (build_string ("Invalid hash table rehash threshold"),
5185 /* Look for `:weakness WEAK'. */
5186 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5187 weak
= i
< 0 ? Qnil
: args
[i
];
5189 weak
= Qkey_and_value
;
5192 && !EQ (weak
, Qvalue
)
5193 && !EQ (weak
, Qkey_or_value
)
5194 && !EQ (weak
, Qkey_and_value
))
5195 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5198 /* Now, all args should have been used up, or there's a problem. */
5199 for (i
= 0; i
< nargs
; ++i
)
5202 list2 (build_string ("Invalid argument list"), args
[i
]));
5204 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5205 user_test
, user_hash
);
5209 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5210 doc
: /* Return a copy of hash table TABLE. */)
5214 return copy_hash_table (check_hash_table (table
));
5218 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5219 doc
: /* Return the number of elements in TABLE. */)
5223 return check_hash_table (table
)->count
;
5227 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5228 Shash_table_rehash_size
, 1, 1, 0,
5229 doc
: /* Return the current rehash size of TABLE. */)
5233 return check_hash_table (table
)->rehash_size
;
5237 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5238 Shash_table_rehash_threshold
, 1, 1, 0,
5239 doc
: /* Return the current rehash threshold of TABLE. */)
5243 return check_hash_table (table
)->rehash_threshold
;
5247 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5248 doc
: /* Return the size of TABLE.
5249 The size can be used as an argument to `make-hash-table' to create
5250 a hash table than can hold as many elements of TABLE holds
5251 without need for resizing. */)
5255 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5256 return make_number (HASH_TABLE_SIZE (h
));
5260 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5261 doc
: /* Return the test TABLE uses. */)
5265 return check_hash_table (table
)->test
;
5269 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5271 doc
: /* Return the weakness of TABLE. */)
5275 return check_hash_table (table
)->weak
;
5279 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5280 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5284 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5288 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5289 doc
: /* Clear hash table TABLE. */)
5293 hash_clear (check_hash_table (table
));
5298 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5299 doc
: /* Look up KEY in TABLE and return its associated value.
5300 If KEY is not found, return DFLT which defaults to nil. */)
5302 Lisp_Object key
, table
, dflt
;
5304 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5305 int i
= hash_lookup (h
, key
, NULL
);
5306 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5310 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5311 doc
: /* Associate KEY with VALUE in hash table TABLE.
5312 If KEY is already present in table, replace its current value with
5315 Lisp_Object key
, value
, table
;
5317 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5321 i
= hash_lookup (h
, key
, &hash
);
5323 HASH_VALUE (h
, i
) = value
;
5325 hash_put (h
, key
, value
, hash
);
5331 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5332 doc
: /* Remove KEY from TABLE. */)
5334 Lisp_Object key
, table
;
5336 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5337 hash_remove (h
, key
);
5342 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5343 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5344 FUNCTION is called with 2 arguments KEY and VALUE. */)
5346 Lisp_Object function
, table
;
5348 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5349 Lisp_Object args
[3];
5352 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5353 if (!NILP (HASH_HASH (h
, i
)))
5356 args
[1] = HASH_KEY (h
, i
);
5357 args
[2] = HASH_VALUE (h
, i
);
5365 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5366 Sdefine_hash_table_test
, 3, 3, 0,
5367 doc
: /* Define a new hash table test with name NAME, a symbol.
5369 In hash tables created with NAME specified as test, use TEST to
5370 compare keys, and HASH for computing hash codes of keys.
5372 TEST must be a function taking two arguments and returning non-nil if
5373 both arguments are the same. HASH must be a function taking one
5374 argument and return an integer that is the hash code of the argument.
5375 Hash code computation should use the whole value range of integers,
5376 including negative integers. */)
5378 Lisp_Object name
, test
, hash
;
5380 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5385 /************************************************************************
5387 ************************************************************************/
5392 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5393 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5395 A message digest is a cryptographic checksum of a document, and the
5396 algorithm to calculate it is defined in RFC 1321.
5398 The two optional arguments START and END are character positions
5399 specifying for which part of OBJECT the message digest should be
5400 computed. If nil or omitted, the digest is computed for the whole
5403 The MD5 message digest is computed from the result of encoding the
5404 text in a coding system, not directly from the internal Emacs form of
5405 the text. The optional fourth argument CODING-SYSTEM specifies which
5406 coding system to encode the text with. It should be the same coding
5407 system that you used or will use when actually writing the text into a
5410 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5411 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5412 system would be chosen by default for writing this text into a file.
5414 If OBJECT is a string, the most preferred coding system (see the
5415 command `prefer-coding-system') is used.
5417 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5418 guesswork fails. Normally, an error is signaled in such case. */)
5419 (object
, start
, end
, coding_system
, noerror
)
5420 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5422 unsigned char digest
[16];
5423 unsigned char value
[33];
5427 int start_char
= 0, end_char
= 0;
5428 int start_byte
= 0, end_byte
= 0;
5430 register struct buffer
*bp
;
5433 if (STRINGP (object
))
5435 if (NILP (coding_system
))
5437 /* Decide the coding-system to encode the data with. */
5439 if (STRING_MULTIBYTE (object
))
5440 /* use default, we can't guess correct value */
5441 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5443 coding_system
= Qraw_text
;
5446 if (NILP (Fcoding_system_p (coding_system
)))
5448 /* Invalid coding system. */
5450 if (!NILP (noerror
))
5451 coding_system
= Qraw_text
;
5454 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5457 if (STRING_MULTIBYTE (object
))
5458 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5460 size
= SCHARS (object
);
5461 size_byte
= SBYTES (object
);
5465 CHECK_NUMBER (start
);
5467 start_char
= XINT (start
);
5472 start_byte
= string_char_to_byte (object
, start_char
);
5478 end_byte
= size_byte
;
5484 end_char
= XINT (end
);
5489 end_byte
= string_char_to_byte (object
, end_char
);
5492 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5493 args_out_of_range_3 (object
, make_number (start_char
),
5494 make_number (end_char
));
5498 struct buffer
*prev
= current_buffer
;
5500 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5502 CHECK_BUFFER (object
);
5504 bp
= XBUFFER (object
);
5505 if (bp
!= current_buffer
)
5506 set_buffer_internal (bp
);
5512 CHECK_NUMBER_COERCE_MARKER (start
);
5520 CHECK_NUMBER_COERCE_MARKER (end
);
5525 temp
= b
, b
= e
, e
= temp
;
5527 if (!(BEGV
<= b
&& e
<= ZV
))
5528 args_out_of_range (start
, end
);
5530 if (NILP (coding_system
))
5532 /* Decide the coding-system to encode the data with.
5533 See fileio.c:Fwrite-region */
5535 if (!NILP (Vcoding_system_for_write
))
5536 coding_system
= Vcoding_system_for_write
;
5539 int force_raw_text
= 0;
5541 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5542 if (NILP (coding_system
)
5543 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5545 coding_system
= Qnil
;
5546 if (NILP (current_buffer
->enable_multibyte_characters
))
5550 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5552 /* Check file-coding-system-alist. */
5553 Lisp_Object args
[4], val
;
5555 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5556 args
[3] = Fbuffer_file_name(object
);
5557 val
= Ffind_operation_coding_system (4, args
);
5558 if (CONSP (val
) && !NILP (XCDR (val
)))
5559 coding_system
= XCDR (val
);
5562 if (NILP (coding_system
)
5563 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5565 /* If we still have not decided a coding system, use the
5566 default value of buffer-file-coding-system. */
5567 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5571 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5572 /* Confirm that VAL can surely encode the current region. */
5573 coding_system
= call4 (Vselect_safe_coding_system_function
,
5574 make_number (b
), make_number (e
),
5575 coding_system
, Qnil
);
5578 coding_system
= Qraw_text
;
5581 if (NILP (Fcoding_system_p (coding_system
)))
5583 /* Invalid coding system. */
5585 if (!NILP (noerror
))
5586 coding_system
= Qraw_text
;
5589 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5593 object
= make_buffer_string (b
, e
, 0);
5594 if (prev
!= current_buffer
)
5595 set_buffer_internal (prev
);
5596 /* Discard the unwind protect for recovering the current
5600 if (STRING_MULTIBYTE (object
))
5601 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5604 md5_buffer (SDATA (object
) + start_byte
,
5605 SBYTES (object
) - (size_byte
- end_byte
),
5608 for (i
= 0; i
< 16; i
++)
5609 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5612 return make_string (value
, 32);
5619 /* Hash table stuff. */
5620 Qhash_table_p
= intern ("hash-table-p");
5621 staticpro (&Qhash_table_p
);
5622 Qeq
= intern ("eq");
5624 Qeql
= intern ("eql");
5626 Qequal
= intern ("equal");
5627 staticpro (&Qequal
);
5628 QCtest
= intern (":test");
5629 staticpro (&QCtest
);
5630 QCsize
= intern (":size");
5631 staticpro (&QCsize
);
5632 QCrehash_size
= intern (":rehash-size");
5633 staticpro (&QCrehash_size
);
5634 QCrehash_threshold
= intern (":rehash-threshold");
5635 staticpro (&QCrehash_threshold
);
5636 QCweakness
= intern (":weakness");
5637 staticpro (&QCweakness
);
5638 Qkey
= intern ("key");
5640 Qvalue
= intern ("value");
5641 staticpro (&Qvalue
);
5642 Qhash_table_test
= intern ("hash-table-test");
5643 staticpro (&Qhash_table_test
);
5644 Qkey_or_value
= intern ("key-or-value");
5645 staticpro (&Qkey_or_value
);
5646 Qkey_and_value
= intern ("key-and-value");
5647 staticpro (&Qkey_and_value
);
5650 defsubr (&Smake_hash_table
);
5651 defsubr (&Scopy_hash_table
);
5652 defsubr (&Shash_table_count
);
5653 defsubr (&Shash_table_rehash_size
);
5654 defsubr (&Shash_table_rehash_threshold
);
5655 defsubr (&Shash_table_size
);
5656 defsubr (&Shash_table_test
);
5657 defsubr (&Shash_table_weakness
);
5658 defsubr (&Shash_table_p
);
5659 defsubr (&Sclrhash
);
5660 defsubr (&Sgethash
);
5661 defsubr (&Sputhash
);
5662 defsubr (&Sremhash
);
5663 defsubr (&Smaphash
);
5664 defsubr (&Sdefine_hash_table_test
);
5666 Qstring_lessp
= intern ("string-lessp");
5667 staticpro (&Qstring_lessp
);
5668 Qprovide
= intern ("provide");
5669 staticpro (&Qprovide
);
5670 Qrequire
= intern ("require");
5671 staticpro (&Qrequire
);
5672 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5673 staticpro (&Qyes_or_no_p_history
);
5674 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5675 staticpro (&Qcursor_in_echo_area
);
5676 Qwidget_type
= intern ("widget-type");
5677 staticpro (&Qwidget_type
);
5679 staticpro (&string_char_byte_cache_string
);
5680 string_char_byte_cache_string
= Qnil
;
5682 require_nesting_list
= Qnil
;
5683 staticpro (&require_nesting_list
);
5685 Fset (Qyes_or_no_p_history
, Qnil
);
5687 DEFVAR_LISP ("features", &Vfeatures
,
5688 doc
: /* A list of symbols which are the features of the executing emacs.
5689 Used by `featurep' and `require', and altered by `provide'. */);
5691 Qsubfeatures
= intern ("subfeatures");
5692 staticpro (&Qsubfeatures
);
5694 #ifdef HAVE_LANGINFO_CODESET
5695 Qcodeset
= intern ("codeset");
5696 staticpro (&Qcodeset
);
5697 Qdays
= intern ("days");
5699 Qmonths
= intern ("months");
5700 staticpro (&Qmonths
);
5701 Qpaper
= intern ("paper");
5702 staticpro (&Qpaper
);
5703 #endif /* HAVE_LANGINFO_CODESET */
5705 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5706 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5707 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5708 invoked by mouse clicks and mouse menu items. */);
5711 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5712 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5713 This applies to commands from menus and tool bar buttons. The value of
5714 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5715 used if both `use-dialog-box' and this variable are non-nil. */);
5716 use_file_dialog
= 1;
5718 defsubr (&Sidentity
);
5721 defsubr (&Ssafe_length
);
5722 defsubr (&Sstring_bytes
);
5723 defsubr (&Sstring_equal
);
5724 defsubr (&Scompare_strings
);
5725 defsubr (&Sstring_lessp
);
5728 defsubr (&Svconcat
);
5729 defsubr (&Scopy_sequence
);
5730 defsubr (&Sstring_make_multibyte
);
5731 defsubr (&Sstring_make_unibyte
);
5732 defsubr (&Sstring_as_multibyte
);
5733 defsubr (&Sstring_as_unibyte
);
5734 defsubr (&Sstring_to_multibyte
);
5735 defsubr (&Scopy_alist
);
5736 defsubr (&Ssubstring
);
5737 defsubr (&Ssubstring_no_properties
);
5749 defsubr (&Snreverse
);
5750 defsubr (&Sreverse
);
5752 defsubr (&Splist_get
);
5754 defsubr (&Splist_put
);
5756 defsubr (&Slax_plist_get
);
5757 defsubr (&Slax_plist_put
);
5760 defsubr (&Sequal_including_properties
);
5761 defsubr (&Sfillarray
);
5762 defsubr (&Sclear_string
);
5763 defsubr (&Schar_table_subtype
);
5764 defsubr (&Schar_table_parent
);
5765 defsubr (&Sset_char_table_parent
);
5766 defsubr (&Schar_table_extra_slot
);
5767 defsubr (&Sset_char_table_extra_slot
);
5768 defsubr (&Schar_table_range
);
5769 defsubr (&Sset_char_table_range
);
5770 defsubr (&Sset_char_table_default
);
5771 defsubr (&Soptimize_char_table
);
5772 defsubr (&Smap_char_table
);
5776 defsubr (&Smapconcat
);
5777 defsubr (&Sy_or_n_p
);
5778 defsubr (&Syes_or_no_p
);
5779 defsubr (&Sload_average
);
5780 defsubr (&Sfeaturep
);
5781 defsubr (&Srequire
);
5782 defsubr (&Sprovide
);
5783 defsubr (&Splist_member
);
5784 defsubr (&Swidget_put
);
5785 defsubr (&Swidget_get
);
5786 defsubr (&Swidget_apply
);
5787 defsubr (&Sbase64_encode_region
);
5788 defsubr (&Sbase64_decode_region
);
5789 defsubr (&Sbase64_encode_string
);
5790 defsubr (&Sbase64_decode_string
);
5792 defsubr (&Slocale_info
);
5799 Vweak_hash_tables
= Qnil
;
5802 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5803 (do not change this comment) */