1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 02, 2003
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* On Mac OS X, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 /* Nonzero enables use of a file dialog for file name
63 questions asked by mouse commands. */
66 extern int minibuffer_auto_raise
;
67 extern Lisp_Object minibuf_window
;
68 extern Lisp_Object Vlocale_coding_system
;
70 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
71 Lisp_Object Qyes_or_no_p_history
;
72 Lisp_Object Qcursor_in_echo_area
;
73 Lisp_Object Qwidget_type
;
74 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
76 extern Lisp_Object Qinput_method_function
;
78 static int internal_equal ();
80 extern long get_random ();
81 extern void seed_random ();
87 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
88 doc
: /* Return the argument unchanged. */)
95 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
96 doc
: /* Return a pseudo-random number.
97 All integers representable in Lisp are equally likely.
98 On most systems, this is 29 bits' worth.
99 With positive integer argument N, return random number in interval [0,N).
100 With argument t, set the random number seed from the current time and pid. */)
105 Lisp_Object lispy_val
;
106 unsigned long denominator
;
109 seed_random (getpid () + time (NULL
));
110 if (NATNUMP (n
) && XFASTINT (n
) != 0)
112 /* Try to take our random number from the higher bits of VAL,
113 not the lower, since (says Gentzel) the low bits of `random'
114 are less random than the higher ones. We do this by using the
115 quotient rather than the remainder. At the high end of the RNG
116 it's possible to get a quotient larger than n; discarding
117 these values eliminates the bias that would otherwise appear
118 when using a large n. */
119 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
121 val
= get_random () / denominator
;
122 while (val
>= XFASTINT (n
));
126 XSETINT (lispy_val
, val
);
130 /* Random data-structure functions */
132 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
133 doc
: /* Return the length of vector, list or string SEQUENCE.
134 A byte-code function object is also allowed.
135 If the string contains multibyte characters, this is not necessarily
136 the number of bytes in the string; it is the number of characters.
137 To get the number of bytes, use `string-bytes'. */)
139 register Lisp_Object sequence
;
141 register Lisp_Object val
;
145 if (STRINGP (sequence
))
146 XSETFASTINT (val
, SCHARS (sequence
));
147 else if (VECTORP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
149 else if (SUB_CHAR_TABLE_P (sequence
))
150 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
151 else if (CHAR_TABLE_P (sequence
))
152 XSETFASTINT (val
, MAX_CHAR
);
153 else if (BOOL_VECTOR_P (sequence
))
154 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
155 else if (COMPILEDP (sequence
))
156 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
157 else if (CONSP (sequence
))
160 while (CONSP (sequence
))
162 sequence
= XCDR (sequence
);
165 if (!CONSP (sequence
))
168 sequence
= XCDR (sequence
);
173 if (!NILP (sequence
))
174 wrong_type_argument (Qlistp
, sequence
);
176 val
= make_number (i
);
178 else if (NILP (sequence
))
179 XSETFASTINT (val
, 0);
182 sequence
= wrong_type_argument (Qsequencep
, sequence
);
188 /* This does not check for quits. That is safe
189 since it must terminate. */
191 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
192 doc
: /* Return the length of a list, but avoid error or infinite loop.
193 This function never gets an error. If LIST is not really a list,
194 it returns 0. If LIST is circular, it returns a finite value
195 which is at least the number of distinct elements. */)
199 Lisp_Object tail
, halftail
, length
;
202 /* halftail is used to detect circular lists. */
204 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
206 if (EQ (tail
, halftail
) && len
!= 0)
210 halftail
= XCDR (halftail
);
213 XSETINT (length
, len
);
217 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
218 doc
: /* Return the number of bytes in STRING.
219 If STRING is a multibyte string, this is greater than the length of STRING. */)
223 CHECK_STRING (string
);
224 return make_number (SBYTES (string
));
227 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
228 doc
: /* Return t if two strings have identical contents.
229 Case is significant, but text properties are ignored.
230 Symbols are also allowed; their print names are used instead. */)
232 register Lisp_Object s1
, s2
;
235 s1
= SYMBOL_NAME (s1
);
237 s2
= SYMBOL_NAME (s2
);
241 if (SCHARS (s1
) != SCHARS (s2
)
242 || SBYTES (s1
) != SBYTES (s2
)
243 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
248 DEFUN ("compare-strings", Fcompare_strings
,
249 Scompare_strings
, 6, 7, 0,
250 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
251 In string STR1, skip the first START1 characters and stop at END1.
252 In string STR2, skip the first START2 characters and stop at END2.
253 END1 and END2 default to the full lengths of the respective strings.
255 Case is significant in this comparison if IGNORE-CASE is nil.
256 Unibyte strings are converted to multibyte for comparison.
258 The value is t if the strings (or specified portions) match.
259 If string STR1 is less, the value is a negative number N;
260 - 1 - N is the number of characters that match at the beginning.
261 If string STR1 is greater, the value is a positive number N;
262 N - 1 is the number of characters that match at the beginning. */)
263 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
264 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
266 register int end1_char
, end2_char
;
267 register int i1
, i1_byte
, i2
, i2_byte
;
272 start1
= make_number (0);
274 start2
= make_number (0);
275 CHECK_NATNUM (start1
);
276 CHECK_NATNUM (start2
);
285 i1_byte
= string_char_to_byte (str1
, i1
);
286 i2_byte
= string_char_to_byte (str2
, i2
);
288 end1_char
= SCHARS (str1
);
289 if (! NILP (end1
) && end1_char
> XINT (end1
))
290 end1_char
= XINT (end1
);
292 end2_char
= SCHARS (str2
);
293 if (! NILP (end2
) && end2_char
> XINT (end2
))
294 end2_char
= XINT (end2
);
296 while (i1
< end1_char
&& i2
< end2_char
)
298 /* When we find a mismatch, we must compare the
299 characters, not just the bytes. */
302 if (STRING_MULTIBYTE (str1
))
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
306 c1
= SREF (str1
, i1
++);
307 c1
= unibyte_char_to_multibyte (c1
);
310 if (STRING_MULTIBYTE (str2
))
311 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
314 c2
= SREF (str2
, i2
++);
315 c2
= unibyte_char_to_multibyte (c2
);
321 if (! NILP (ignore_case
))
325 tem
= Fupcase (make_number (c1
));
327 tem
= Fupcase (make_number (c2
));
334 /* Note that I1 has already been incremented
335 past the character that we are comparing;
336 hence we don't add or subtract 1 here. */
338 return make_number (- i1
+ XINT (start1
));
340 return make_number (i1
- XINT (start1
));
344 return make_number (i1
- XINT (start1
) + 1);
346 return make_number (- i1
+ XINT (start1
) - 1);
351 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
352 doc
: /* Return t if first arg string is less than second in lexicographic order.
354 Symbols are also allowed; their print names are used instead. */)
356 register Lisp_Object s1
, s2
;
359 register int i1
, i1_byte
, i2
, i2_byte
;
362 s1
= SYMBOL_NAME (s1
);
364 s2
= SYMBOL_NAME (s2
);
368 i1
= i1_byte
= i2
= i2_byte
= 0;
371 if (end
> SCHARS (s2
))
376 /* When we find a mismatch, we must compare the
377 characters, not just the bytes. */
380 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
381 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
384 return c1
< c2
? Qt
: Qnil
;
386 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
389 static Lisp_Object
concat ();
400 return concat (2, args
, Lisp_String
, 0);
402 return concat (2, &s1
, Lisp_String
, 0);
403 #endif /* NO_ARG_ARRAY */
409 Lisp_Object s1
, s2
, s3
;
416 return concat (3, args
, Lisp_String
, 0);
418 return concat (3, &s1
, Lisp_String
, 0);
419 #endif /* NO_ARG_ARRAY */
422 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
423 doc
: /* Concatenate all the arguments and make the result a list.
424 The result is a list whose elements are the elements of all the arguments.
425 Each argument may be a list, vector or string.
426 The last argument is not copied, just used as the tail of the new list.
427 usage: (append &rest SEQUENCES) */)
432 return concat (nargs
, args
, Lisp_Cons
, 1);
435 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
436 doc
: /* Concatenate all the arguments and make the result a string.
437 The result is a string whose elements are the elements of all the arguments.
438 Each argument may be a string or a list or vector of characters (integers).
439 usage: (concat &rest SEQUENCES) */)
444 return concat (nargs
, args
, Lisp_String
, 0);
447 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
448 doc
: /* Concatenate all the arguments and make the result a vector.
449 The result is a vector whose elements are the elements of all the arguments.
450 Each argument may be a list, vector or string.
451 usage: (vconcat &rest SEQUENCES) */)
456 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
459 /* Return a copy of a sub char table ARG. The elements except for a
460 nested sub char table are not copied. */
462 copy_sub_char_table (arg
)
465 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
468 /* Copy all the contents. */
469 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
470 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
471 /* Recursively copy any sub char-tables in the ordinary slots. */
472 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
473 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
474 XCHAR_TABLE (copy
)->contents
[i
]
475 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
481 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
482 doc
: /* Return a copy of a list, vector, string or char-table.
483 The elements of a list or vector are not copied; they are shared
484 with the original. */)
488 if (NILP (arg
)) return arg
;
490 if (CHAR_TABLE_P (arg
))
495 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
496 /* Copy all the slots, including the extra ones. */
497 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
498 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
499 * sizeof (Lisp_Object
)));
501 /* Recursively copy any sub char tables in the ordinary slots
502 for multibyte characters. */
503 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
504 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
505 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
506 XCHAR_TABLE (copy
)->contents
[i
]
507 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
512 if (BOOL_VECTOR_P (arg
))
516 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
518 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
519 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
524 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
525 arg
= wrong_type_argument (Qsequencep
, arg
);
526 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
529 /* In string STR of length LEN, see if bytes before STR[I] combine
530 with bytes after STR[I] to form a single character. If so, return
531 the number of bytes after STR[I] which combine in this way.
532 Otherwize, return 0. */
535 count_combining (str
, len
, i
)
539 int j
= i
- 1, bytes
;
541 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
543 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
544 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
546 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
547 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
550 /* This structure holds information of an argument of `concat' that is
551 a string and has text properties to be copied. */
554 int argnum
; /* refer to ARGS (arguments of `concat') */
555 int from
; /* refer to ARGS[argnum] (argument string) */
556 int to
; /* refer to VAL (the target string) */
560 concat (nargs
, args
, target_type
, last_special
)
563 enum Lisp_Type target_type
;
567 register Lisp_Object tail
;
568 register Lisp_Object
this;
570 int toindex_byte
= 0;
571 register int result_len
;
572 register int result_len_byte
;
574 Lisp_Object last_tail
;
577 /* When we make a multibyte string, we can't copy text properties
578 while concatinating each string because the length of resulting
579 string can't be decided until we finish the whole concatination.
580 So, we record strings that have text properties to be copied
581 here, and copy the text properties after the concatination. */
582 struct textprop_rec
*textprops
= NULL
;
583 /* Number of elments in textprops. */
584 int num_textprops
= 0;
588 /* In append, the last arg isn't treated like the others */
589 if (last_special
&& nargs
> 0)
592 last_tail
= args
[nargs
];
597 /* Canonicalize each argument. */
598 for (argnum
= 0; argnum
< nargs
; argnum
++)
601 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
602 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
604 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
608 /* Compute total length in chars of arguments in RESULT_LEN.
609 If desired output is a string, also compute length in bytes
610 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
611 whether the result should be a multibyte string. */
615 for (argnum
= 0; argnum
< nargs
; argnum
++)
619 len
= XFASTINT (Flength (this));
620 if (target_type
== Lisp_String
)
622 /* We must count the number of bytes needed in the string
623 as well as the number of characters. */
629 for (i
= 0; i
< len
; i
++)
631 ch
= XVECTOR (this)->contents
[i
];
633 wrong_type_argument (Qintegerp
, ch
);
634 this_len_byte
= CHAR_BYTES (XINT (ch
));
635 result_len_byte
+= this_len_byte
;
636 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
639 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
640 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
641 else if (CONSP (this))
642 for (; CONSP (this); this = XCDR (this))
646 wrong_type_argument (Qintegerp
, ch
);
647 this_len_byte
= CHAR_BYTES (XINT (ch
));
648 result_len_byte
+= this_len_byte
;
649 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
652 else if (STRINGP (this))
654 if (STRING_MULTIBYTE (this))
657 result_len_byte
+= SBYTES (this);
660 result_len_byte
+= count_size_as_multibyte (SDATA (this),
668 if (! some_multibyte
)
669 result_len_byte
= result_len
;
671 /* Create the output object. */
672 if (target_type
== Lisp_Cons
)
673 val
= Fmake_list (make_number (result_len
), Qnil
);
674 else if (target_type
== Lisp_Vectorlike
)
675 val
= Fmake_vector (make_number (result_len
), Qnil
);
676 else if (some_multibyte
)
677 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
679 val
= make_uninit_string (result_len
);
681 /* In `append', if all but last arg are nil, return last arg. */
682 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
685 /* Copy the contents of the args into the result. */
687 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
689 toindex
= 0, toindex_byte
= 0;
694 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
696 for (argnum
= 0; argnum
< nargs
; argnum
++)
700 register unsigned int thisindex
= 0;
701 register unsigned int thisindex_byte
= 0;
705 thislen
= Flength (this), thisleni
= XINT (thislen
);
707 /* Between strings of the same kind, copy fast. */
708 if (STRINGP (this) && STRINGP (val
)
709 && STRING_MULTIBYTE (this) == some_multibyte
)
711 int thislen_byte
= SBYTES (this);
714 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
716 combined
= (some_multibyte
&& toindex_byte
> 0
717 ? count_combining (SDATA (val
),
718 toindex_byte
+ thislen_byte
,
721 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
723 textprops
[num_textprops
].argnum
= argnum
;
724 /* We ignore text properties on characters being combined. */
725 textprops
[num_textprops
].from
= combined
;
726 textprops
[num_textprops
++].to
= toindex
;
728 toindex_byte
+= thislen_byte
;
729 toindex
+= thisleni
- combined
;
730 STRING_SET_CHARS (val
, SCHARS (val
) - combined
);
732 /* Copy a single-byte string to a multibyte string. */
733 else if (STRINGP (this) && STRINGP (val
))
735 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
737 textprops
[num_textprops
].argnum
= argnum
;
738 textprops
[num_textprops
].from
= 0;
739 textprops
[num_textprops
++].to
= toindex
;
741 toindex_byte
+= copy_text (SDATA (this),
742 SDATA (val
) + toindex_byte
,
743 SCHARS (this), 0, 1);
747 /* Copy element by element. */
750 register Lisp_Object elt
;
752 /* Fetch next element of `this' arg into `elt', or break if
753 `this' is exhausted. */
754 if (NILP (this)) break;
756 elt
= XCAR (this), this = XCDR (this);
757 else if (thisindex
>= thisleni
)
759 else if (STRINGP (this))
762 if (STRING_MULTIBYTE (this))
764 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
767 XSETFASTINT (elt
, c
);
771 XSETFASTINT (elt
, SREF (this, thisindex
++));
773 && (XINT (elt
) >= 0240
774 || (XINT (elt
) >= 0200
775 && ! NILP (Vnonascii_translation_table
)))
776 && XINT (elt
) < 0400)
778 c
= unibyte_char_to_multibyte (XINT (elt
));
783 else if (BOOL_VECTOR_P (this))
786 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
787 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
794 elt
= XVECTOR (this)->contents
[thisindex
++];
796 /* Store this element into the result. */
803 else if (VECTORP (val
))
804 XVECTOR (val
)->contents
[toindex
++] = elt
;
808 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
812 += CHAR_STRING (XINT (elt
),
813 SDATA (val
) + toindex_byte
);
815 SSET (val
, toindex_byte
++, XINT (elt
));
818 && count_combining (SDATA (val
),
819 toindex_byte
, toindex_byte
- 1))
820 STRING_SET_CHARS (val
, SCHARS (val
) - 1);
825 /* If we have any multibyte characters,
826 we already decided to make a multibyte string. */
829 /* P exists as a variable
830 to avoid a bug on the Masscomp C compiler. */
831 unsigned char *p
= SDATA (val
) + toindex_byte
;
833 toindex_byte
+= CHAR_STRING (c
, p
);
840 XSETCDR (prev
, last_tail
);
842 if (num_textprops
> 0)
845 int last_to_end
= -1;
847 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
849 this = args
[textprops
[argnum
].argnum
];
850 props
= text_property_list (this,
852 make_number (SCHARS (this)),
854 /* If successive arguments have properites, be sure that the
855 value of `composition' property be the copy. */
856 if (last_to_end
== textprops
[argnum
].to
)
857 make_composition_value_copy (props
);
858 add_text_properties_from_list (val
, props
,
859 make_number (textprops
[argnum
].to
));
860 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
866 static Lisp_Object string_char_byte_cache_string
;
867 static int string_char_byte_cache_charpos
;
868 static int string_char_byte_cache_bytepos
;
871 clear_string_char_byte_cache ()
873 string_char_byte_cache_string
= Qnil
;
876 /* Return the character index corresponding to CHAR_INDEX in STRING. */
879 string_char_to_byte (string
, char_index
)
884 int best_below
, best_below_byte
;
885 int best_above
, best_above_byte
;
887 best_below
= best_below_byte
= 0;
888 best_above
= SCHARS (string
);
889 best_above_byte
= SBYTES (string
);
890 if (best_above
== best_above_byte
)
893 if (EQ (string
, string_char_byte_cache_string
))
895 if (string_char_byte_cache_charpos
< char_index
)
897 best_below
= string_char_byte_cache_charpos
;
898 best_below_byte
= string_char_byte_cache_bytepos
;
902 best_above
= string_char_byte_cache_charpos
;
903 best_above_byte
= string_char_byte_cache_bytepos
;
907 if (char_index
- best_below
< best_above
- char_index
)
909 while (best_below
< char_index
)
912 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
913 best_below
, best_below_byte
);
916 i_byte
= best_below_byte
;
920 while (best_above
> char_index
)
922 unsigned char *pend
= SDATA (string
) + best_above_byte
;
923 unsigned char *pbeg
= pend
- best_above_byte
;
924 unsigned char *p
= pend
- 1;
927 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
928 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
929 if (bytes
== pend
- p
)
930 best_above_byte
-= bytes
;
931 else if (bytes
> pend
- p
)
932 best_above_byte
-= (pend
- p
);
938 i_byte
= best_above_byte
;
941 string_char_byte_cache_bytepos
= i_byte
;
942 string_char_byte_cache_charpos
= i
;
943 string_char_byte_cache_string
= string
;
948 /* Return the character index corresponding to BYTE_INDEX in STRING. */
951 string_byte_to_char (string
, byte_index
)
956 int best_below
, best_below_byte
;
957 int best_above
, best_above_byte
;
959 best_below
= best_below_byte
= 0;
960 best_above
= SCHARS (string
);
961 best_above_byte
= SBYTES (string
);
962 if (best_above
== best_above_byte
)
965 if (EQ (string
, string_char_byte_cache_string
))
967 if (string_char_byte_cache_bytepos
< byte_index
)
969 best_below
= string_char_byte_cache_charpos
;
970 best_below_byte
= string_char_byte_cache_bytepos
;
974 best_above
= string_char_byte_cache_charpos
;
975 best_above_byte
= string_char_byte_cache_bytepos
;
979 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
981 while (best_below_byte
< byte_index
)
984 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
985 best_below
, best_below_byte
);
988 i_byte
= best_below_byte
;
992 while (best_above_byte
> byte_index
)
994 unsigned char *pend
= SDATA (string
) + best_above_byte
;
995 unsigned char *pbeg
= pend
- best_above_byte
;
996 unsigned char *p
= pend
- 1;
999 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
1000 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
1001 if (bytes
== pend
- p
)
1002 best_above_byte
-= bytes
;
1003 else if (bytes
> pend
- p
)
1004 best_above_byte
-= (pend
- p
);
1010 i_byte
= best_above_byte
;
1013 string_char_byte_cache_bytepos
= i_byte
;
1014 string_char_byte_cache_charpos
= i
;
1015 string_char_byte_cache_string
= string
;
1020 /* Convert STRING to a multibyte string.
1021 Single-byte characters 0240 through 0377 are converted
1022 by adding nonascii_insert_offset to each. */
1025 string_make_multibyte (string
)
1031 if (STRING_MULTIBYTE (string
))
1034 nbytes
= count_size_as_multibyte (SDATA (string
),
1036 /* If all the chars are ASCII, they won't need any more bytes
1037 once converted. In that case, we can return STRING itself. */
1038 if (nbytes
== SBYTES (string
))
1041 buf
= (unsigned char *) alloca (nbytes
);
1042 copy_text (SDATA (string
), buf
, SBYTES (string
),
1045 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1049 /* Convert STRING to a multibyte string without changing each
1050 character codes. Thus, characters 0200 trough 0237 are converted
1051 to eight-bit-control characters, and characters 0240 through 0377
1052 are converted eight-bit-graphic characters. */
1055 string_to_multibyte (string
)
1061 if (STRING_MULTIBYTE (string
))
1064 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1065 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1066 any more bytes once converted. */
1067 if (nbytes
== SBYTES (string
))
1068 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1070 buf
= (unsigned char *) alloca (nbytes
);
1071 bcopy (SDATA (string
), buf
, SBYTES (string
));
1072 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1074 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1078 /* Convert STRING to a single-byte string. */
1081 string_make_unibyte (string
)
1086 if (! STRING_MULTIBYTE (string
))
1089 buf
= (unsigned char *) alloca (SCHARS (string
));
1091 copy_text (SDATA (string
), buf
, SBYTES (string
),
1094 return make_unibyte_string (buf
, SCHARS (string
));
1097 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1099 doc
: /* Return the multibyte equivalent of STRING.
1100 If STRING is unibyte and contains non-ASCII characters, the function
1101 `unibyte-char-to-multibyte' is used to convert each unibyte character
1102 to a multibyte character. In this case, the returned string is a
1103 newly created string with no text properties. If STRING is multibyte
1104 or entirely ASCII, it is returned unchanged. In particular, when
1105 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1106 \(When the characters are all ASCII, Emacs primitives will treat the
1107 string the same way whether it is unibyte or multibyte.) */)
1111 CHECK_STRING (string
);
1113 return string_make_multibyte (string
);
1116 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1118 doc
: /* Return the unibyte equivalent of STRING.
1119 Multibyte character codes are converted to unibyte according to
1120 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1121 If the lookup in the translation table fails, this function takes just
1122 the low 8 bits of each character. */)
1126 CHECK_STRING (string
);
1128 return string_make_unibyte (string
);
1131 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1133 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1134 If STRING is unibyte, the result is STRING itself.
1135 Otherwise it is a newly created string, with no text properties.
1136 If STRING is multibyte and contains a character of charset
1137 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1138 corresponding single byte. */)
1142 CHECK_STRING (string
);
1144 if (STRING_MULTIBYTE (string
))
1146 int bytes
= SBYTES (string
);
1147 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1149 bcopy (SDATA (string
), str
, bytes
);
1150 bytes
= str_as_unibyte (str
, bytes
);
1151 string
= make_unibyte_string (str
, bytes
);
1157 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1159 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1160 If STRING is multibyte, the result is STRING itself.
1161 Otherwise it is a newly created string, with no text properties.
1162 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1163 part of a multibyte form), it is converted to the corresponding
1164 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1168 CHECK_STRING (string
);
1170 if (! STRING_MULTIBYTE (string
))
1172 Lisp_Object new_string
;
1175 parse_str_as_multibyte (SDATA (string
),
1178 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1179 bcopy (SDATA (string
), SDATA (new_string
),
1181 if (nbytes
!= SBYTES (string
))
1182 str_as_multibyte (SDATA (new_string
), nbytes
,
1183 SBYTES (string
), NULL
);
1184 string
= new_string
;
1185 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1190 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1192 doc
: /* Return a multibyte string with the same individual chars as STRING.
1193 If STRING is multibyte, the result is STRING itself.
1194 Otherwise it is a newly created string, with no text properties.
1195 Characters 0200 through 0237 are converted to eight-bit-control
1196 characters of the same character code. Characters 0240 through 0377
1197 are converted to eight-bit-graphic characters of the same character
1202 CHECK_STRING (string
);
1204 return string_to_multibyte (string
);
1208 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1209 doc
: /* Return a copy of ALIST.
1210 This is an alist which represents the same mapping from objects to objects,
1211 but does not share the alist structure with ALIST.
1212 The objects mapped (cars and cdrs of elements of the alist)
1213 are shared, however.
1214 Elements of ALIST that are not conses are also shared. */)
1218 register Lisp_Object tem
;
1223 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1224 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1226 register Lisp_Object car
;
1230 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1235 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1236 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1237 TO may be nil or omitted; then the substring runs to the end of STRING.
1238 FROM and TO start at 0. If either is negative, it counts from the end.
1240 This function allows vectors as well as strings. */)
1243 register Lisp_Object from
, to
;
1248 int from_char
, to_char
;
1249 int from_byte
= 0, to_byte
= 0;
1251 if (! (STRINGP (string
) || VECTORP (string
)))
1252 wrong_type_argument (Qarrayp
, string
);
1254 CHECK_NUMBER (from
);
1256 if (STRINGP (string
))
1258 size
= SCHARS (string
);
1259 size_byte
= SBYTES (string
);
1262 size
= XVECTOR (string
)->size
;
1267 to_byte
= size_byte
;
1273 to_char
= XINT (to
);
1277 if (STRINGP (string
))
1278 to_byte
= string_char_to_byte (string
, to_char
);
1281 from_char
= XINT (from
);
1284 if (STRINGP (string
))
1285 from_byte
= string_char_to_byte (string
, from_char
);
1287 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1288 args_out_of_range_3 (string
, make_number (from_char
),
1289 make_number (to_char
));
1291 if (STRINGP (string
))
1293 res
= make_specified_string (SDATA (string
) + from_byte
,
1294 to_char
- from_char
, to_byte
- from_byte
,
1295 STRING_MULTIBYTE (string
));
1296 copy_text_properties (make_number (from_char
), make_number (to_char
),
1297 string
, make_number (0), res
, Qnil
);
1300 res
= Fvector (to_char
- from_char
,
1301 XVECTOR (string
)->contents
+ from_char
);
1307 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1308 doc
: /* Return a substring of STRING, without text properties.
1309 It starts at index FROM and ending before TO.
1310 TO may be nil or omitted; then the substring runs to the end of STRING.
1311 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1312 If FROM or TO is negative, it counts from the end.
1314 With one argument, just copy STRING without its properties. */)
1317 register Lisp_Object from
, to
;
1319 int size
, size_byte
;
1320 int from_char
, to_char
;
1321 int from_byte
, to_byte
;
1323 CHECK_STRING (string
);
1325 size
= SCHARS (string
);
1326 size_byte
= SBYTES (string
);
1329 from_char
= from_byte
= 0;
1332 CHECK_NUMBER (from
);
1333 from_char
= XINT (from
);
1337 from_byte
= string_char_to_byte (string
, from_char
);
1343 to_byte
= size_byte
;
1349 to_char
= XINT (to
);
1353 to_byte
= string_char_to_byte (string
, to_char
);
1356 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1357 args_out_of_range_3 (string
, make_number (from_char
),
1358 make_number (to_char
));
1360 return make_specified_string (SDATA (string
) + from_byte
,
1361 to_char
- from_char
, to_byte
- from_byte
,
1362 STRING_MULTIBYTE (string
));
1365 /* Extract a substring of STRING, giving start and end positions
1366 both in characters and in bytes. */
1369 substring_both (string
, from
, from_byte
, to
, to_byte
)
1371 int from
, from_byte
, to
, to_byte
;
1377 if (! (STRINGP (string
) || VECTORP (string
)))
1378 wrong_type_argument (Qarrayp
, string
);
1380 if (STRINGP (string
))
1382 size
= SCHARS (string
);
1383 size_byte
= SBYTES (string
);
1386 size
= XVECTOR (string
)->size
;
1388 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1389 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1391 if (STRINGP (string
))
1393 res
= make_specified_string (SDATA (string
) + from_byte
,
1394 to
- from
, to_byte
- from_byte
,
1395 STRING_MULTIBYTE (string
));
1396 copy_text_properties (make_number (from
), make_number (to
),
1397 string
, make_number (0), res
, Qnil
);
1400 res
= Fvector (to
- from
,
1401 XVECTOR (string
)->contents
+ from
);
1406 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1407 doc
: /* Take cdr N times on LIST, returns the result. */)
1410 register Lisp_Object list
;
1412 register int i
, num
;
1415 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1419 wrong_type_argument (Qlistp
, list
);
1425 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1426 doc
: /* Return the Nth element of LIST.
1427 N counts from zero. If LIST is not that long, nil is returned. */)
1429 Lisp_Object n
, list
;
1431 return Fcar (Fnthcdr (n
, list
));
1434 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1435 doc
: /* Return element of SEQUENCE at index N. */)
1437 register Lisp_Object sequence
, n
;
1442 if (CONSP (sequence
) || NILP (sequence
))
1443 return Fcar (Fnthcdr (n
, sequence
));
1444 else if (STRINGP (sequence
) || VECTORP (sequence
)
1445 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1446 return Faref (sequence
, n
);
1448 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1452 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1453 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1454 The value is actually the tail of LIST whose car is ELT. */)
1456 register Lisp_Object elt
;
1459 register Lisp_Object tail
;
1460 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1462 register Lisp_Object tem
;
1464 wrong_type_argument (Qlistp
, list
);
1466 if (! NILP (Fequal (elt
, tem
)))
1473 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1474 doc
: /* Return non-nil if ELT is an element of LIST.
1475 Comparison done with EQ. The value is actually the tail of LIST
1476 whose car is ELT. */)
1478 Lisp_Object elt
, list
;
1482 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1486 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1490 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1497 if (!CONSP (list
) && !NILP (list
))
1498 list
= wrong_type_argument (Qlistp
, list
);
1503 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1504 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1505 The value is actually the first element of LIST whose car is KEY.
1506 Elements of LIST that are not conses are ignored. */)
1508 Lisp_Object key
, list
;
1515 || (CONSP (XCAR (list
))
1516 && EQ (XCAR (XCAR (list
)), key
)))
1521 || (CONSP (XCAR (list
))
1522 && EQ (XCAR (XCAR (list
)), key
)))
1527 || (CONSP (XCAR (list
))
1528 && EQ (XCAR (XCAR (list
)), key
)))
1536 result
= XCAR (list
);
1537 else if (NILP (list
))
1540 result
= wrong_type_argument (Qlistp
, list
);
1545 /* Like Fassq but never report an error and do not allow quits.
1546 Use only on lists known never to be circular. */
1549 assq_no_quit (key
, list
)
1550 Lisp_Object key
, list
;
1553 && (!CONSP (XCAR (list
))
1554 || !EQ (XCAR (XCAR (list
)), key
)))
1557 return CONSP (list
) ? XCAR (list
) : Qnil
;
1560 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1561 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1562 The value is actually the first element of LIST whose car equals KEY. */)
1564 Lisp_Object key
, list
;
1566 Lisp_Object result
, car
;
1571 || (CONSP (XCAR (list
))
1572 && (car
= XCAR (XCAR (list
)),
1573 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1578 || (CONSP (XCAR (list
))
1579 && (car
= XCAR (XCAR (list
)),
1580 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1585 || (CONSP (XCAR (list
))
1586 && (car
= XCAR (XCAR (list
)),
1587 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1595 result
= XCAR (list
);
1596 else if (NILP (list
))
1599 result
= wrong_type_argument (Qlistp
, list
);
1604 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1605 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1606 The value is actually the first element of LIST whose cdr is KEY. */)
1608 register Lisp_Object key
;
1616 || (CONSP (XCAR (list
))
1617 && EQ (XCDR (XCAR (list
)), key
)))
1622 || (CONSP (XCAR (list
))
1623 && EQ (XCDR (XCAR (list
)), key
)))
1628 || (CONSP (XCAR (list
))
1629 && EQ (XCDR (XCAR (list
)), key
)))
1638 else if (CONSP (list
))
1639 result
= XCAR (list
);
1641 result
= wrong_type_argument (Qlistp
, list
);
1646 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1647 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1648 The value is actually the first element of LIST whose cdr equals KEY. */)
1650 Lisp_Object key
, list
;
1652 Lisp_Object result
, cdr
;
1657 || (CONSP (XCAR (list
))
1658 && (cdr
= XCDR (XCAR (list
)),
1659 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1664 || (CONSP (XCAR (list
))
1665 && (cdr
= XCDR (XCAR (list
)),
1666 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1671 || (CONSP (XCAR (list
))
1672 && (cdr
= XCDR (XCAR (list
)),
1673 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1681 result
= XCAR (list
);
1682 else if (NILP (list
))
1685 result
= wrong_type_argument (Qlistp
, list
);
1690 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1691 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1692 The modified LIST is returned. Comparison is done with `eq'.
1693 If the first member of LIST is ELT, there is no way to remove it by side effect;
1694 therefore, write `(setq foo (delq element foo))'
1695 to be sure of changing the value of `foo'. */)
1697 register Lisp_Object elt
;
1700 register Lisp_Object tail
, prev
;
1701 register Lisp_Object tem
;
1705 while (!NILP (tail
))
1708 wrong_type_argument (Qlistp
, list
);
1715 Fsetcdr (prev
, XCDR (tail
));
1725 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1726 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1727 SEQ must be a list, a vector, or a string.
1728 The modified SEQ is returned. Comparison is done with `equal'.
1729 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1730 is not a side effect; it is simply using a different sequence.
1731 Therefore, write `(setq foo (delete element foo))'
1732 to be sure of changing the value of `foo'. */)
1734 Lisp_Object elt
, seq
;
1740 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1741 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1744 if (n
!= ASIZE (seq
))
1746 struct Lisp_Vector
*p
= allocate_vector (n
);
1748 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1749 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1750 p
->contents
[n
++] = AREF (seq
, i
);
1752 XSETVECTOR (seq
, p
);
1755 else if (STRINGP (seq
))
1757 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1760 for (i
= nchars
= nbytes
= ibyte
= 0;
1762 ++i
, ibyte
+= cbytes
)
1764 if (STRING_MULTIBYTE (seq
))
1766 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1767 SBYTES (seq
) - ibyte
);
1768 cbytes
= CHAR_BYTES (c
);
1776 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1783 if (nchars
!= SCHARS (seq
))
1787 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1788 if (!STRING_MULTIBYTE (seq
))
1789 STRING_SET_UNIBYTE (tem
);
1791 for (i
= nchars
= nbytes
= ibyte
= 0;
1793 ++i
, ibyte
+= cbytes
)
1795 if (STRING_MULTIBYTE (seq
))
1797 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1798 SBYTES (seq
) - ibyte
);
1799 cbytes
= CHAR_BYTES (c
);
1807 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1809 unsigned char *from
= SDATA (seq
) + ibyte
;
1810 unsigned char *to
= SDATA (tem
) + nbytes
;
1816 for (n
= cbytes
; n
--; )
1826 Lisp_Object tail
, prev
;
1828 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1831 wrong_type_argument (Qlistp
, seq
);
1833 if (!NILP (Fequal (elt
, XCAR (tail
))))
1838 Fsetcdr (prev
, XCDR (tail
));
1849 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1850 doc
: /* Reverse LIST by modifying cdr pointers.
1851 Return the reversed list. */)
1855 register Lisp_Object prev
, tail
, next
;
1857 if (NILP (list
)) return list
;
1860 while (!NILP (tail
))
1864 wrong_type_argument (Qlistp
, list
);
1866 Fsetcdr (tail
, prev
);
1873 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1874 doc
: /* Reverse LIST, copying. Return the reversed list.
1875 See also the function `nreverse', which is used more often. */)
1881 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1884 new = Fcons (XCAR (list
), new);
1887 wrong_type_argument (Qconsp
, list
);
1891 Lisp_Object
merge ();
1893 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1894 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1895 Returns the sorted list. LIST is modified by side effects.
1896 PREDICATE is called with two elements of LIST, and should return t
1897 if the first element is "less" than the second. */)
1899 Lisp_Object list
, predicate
;
1901 Lisp_Object front
, back
;
1902 register Lisp_Object len
, tem
;
1903 struct gcpro gcpro1
, gcpro2
;
1904 register int length
;
1907 len
= Flength (list
);
1908 length
= XINT (len
);
1912 XSETINT (len
, (length
/ 2) - 1);
1913 tem
= Fnthcdr (len
, list
);
1915 Fsetcdr (tem
, Qnil
);
1917 GCPRO2 (front
, back
);
1918 front
= Fsort (front
, predicate
);
1919 back
= Fsort (back
, predicate
);
1921 return merge (front
, back
, predicate
);
1925 merge (org_l1
, org_l2
, pred
)
1926 Lisp_Object org_l1
, org_l2
;
1930 register Lisp_Object tail
;
1932 register Lisp_Object l1
, l2
;
1933 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1940 /* It is sufficient to protect org_l1 and org_l2.
1941 When l1 and l2 are updated, we copy the new values
1942 back into the org_ vars. */
1943 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1963 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1979 Fsetcdr (tail
, tem
);
1985 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1986 doc
: /* Extract a value from a property list.
1987 PLIST is a property list, which is a list of the form
1988 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1989 corresponding to the given PROP, or nil if PROP is not
1990 one of the properties on the list. */)
1998 CONSP (tail
) && CONSP (XCDR (tail
));
1999 tail
= XCDR (XCDR (tail
)))
2001 if (EQ (prop
, XCAR (tail
)))
2002 return XCAR (XCDR (tail
));
2004 /* This function can be called asynchronously
2005 (setup_coding_system). Don't QUIT in that case. */
2006 if (!interrupt_input_blocked
)
2011 wrong_type_argument (Qlistp
, prop
);
2016 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2017 doc
: /* Return the value of SYMBOL's PROPNAME property.
2018 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2020 Lisp_Object symbol
, propname
;
2022 CHECK_SYMBOL (symbol
);
2023 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2026 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2027 doc
: /* Change value in PLIST of PROP to VAL.
2028 PLIST is a property list, which is a list of the form
2029 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2030 If PROP is already a property on the list, its value is set to VAL,
2031 otherwise the new PROP VAL pair is added. The new plist is returned;
2032 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2033 The PLIST is modified by side effects. */)
2036 register Lisp_Object prop
;
2039 register Lisp_Object tail
, prev
;
2040 Lisp_Object newcell
;
2042 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2043 tail
= XCDR (XCDR (tail
)))
2045 if (EQ (prop
, XCAR (tail
)))
2047 Fsetcar (XCDR (tail
), val
);
2054 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2058 Fsetcdr (XCDR (prev
), newcell
);
2062 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2063 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2064 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2065 (symbol
, propname
, value
)
2066 Lisp_Object symbol
, propname
, value
;
2068 CHECK_SYMBOL (symbol
);
2069 XSYMBOL (symbol
)->plist
2070 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2074 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2075 doc
: /* Extract a value from a property list, comparing with `equal'.
2076 PLIST is a property list, which is a list of the form
2077 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2078 corresponding to the given PROP, or nil if PROP is not
2079 one of the properties on the list. */)
2087 CONSP (tail
) && CONSP (XCDR (tail
));
2088 tail
= XCDR (XCDR (tail
)))
2090 if (! NILP (Fequal (prop
, XCAR (tail
))))
2091 return XCAR (XCDR (tail
));
2097 wrong_type_argument (Qlistp
, prop
);
2102 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2103 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2104 PLIST is a property list, which is a list of the form
2105 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2106 If PROP is already a property on the list, its value is set to VAL,
2107 otherwise the new PROP VAL pair is added. The new plist is returned;
2108 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2109 The PLIST is modified by side effects. */)
2112 register Lisp_Object prop
;
2115 register Lisp_Object tail
, prev
;
2116 Lisp_Object newcell
;
2118 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2119 tail
= XCDR (XCDR (tail
)))
2121 if (! NILP (Fequal (prop
, XCAR (tail
))))
2123 Fsetcar (XCDR (tail
), val
);
2130 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2134 Fsetcdr (XCDR (prev
), newcell
);
2138 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2139 doc
: /* Return t if two Lisp objects have similar structure and contents.
2140 They must have the same data type.
2141 Conses are compared by comparing the cars and the cdrs.
2142 Vectors and strings are compared element by element.
2143 Numbers are compared by value, but integers cannot equal floats.
2144 (Use `=' if you want integers and floats to be able to be equal.)
2145 Symbols must match exactly. */)
2147 register Lisp_Object o1
, o2
;
2149 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2153 internal_equal (o1
, o2
, depth
)
2154 register Lisp_Object o1
, o2
;
2158 error ("Stack overflow in equal");
2164 if (XTYPE (o1
) != XTYPE (o2
))
2173 d1
= extract_float (o1
);
2174 d2
= extract_float (o2
);
2175 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2176 though they are not =. */
2177 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2181 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2188 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2192 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2194 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2197 o1
= XOVERLAY (o1
)->plist
;
2198 o2
= XOVERLAY (o2
)->plist
;
2203 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2204 && (XMARKER (o1
)->buffer
== 0
2205 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2209 case Lisp_Vectorlike
:
2212 EMACS_INT size
= XVECTOR (o1
)->size
;
2213 /* Pseudovectors have the type encoded in the size field, so this test
2214 actually checks that the objects have the same type as well as the
2216 if (XVECTOR (o2
)->size
!= size
)
2218 /* Boolvectors are compared much like strings. */
2219 if (BOOL_VECTOR_P (o1
))
2222 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2224 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2226 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2231 if (WINDOW_CONFIGURATIONP (o1
))
2232 return compare_window_configurations (o1
, o2
, 0);
2234 /* Aside from them, only true vectors, char-tables, and compiled
2235 functions are sensible to compare, so eliminate the others now. */
2236 if (size
& PSEUDOVECTOR_FLAG
)
2238 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2240 size
&= PSEUDOVECTOR_SIZE_MASK
;
2242 for (i
= 0; i
< size
; i
++)
2245 v1
= XVECTOR (o1
)->contents
[i
];
2246 v2
= XVECTOR (o2
)->contents
[i
];
2247 if (!internal_equal (v1
, v2
, depth
+ 1))
2255 if (SCHARS (o1
) != SCHARS (o2
))
2257 if (SBYTES (o1
) != SBYTES (o2
))
2259 if (bcmp (SDATA (o1
), SDATA (o2
),
2266 case Lisp_Type_Limit
:
2273 extern Lisp_Object
Fmake_char_internal ();
2275 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2276 doc
: /* Store each element of ARRAY with ITEM.
2277 ARRAY is a vector, string, char-table, or bool-vector. */)
2279 Lisp_Object array
, item
;
2281 register int size
, index
, charval
;
2283 if (VECTORP (array
))
2285 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2286 size
= XVECTOR (array
)->size
;
2287 for (index
= 0; index
< size
; index
++)
2290 else if (CHAR_TABLE_P (array
))
2292 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2293 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2294 for (index
= 0; index
< size
; index
++)
2296 XCHAR_TABLE (array
)->defalt
= Qnil
;
2298 else if (STRINGP (array
))
2300 register unsigned char *p
= SDATA (array
);
2301 CHECK_NUMBER (item
);
2302 charval
= XINT (item
);
2303 size
= SCHARS (array
);
2304 if (STRING_MULTIBYTE (array
))
2306 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2307 int len
= CHAR_STRING (charval
, str
);
2308 int size_byte
= SBYTES (array
);
2309 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2312 if (size
!= size_byte
)
2315 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2316 if (len
!= this_len
)
2317 error ("Attempt to change byte length of a string");
2320 for (i
= 0; i
< size_byte
; i
++)
2321 *p
++ = str
[i
% len
];
2324 for (index
= 0; index
< size
; index
++)
2327 else if (BOOL_VECTOR_P (array
))
2329 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2331 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2333 charval
= (! NILP (item
) ? -1 : 0);
2334 for (index
= 0; index
< size_in_chars
- 1; index
++)
2336 if (index
< size_in_chars
)
2338 /* Mask out bits beyond the vector size. */
2339 if (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)
2340 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)) - 1;
2346 array
= wrong_type_argument (Qarrayp
, array
);
2352 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2354 doc
: /* Clear the contents of STRING.
2355 This makes STRING unibyte and may change its length. */)
2359 int len
= SBYTES (string
);
2360 bzero (SDATA (string
), len
);
2361 STRING_SET_CHARS (string
, len
);
2362 STRING_SET_UNIBYTE (string
);
2366 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2368 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2370 Lisp_Object char_table
;
2372 CHECK_CHAR_TABLE (char_table
);
2374 return XCHAR_TABLE (char_table
)->purpose
;
2377 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2379 doc
: /* Return the parent char-table of CHAR-TABLE.
2380 The value is either nil or another char-table.
2381 If CHAR-TABLE holds nil for a given character,
2382 then the actual applicable value is inherited from the parent char-table
2383 \(or from its parents, if necessary). */)
2385 Lisp_Object char_table
;
2387 CHECK_CHAR_TABLE (char_table
);
2389 return XCHAR_TABLE (char_table
)->parent
;
2392 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2394 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2395 Return PARENT. PARENT must be either nil or another char-table. */)
2396 (char_table
, parent
)
2397 Lisp_Object char_table
, parent
;
2401 CHECK_CHAR_TABLE (char_table
);
2405 CHECK_CHAR_TABLE (parent
);
2407 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2408 if (EQ (temp
, char_table
))
2409 error ("Attempt to make a chartable be its own parent");
2412 XCHAR_TABLE (char_table
)->parent
= parent
;
2417 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2419 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2421 Lisp_Object char_table
, n
;
2423 CHECK_CHAR_TABLE (char_table
);
2426 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2427 args_out_of_range (char_table
, n
);
2429 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2432 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2433 Sset_char_table_extra_slot
,
2435 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2436 (char_table
, n
, value
)
2437 Lisp_Object char_table
, n
, value
;
2439 CHECK_CHAR_TABLE (char_table
);
2442 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2443 args_out_of_range (char_table
, n
);
2445 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2448 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2450 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2451 RANGE should be nil (for the default value)
2452 a vector which identifies a character set or a row of a character set,
2453 a character set name, or a character code. */)
2455 Lisp_Object char_table
, range
;
2457 CHECK_CHAR_TABLE (char_table
);
2459 if (EQ (range
, Qnil
))
2460 return XCHAR_TABLE (char_table
)->defalt
;
2461 else if (INTEGERP (range
))
2462 return Faref (char_table
, range
);
2463 else if (SYMBOLP (range
))
2465 Lisp_Object charset_info
;
2467 charset_info
= Fget (range
, Qcharset
);
2468 CHECK_VECTOR (charset_info
);
2470 return Faref (char_table
,
2471 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2474 else if (VECTORP (range
))
2476 if (XVECTOR (range
)->size
== 1)
2477 return Faref (char_table
,
2478 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2481 int size
= XVECTOR (range
)->size
;
2482 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2483 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2484 size
<= 1 ? Qnil
: val
[1],
2485 size
<= 2 ? Qnil
: val
[2]);
2486 return Faref (char_table
, ch
);
2490 error ("Invalid RANGE argument to `char-table-range'");
2494 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2496 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2497 RANGE should be t (for all characters), nil (for the default value),
2498 a character set, a vector which identifies a character set, a row of a
2499 character set, or a character code. Return VALUE. */)
2500 (char_table
, range
, value
)
2501 Lisp_Object char_table
, range
, value
;
2505 CHECK_CHAR_TABLE (char_table
);
2508 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2509 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2510 else if (EQ (range
, Qnil
))
2511 XCHAR_TABLE (char_table
)->defalt
= value
;
2512 else if (SYMBOLP (range
))
2514 Lisp_Object charset_info
;
2516 charset_info
= Fget (range
, Qcharset
);
2517 CHECK_VECTOR (charset_info
);
2519 return Faset (char_table
,
2520 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2524 else if (INTEGERP (range
))
2525 Faset (char_table
, range
, value
);
2526 else if (VECTORP (range
))
2528 if (XVECTOR (range
)->size
== 1)
2529 return Faset (char_table
,
2530 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2534 int size
= XVECTOR (range
)->size
;
2535 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2536 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2537 size
<= 1 ? Qnil
: val
[1],
2538 size
<= 2 ? Qnil
: val
[2]);
2539 return Faset (char_table
, ch
, value
);
2543 error ("Invalid RANGE argument to `set-char-table-range'");
2548 DEFUN ("set-char-table-default", Fset_char_table_default
,
2549 Sset_char_table_default
, 3, 3, 0,
2550 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2551 The generic character specifies the group of characters.
2552 See also the documentation of `make-char'. */)
2553 (char_table
, ch
, value
)
2554 Lisp_Object char_table
, ch
, value
;
2556 int c
, charset
, code1
, code2
;
2559 CHECK_CHAR_TABLE (char_table
);
2563 SPLIT_CHAR (c
, charset
, code1
, code2
);
2565 /* Since we may want to set the default value for a character set
2566 not yet defined, we check only if the character set is in the
2567 valid range or not, instead of it is already defined or not. */
2568 if (! CHARSET_VALID_P (charset
))
2569 invalid_character (c
);
2571 if (charset
== CHARSET_ASCII
)
2572 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2574 /* Even if C is not a generic char, we had better behave as if a
2575 generic char is specified. */
2576 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2578 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2581 if (SUB_CHAR_TABLE_P (temp
))
2582 XCHAR_TABLE (temp
)->defalt
= value
;
2584 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2587 if (SUB_CHAR_TABLE_P (temp
))
2590 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2591 = make_sub_char_table (temp
));
2592 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2593 if (SUB_CHAR_TABLE_P (temp
))
2594 XCHAR_TABLE (temp
)->defalt
= value
;
2596 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2600 /* Look up the element in TABLE at index CH,
2601 and return it as an integer.
2602 If the element is nil, return CH itself.
2603 (Actually we do that for any non-integer.) */
2606 char_table_translate (table
, ch
)
2611 value
= Faref (table
, make_number (ch
));
2612 if (! INTEGERP (value
))
2614 return XINT (value
);
2618 optimize_sub_char_table (table
, chars
)
2626 from
= 33, to
= 127;
2628 from
= 32, to
= 128;
2630 if (!SUB_CHAR_TABLE_P (*table
))
2632 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2633 for (; from
< to
; from
++)
2634 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2639 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2640 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2648 CHECK_CHAR_TABLE (table
);
2650 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2652 elt
= XCHAR_TABLE (table
)->contents
[i
];
2653 if (!SUB_CHAR_TABLE_P (elt
))
2655 dim
= CHARSET_DIMENSION (i
- 128);
2657 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2658 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2659 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2665 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2666 character or group of characters that share a value.
2667 DEPTH is the current depth in the originally specified
2668 chartable, and INDICES contains the vector indices
2669 for the levels our callers have descended.
2671 ARG is passed to C_FUNCTION when that is called. */
2674 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2675 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2676 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2683 /* At first, handle ASCII and 8-bit European characters. */
2684 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2686 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2688 elt
= XCHAR_TABLE (subtable
)->defalt
;
2690 elt
= Faref (subtable
, make_number (i
));
2692 (*c_function
) (arg
, make_number (i
), elt
);
2694 call2 (function
, make_number (i
), elt
);
2696 #if 0 /* If the char table has entries for higher characters,
2697 we should report them. */
2698 if (NILP (current_buffer
->enable_multibyte_characters
))
2701 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2705 int charset
= XFASTINT (indices
[0]) - 128;
2708 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2709 if (CHARSET_CHARS (charset
) == 94)
2718 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2719 XSETFASTINT (indices
[depth
], i
);
2720 charset
= XFASTINT (indices
[0]) - 128;
2722 && (!CHARSET_DEFINED_P (charset
)
2723 || charset
== CHARSET_8_BIT_CONTROL
2724 || charset
== CHARSET_8_BIT_GRAPHIC
))
2727 if (SUB_CHAR_TABLE_P (elt
))
2730 error ("Too deep char table");
2731 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2737 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2738 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2739 c
= MAKE_CHAR (charset
, c1
, c2
);
2742 elt
= XCHAR_TABLE (subtable
)->defalt
;
2744 elt
= Faref (table
, make_number (c
));
2747 (*c_function
) (arg
, make_number (c
), elt
);
2749 call2 (function
, make_number (c
), elt
);
2754 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2756 void_call2 (a
, b
, c
)
2757 Lisp_Object a
, b
, c
;
2762 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2764 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2765 FUNCTION is called with two arguments--a key and a value.
2766 The key is always a possible IDX argument to `aref'. */)
2767 (function
, char_table
)
2768 Lisp_Object function
, char_table
;
2770 /* The depth of char table is at most 3. */
2771 Lisp_Object indices
[3];
2773 CHECK_CHAR_TABLE (char_table
);
2775 /* When Lisp_Object is represented as a union, `call2' cannot directly
2776 be passed to map_char_table because it returns a Lisp_Object rather
2777 than returning nothing.
2778 Casting leads to crashes on some architectures. -stef */
2779 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2783 /* Return a value for character C in char-table TABLE. Store the
2784 actual index for that value in *IDX. Ignore the default value of
2788 char_table_ref_and_index (table
, c
, idx
)
2792 int charset
, c1
, c2
;
2795 if (SINGLE_BYTE_CHAR_P (c
))
2798 return XCHAR_TABLE (table
)->contents
[c
];
2800 SPLIT_CHAR (c
, charset
, c1
, c2
);
2801 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2802 *idx
= MAKE_CHAR (charset
, 0, 0);
2803 if (!SUB_CHAR_TABLE_P (elt
))
2805 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2806 return XCHAR_TABLE (elt
)->defalt
;
2807 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2808 *idx
= MAKE_CHAR (charset
, c1
, 0);
2809 if (!SUB_CHAR_TABLE_P (elt
))
2811 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2812 return XCHAR_TABLE (elt
)->defalt
;
2814 return XCHAR_TABLE (elt
)->contents
[c2
];
2824 Lisp_Object args
[2];
2827 return Fnconc (2, args
);
2829 return Fnconc (2, &s1
);
2830 #endif /* NO_ARG_ARRAY */
2833 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2834 doc
: /* Concatenate any number of lists by altering them.
2835 Only the last argument is not altered, and need not be a list.
2836 usage: (nconc &rest LISTS) */)
2841 register int argnum
;
2842 register Lisp_Object tail
, tem
, val
;
2846 for (argnum
= 0; argnum
< nargs
; argnum
++)
2849 if (NILP (tem
)) continue;
2854 if (argnum
+ 1 == nargs
) break;
2857 tem
= wrong_type_argument (Qlistp
, tem
);
2866 tem
= args
[argnum
+ 1];
2867 Fsetcdr (tail
, tem
);
2869 args
[argnum
+ 1] = tail
;
2875 /* This is the guts of all mapping functions.
2876 Apply FN to each element of SEQ, one by one,
2877 storing the results into elements of VALS, a C vector of Lisp_Objects.
2878 LENI is the length of VALS, which should also be the length of SEQ. */
2881 mapcar1 (leni
, vals
, fn
, seq
)
2884 Lisp_Object fn
, seq
;
2886 register Lisp_Object tail
;
2889 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2893 /* Don't let vals contain any garbage when GC happens. */
2894 for (i
= 0; i
< leni
; i
++)
2897 GCPRO3 (dummy
, fn
, seq
);
2899 gcpro1
.nvars
= leni
;
2903 /* We need not explicitly protect `tail' because it is used only on lists, and
2904 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2908 for (i
= 0; i
< leni
; i
++)
2910 dummy
= XVECTOR (seq
)->contents
[i
];
2911 dummy
= call1 (fn
, dummy
);
2916 else if (BOOL_VECTOR_P (seq
))
2918 for (i
= 0; i
< leni
; i
++)
2921 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2922 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2927 dummy
= call1 (fn
, dummy
);
2932 else if (STRINGP (seq
))
2936 for (i
= 0, i_byte
= 0; i
< leni
;)
2941 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2942 XSETFASTINT (dummy
, c
);
2943 dummy
= call1 (fn
, dummy
);
2945 vals
[i_before
] = dummy
;
2948 else /* Must be a list, since Flength did not get an error */
2951 for (i
= 0; i
< leni
; i
++)
2953 dummy
= call1 (fn
, Fcar (tail
));
2963 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2964 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2965 In between each pair of results, stick in SEPARATOR. Thus, " " as
2966 SEPARATOR results in spaces between the values returned by FUNCTION.
2967 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2968 (function
, sequence
, separator
)
2969 Lisp_Object function
, sequence
, separator
;
2974 register Lisp_Object
*args
;
2976 struct gcpro gcpro1
;
2978 len
= Flength (sequence
);
2980 nargs
= leni
+ leni
- 1;
2981 if (nargs
< 0) return build_string ("");
2983 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2986 mapcar1 (leni
, args
, function
, sequence
);
2989 for (i
= leni
- 1; i
>= 0; i
--)
2990 args
[i
+ i
] = args
[i
];
2992 for (i
= 1; i
< nargs
; i
+= 2)
2993 args
[i
] = separator
;
2995 return Fconcat (nargs
, args
);
2998 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2999 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3000 The result is a list just as long as SEQUENCE.
3001 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3002 (function
, sequence
)
3003 Lisp_Object function
, sequence
;
3005 register Lisp_Object len
;
3007 register Lisp_Object
*args
;
3009 len
= Flength (sequence
);
3010 leni
= XFASTINT (len
);
3011 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
3013 mapcar1 (leni
, args
, function
, sequence
);
3015 return Flist (leni
, args
);
3018 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3019 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3020 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3021 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3022 (function
, sequence
)
3023 Lisp_Object function
, sequence
;
3027 leni
= XFASTINT (Flength (sequence
));
3028 mapcar1 (leni
, 0, function
, sequence
);
3033 /* Anything that calls this function must protect from GC! */
3035 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3036 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3037 Takes one argument, which is the string to display to ask the question.
3038 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3039 No confirmation of the answer is requested; a single character is enough.
3040 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3041 the bindings in `query-replace-map'; see the documentation of that variable
3042 for more information. In this case, the useful bindings are `act', `skip',
3043 `recenter', and `quit'.\)
3045 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3046 is nil and `use-dialog-box' is non-nil. */)
3050 register Lisp_Object obj
, key
, def
, map
;
3051 register int answer
;
3052 Lisp_Object xprompt
;
3053 Lisp_Object args
[2];
3054 struct gcpro gcpro1
, gcpro2
;
3055 int count
= SPECPDL_INDEX ();
3057 specbind (Qcursor_in_echo_area
, Qt
);
3059 map
= Fsymbol_value (intern ("query-replace-map"));
3061 CHECK_STRING (prompt
);
3063 GCPRO2 (prompt
, xprompt
);
3065 #ifdef HAVE_X_WINDOWS
3066 if (display_hourglass_p
)
3067 cancel_hourglass ();
3074 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3078 Lisp_Object pane
, menu
;
3079 redisplay_preserve_echo_area (3);
3080 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3081 Fcons (Fcons (build_string ("No"), Qnil
),
3083 menu
= Fcons (prompt
, pane
);
3084 obj
= Fx_popup_dialog (Qt
, menu
);
3085 answer
= !NILP (obj
);
3088 #endif /* HAVE_MENUS */
3089 cursor_in_echo_area
= 1;
3090 choose_minibuf_frame ();
3093 Lisp_Object pargs
[3];
3095 /* Colorize prompt according to `minibuffer-prompt' face. */
3096 pargs
[0] = build_string ("%s(y or n) ");
3097 pargs
[1] = intern ("face");
3098 pargs
[2] = intern ("minibuffer-prompt");
3099 args
[0] = Fpropertize (3, pargs
);
3104 if (minibuffer_auto_raise
)
3106 Lisp_Object mini_frame
;
3108 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3110 Fraise_frame (mini_frame
);
3113 obj
= read_filtered_event (1, 0, 0, 0);
3114 cursor_in_echo_area
= 0;
3115 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3118 key
= Fmake_vector (make_number (1), obj
);
3119 def
= Flookup_key (map
, key
, Qt
);
3121 if (EQ (def
, intern ("skip")))
3126 else if (EQ (def
, intern ("act")))
3131 else if (EQ (def
, intern ("recenter")))
3137 else if (EQ (def
, intern ("quit")))
3139 /* We want to exit this command for exit-prefix,
3140 and this is the only way to do it. */
3141 else if (EQ (def
, intern ("exit-prefix")))
3146 /* If we don't clear this, then the next call to read_char will
3147 return quit_char again, and we'll enter an infinite loop. */
3152 if (EQ (xprompt
, prompt
))
3154 args
[0] = build_string ("Please answer y or n. ");
3156 xprompt
= Fconcat (2, args
);
3161 if (! noninteractive
)
3163 cursor_in_echo_area
= -1;
3164 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3168 unbind_to (count
, Qnil
);
3169 return answer
? Qt
: Qnil
;
3172 /* This is how C code calls `yes-or-no-p' and allows the user
3175 Anything that calls this function must protect from GC! */
3178 do_yes_or_no_p (prompt
)
3181 return call1 (intern ("yes-or-no-p"), prompt
);
3184 /* Anything that calls this function must protect from GC! */
3186 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3187 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3188 Takes one argument, which is the string to display to ask the question.
3189 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3190 The user must confirm the answer with RET,
3191 and can edit it until it has been confirmed.
3193 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3194 is nil, and `use-dialog-box' is non-nil. */)
3198 register Lisp_Object ans
;
3199 Lisp_Object args
[2];
3200 struct gcpro gcpro1
;
3202 CHECK_STRING (prompt
);
3205 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3209 Lisp_Object pane
, menu
, obj
;
3210 redisplay_preserve_echo_area (4);
3211 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3212 Fcons (Fcons (build_string ("No"), Qnil
),
3215 menu
= Fcons (prompt
, pane
);
3216 obj
= Fx_popup_dialog (Qt
, menu
);
3220 #endif /* HAVE_MENUS */
3223 args
[1] = build_string ("(yes or no) ");
3224 prompt
= Fconcat (2, args
);
3230 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3231 Qyes_or_no_p_history
, Qnil
,
3233 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3238 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3246 message ("Please answer yes or no.");
3247 Fsleep_for (make_number (2), Qnil
);
3251 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3252 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3254 Each of the three load averages is multiplied by 100, then converted
3257 When USE-FLOATS is non-nil, floats will be used instead of integers.
3258 These floats are not multiplied by 100.
3260 If the 5-minute or 15-minute load averages are not available, return a
3261 shortened list, containing only those averages which are available.
3263 An error is thrown if the load average can't be obtained. In some
3264 cases making it work would require Emacs being installed setuid or
3265 setgid so that it can read kernel information, and that usually isn't
3268 Lisp_Object use_floats
;
3271 int loads
= getloadavg (load_ave
, 3);
3272 Lisp_Object ret
= Qnil
;
3275 error ("load-average not implemented for this operating system");
3279 Lisp_Object load
= (NILP (use_floats
) ?
3280 make_number ((int) (100.0 * load_ave
[loads
]))
3281 : make_float (load_ave
[loads
]));
3282 ret
= Fcons (load
, ret
);
3288 Lisp_Object Vfeatures
, Qsubfeatures
;
3289 extern Lisp_Object Vafter_load_alist
;
3291 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3292 doc
: /* Returns t if FEATURE is present in this Emacs.
3294 Use this to conditionalize execution of lisp code based on the
3295 presence or absence of emacs or environment extensions.
3296 Use `provide' to declare that a feature is available. This function
3297 looks at the value of the variable `features'. The optional argument
3298 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3299 (feature
, subfeature
)
3300 Lisp_Object feature
, subfeature
;
3302 register Lisp_Object tem
;
3303 CHECK_SYMBOL (feature
);
3304 tem
= Fmemq (feature
, Vfeatures
);
3305 if (!NILP (tem
) && !NILP (subfeature
))
3306 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3307 return (NILP (tem
)) ? Qnil
: Qt
;
3310 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3311 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3312 The optional argument SUBFEATURES should be a list of symbols listing
3313 particular subfeatures supported in this version of FEATURE. */)
3314 (feature
, subfeatures
)
3315 Lisp_Object feature
, subfeatures
;
3317 register Lisp_Object tem
;
3318 CHECK_SYMBOL (feature
);
3319 CHECK_LIST (subfeatures
);
3320 if (!NILP (Vautoload_queue
))
3321 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3322 tem
= Fmemq (feature
, Vfeatures
);
3324 Vfeatures
= Fcons (feature
, Vfeatures
);
3325 if (!NILP (subfeatures
))
3326 Fput (feature
, Qsubfeatures
, subfeatures
);
3327 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3329 /* Run any load-hooks for this file. */
3330 tem
= Fassq (feature
, Vafter_load_alist
);
3332 Fprogn (XCDR (tem
));
3337 /* `require' and its subroutines. */
3339 /* List of features currently being require'd, innermost first. */
3341 Lisp_Object require_nesting_list
;
3344 require_unwind (old_value
)
3345 Lisp_Object old_value
;
3347 return require_nesting_list
= old_value
;
3350 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3351 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3352 If FEATURE is not a member of the list `features', then the feature
3353 is not loaded; so load the file FILENAME.
3354 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3355 and `load' will try to load this name appended with the suffix `.elc' or
3356 `.el', in that order. The name without appended suffix will not be used.
3357 If the optional third argument NOERROR is non-nil,
3358 then return nil if the file is not found instead of signaling an error.
3359 Normally the return value is FEATURE.
3360 The normal messages at start and end of loading FILENAME are suppressed. */)
3361 (feature
, filename
, noerror
)
3362 Lisp_Object feature
, filename
, noerror
;
3364 register Lisp_Object tem
;
3365 struct gcpro gcpro1
, gcpro2
;
3367 CHECK_SYMBOL (feature
);
3369 tem
= Fmemq (feature
, Vfeatures
);
3373 int count
= SPECPDL_INDEX ();
3376 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3378 /* This is to make sure that loadup.el gives a clear picture
3379 of what files are preloaded and when. */
3380 if (! NILP (Vpurify_flag
))
3381 error ("(require %s) while preparing to dump",
3382 SDATA (SYMBOL_NAME (feature
)));
3384 /* A certain amount of recursive `require' is legitimate,
3385 but if we require the same feature recursively 3 times,
3387 tem
= require_nesting_list
;
3388 while (! NILP (tem
))
3390 if (! NILP (Fequal (feature
, XCAR (tem
))))
3395 error ("Recursive `require' for feature `%s'",
3396 SDATA (SYMBOL_NAME (feature
)));
3398 /* Update the list for any nested `require's that occur. */
3399 record_unwind_protect (require_unwind
, require_nesting_list
);
3400 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3402 /* Value saved here is to be restored into Vautoload_queue */
3403 record_unwind_protect (un_autoload
, Vautoload_queue
);
3404 Vautoload_queue
= Qt
;
3406 /* Load the file. */
3407 GCPRO2 (feature
, filename
);
3408 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3409 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3412 /* If load failed entirely, return nil. */
3414 return unbind_to (count
, Qnil
);
3416 tem
= Fmemq (feature
, Vfeatures
);
3418 error ("Required feature `%s' was not provided",
3419 SDATA (SYMBOL_NAME (feature
)));
3421 /* Once loading finishes, don't undo it. */
3422 Vautoload_queue
= Qt
;
3423 feature
= unbind_to (count
, feature
);
3429 /* Primitives for work of the "widget" library.
3430 In an ideal world, this section would not have been necessary.
3431 However, lisp function calls being as slow as they are, it turns
3432 out that some functions in the widget library (wid-edit.el) are the
3433 bottleneck of Widget operation. Here is their translation to C,
3434 for the sole reason of efficiency. */
3436 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3437 doc
: /* Return non-nil if PLIST has the property PROP.
3438 PLIST is a property list, which is a list of the form
3439 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3440 Unlike `plist-get', this allows you to distinguish between a missing
3441 property and a property with the value nil.
3442 The value is actually the tail of PLIST whose car is PROP. */)
3444 Lisp_Object plist
, prop
;
3446 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3449 plist
= XCDR (plist
);
3450 plist
= CDR (plist
);
3455 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3456 doc
: /* In WIDGET, set PROPERTY to VALUE.
3457 The value can later be retrieved with `widget-get'. */)
3458 (widget
, property
, value
)
3459 Lisp_Object widget
, property
, value
;
3461 CHECK_CONS (widget
);
3462 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3466 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3467 doc
: /* In WIDGET, get the value of PROPERTY.
3468 The value could either be specified when the widget was created, or
3469 later with `widget-put'. */)
3471 Lisp_Object widget
, property
;
3479 CHECK_CONS (widget
);
3480 tmp
= Fplist_member (XCDR (widget
), property
);
3486 tmp
= XCAR (widget
);
3489 widget
= Fget (tmp
, Qwidget_type
);
3493 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3494 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3495 ARGS are passed as extra arguments to the function.
3496 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3501 /* This function can GC. */
3502 Lisp_Object newargs
[3];
3503 struct gcpro gcpro1
, gcpro2
;
3506 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3507 newargs
[1] = args
[0];
3508 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3509 GCPRO2 (newargs
[0], newargs
[2]);
3510 result
= Fapply (3, newargs
);
3515 #ifdef HAVE_LANGINFO_CODESET
3516 #include <langinfo.h>
3519 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3520 doc
: /* Access locale data ITEM for the current C locale, if available.
3521 ITEM should be one of the following:
3523 `codeset', returning the character set as a string (locale item CODESET);
3525 `days', returning a 7-element vector of day names (locale items DAY_n);
3527 `months', returning a 12-element vector of month names (locale items MON_n);
3529 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3530 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3532 If the system can't provide such information through a call to
3533 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3535 See also Info node `(libc)Locales'.
3537 The data read from the system are decoded using `locale-coding-system'. */)
3542 #ifdef HAVE_LANGINFO_CODESET
3544 if (EQ (item
, Qcodeset
))
3546 str
= nl_langinfo (CODESET
);
3547 return build_string (str
);
3550 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3552 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3553 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3555 synchronize_system_time_locale ();
3556 for (i
= 0; i
< 7; i
++)
3558 str
= nl_langinfo (days
[i
]);
3559 val
= make_unibyte_string (str
, strlen (str
));
3560 /* Fixme: Is this coding system necessarily right, even if
3561 it is consistent with CODESET? If not, what to do? */
3562 Faset (v
, make_number (i
),
3563 code_convert_string_norecord (val
, Vlocale_coding_system
,
3570 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3572 struct Lisp_Vector
*p
= allocate_vector (12);
3573 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3574 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3576 synchronize_system_time_locale ();
3577 for (i
= 0; i
< 12; i
++)
3579 str
= nl_langinfo (months
[i
]);
3580 val
= make_unibyte_string (str
, strlen (str
));
3582 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3584 XSETVECTOR (val
, p
);
3588 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3589 but is in the locale files. This could be used by ps-print. */
3591 else if (EQ (item
, Qpaper
))
3593 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3594 make_number (nl_langinfo (PAPER_HEIGHT
)));
3596 #endif /* PAPER_WIDTH */
3597 #endif /* HAVE_LANGINFO_CODESET*/
3601 /* base64 encode/decode functions (RFC 2045).
3602 Based on code from GNU recode. */
3604 #define MIME_LINE_LENGTH 76
3606 #define IS_ASCII(Character) \
3608 #define IS_BASE64(Character) \
3609 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3610 #define IS_BASE64_IGNORABLE(Character) \
3611 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3612 || (Character) == '\f' || (Character) == '\r')
3614 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3615 character or return retval if there are no characters left to
3617 #define READ_QUADRUPLET_BYTE(retval) \
3622 if (nchars_return) \
3623 *nchars_return = nchars; \
3628 while (IS_BASE64_IGNORABLE (c))
3630 /* Don't use alloca for regions larger than this, lest we overflow
3632 #define MAX_ALLOCA 16*1024
3634 /* Table of characters coding the 64 values. */
3635 static char base64_value_to_char
[64] =
3637 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3638 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3639 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3640 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3641 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3642 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3643 '8', '9', '+', '/' /* 60-63 */
3646 /* Table of base64 values for first 128 characters. */
3647 static short base64_char_to_value
[128] =
3649 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3650 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3651 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3652 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3653 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3654 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3655 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3656 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3657 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3658 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3659 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3660 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3661 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3664 /* The following diagram shows the logical steps by which three octets
3665 get transformed into four base64 characters.
3667 .--------. .--------. .--------.
3668 |aaaaaabb| |bbbbcccc| |ccdddddd|
3669 `--------' `--------' `--------'
3671 .--------+--------+--------+--------.
3672 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3673 `--------+--------+--------+--------'
3675 .--------+--------+--------+--------.
3676 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3677 `--------+--------+--------+--------'
3679 The octets are divided into 6 bit chunks, which are then encoded into
3680 base64 characters. */
3683 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3684 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3686 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3688 doc
: /* Base64-encode the region between BEG and END.
3689 Return the length of the encoded text.
3690 Optional third argument NO-LINE-BREAK means do not break long lines
3691 into shorter lines. */)
3692 (beg
, end
, no_line_break
)
3693 Lisp_Object beg
, end
, no_line_break
;
3696 int allength
, length
;
3697 int ibeg
, iend
, encoded_length
;
3700 validate_region (&beg
, &end
);
3702 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3703 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3704 move_gap_both (XFASTINT (beg
), ibeg
);
3706 /* We need to allocate enough room for encoding the text.
3707 We need 33 1/3% more space, plus a newline every 76
3708 characters, and then we round up. */
3709 length
= iend
- ibeg
;
3710 allength
= length
+ length
/3 + 1;
3711 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3713 if (allength
<= MAX_ALLOCA
)
3714 encoded
= (char *) alloca (allength
);
3716 encoded
= (char *) xmalloc (allength
);
3717 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3718 NILP (no_line_break
),
3719 !NILP (current_buffer
->enable_multibyte_characters
));
3720 if (encoded_length
> allength
)
3723 if (encoded_length
< 0)
3725 /* The encoding wasn't possible. */
3726 if (length
> MAX_ALLOCA
)
3728 error ("Multibyte character in data for base64 encoding");
3731 /* Now we have encoded the region, so we insert the new contents
3732 and delete the old. (Insert first in order to preserve markers.) */
3733 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3734 insert (encoded
, encoded_length
);
3735 if (allength
> MAX_ALLOCA
)
3737 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3739 /* If point was outside of the region, restore it exactly; else just
3740 move to the beginning of the region. */
3741 if (old_pos
>= XFASTINT (end
))
3742 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3743 else if (old_pos
> XFASTINT (beg
))
3744 old_pos
= XFASTINT (beg
);
3747 /* We return the length of the encoded text. */
3748 return make_number (encoded_length
);
3751 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3753 doc
: /* Base64-encode STRING and return the result.
3754 Optional second argument NO-LINE-BREAK means do not break long lines
3755 into shorter lines. */)
3756 (string
, no_line_break
)
3757 Lisp_Object string
, no_line_break
;
3759 int allength
, length
, encoded_length
;
3761 Lisp_Object encoded_string
;
3763 CHECK_STRING (string
);
3765 /* We need to allocate enough room for encoding the text.
3766 We need 33 1/3% more space, plus a newline every 76
3767 characters, and then we round up. */
3768 length
= SBYTES (string
);
3769 allength
= length
+ length
/3 + 1;
3770 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3772 /* We need to allocate enough room for decoding the text. */
3773 if (allength
<= MAX_ALLOCA
)
3774 encoded
= (char *) alloca (allength
);
3776 encoded
= (char *) xmalloc (allength
);
3778 encoded_length
= base64_encode_1 (SDATA (string
),
3779 encoded
, length
, NILP (no_line_break
),
3780 STRING_MULTIBYTE (string
));
3781 if (encoded_length
> allength
)
3784 if (encoded_length
< 0)
3786 /* The encoding wasn't possible. */
3787 if (length
> MAX_ALLOCA
)
3789 error ("Multibyte character in data for base64 encoding");
3792 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3793 if (allength
> MAX_ALLOCA
)
3796 return encoded_string
;
3800 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3807 int counter
= 0, i
= 0;
3817 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3825 /* Wrap line every 76 characters. */
3829 if (counter
< MIME_LINE_LENGTH
/ 4)
3838 /* Process first byte of a triplet. */
3840 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3841 value
= (0x03 & c
) << 4;
3843 /* Process second byte of a triplet. */
3847 *e
++ = base64_value_to_char
[value
];
3855 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3863 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3864 value
= (0x0f & c
) << 2;
3866 /* Process third byte of a triplet. */
3870 *e
++ = base64_value_to_char
[value
];
3877 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3885 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3886 *e
++ = base64_value_to_char
[0x3f & c
];
3893 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3895 doc
: /* Base64-decode the region between BEG and END.
3896 Return the length of the decoded text.
3897 If the region can't be decoded, signal an error and don't modify the buffer. */)
3899 Lisp_Object beg
, end
;
3901 int ibeg
, iend
, length
, allength
;
3906 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3908 validate_region (&beg
, &end
);
3910 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3911 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3913 length
= iend
- ibeg
;
3915 /* We need to allocate enough room for decoding the text. If we are
3916 working on a multibyte buffer, each decoded code may occupy at
3918 allength
= multibyte
? length
* 2 : length
;
3919 if (allength
<= MAX_ALLOCA
)
3920 decoded
= (char *) alloca (allength
);
3922 decoded
= (char *) xmalloc (allength
);
3924 move_gap_both (XFASTINT (beg
), ibeg
);
3925 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3926 multibyte
, &inserted_chars
);
3927 if (decoded_length
> allength
)
3930 if (decoded_length
< 0)
3932 /* The decoding wasn't possible. */
3933 if (allength
> MAX_ALLOCA
)
3935 error ("Invalid base64 data");
3938 /* Now we have decoded the region, so we insert the new contents
3939 and delete the old. (Insert first in order to preserve markers.) */
3940 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3941 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3942 if (allength
> MAX_ALLOCA
)
3944 /* Delete the original text. */
3945 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3946 iend
+ decoded_length
, 1);
3948 /* If point was outside of the region, restore it exactly; else just
3949 move to the beginning of the region. */
3950 if (old_pos
>= XFASTINT (end
))
3951 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3952 else if (old_pos
> XFASTINT (beg
))
3953 old_pos
= XFASTINT (beg
);
3954 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3956 return make_number (inserted_chars
);
3959 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3961 doc
: /* Base64-decode STRING and return the result. */)
3966 int length
, decoded_length
;
3967 Lisp_Object decoded_string
;
3969 CHECK_STRING (string
);
3971 length
= SBYTES (string
);
3972 /* We need to allocate enough room for decoding the text. */
3973 if (length
<= MAX_ALLOCA
)
3974 decoded
= (char *) alloca (length
);
3976 decoded
= (char *) xmalloc (length
);
3978 /* The decoded result should be unibyte. */
3979 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3981 if (decoded_length
> length
)
3983 else if (decoded_length
>= 0)
3984 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3986 decoded_string
= Qnil
;
3988 if (length
> MAX_ALLOCA
)
3990 if (!STRINGP (decoded_string
))
3991 error ("Invalid base64 data");
3993 return decoded_string
;
3996 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3997 MULTIBYTE is nonzero, the decoded result should be in multibyte
3998 form. If NCHARS_RETRUN is not NULL, store the number of produced
3999 characters in *NCHARS_RETURN. */
4002 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4012 unsigned long value
;
4017 /* Process first byte of a quadruplet. */
4019 READ_QUADRUPLET_BYTE (e
-to
);
4023 value
= base64_char_to_value
[c
] << 18;
4025 /* Process second byte of a quadruplet. */
4027 READ_QUADRUPLET_BYTE (-1);
4031 value
|= base64_char_to_value
[c
] << 12;
4033 c
= (unsigned char) (value
>> 16);
4035 e
+= CHAR_STRING (c
, e
);
4040 /* Process third byte of a quadruplet. */
4042 READ_QUADRUPLET_BYTE (-1);
4046 READ_QUADRUPLET_BYTE (-1);
4055 value
|= base64_char_to_value
[c
] << 6;
4057 c
= (unsigned char) (0xff & value
>> 8);
4059 e
+= CHAR_STRING (c
, e
);
4064 /* Process fourth byte of a quadruplet. */
4066 READ_QUADRUPLET_BYTE (-1);
4073 value
|= base64_char_to_value
[c
];
4075 c
= (unsigned char) (0xff & value
);
4077 e
+= CHAR_STRING (c
, e
);
4086 /***********************************************************************
4088 ***** Hash Tables *****
4090 ***********************************************************************/
4092 /* Implemented by gerd@gnu.org. This hash table implementation was
4093 inspired by CMUCL hash tables. */
4097 1. For small tables, association lists are probably faster than
4098 hash tables because they have lower overhead.
4100 For uses of hash tables where the O(1) behavior of table
4101 operations is not a requirement, it might therefore be a good idea
4102 not to hash. Instead, we could just do a linear search in the
4103 key_and_value vector of the hash table. This could be done
4104 if a `:linear-search t' argument is given to make-hash-table. */
4107 /* The list of all weak hash tables. Don't staticpro this one. */
4109 Lisp_Object Vweak_hash_tables
;
4111 /* Various symbols. */
4113 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4114 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4115 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4117 /* Function prototypes. */
4119 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4120 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4121 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4122 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4123 Lisp_Object
, unsigned));
4124 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4125 Lisp_Object
, unsigned));
4126 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4127 unsigned, Lisp_Object
, unsigned));
4128 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4129 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4130 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4131 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4133 static unsigned sxhash_string
P_ ((unsigned char *, int));
4134 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4135 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4136 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4137 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4141 /***********************************************************************
4143 ***********************************************************************/
4145 /* If OBJ is a Lisp hash table, return a pointer to its struct
4146 Lisp_Hash_Table. Otherwise, signal an error. */
4148 static struct Lisp_Hash_Table
*
4149 check_hash_table (obj
)
4152 CHECK_HASH_TABLE (obj
);
4153 return XHASH_TABLE (obj
);
4157 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4161 next_almost_prime (n
)
4174 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4175 which USED[I] is non-zero. If found at index I in ARGS, set
4176 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4177 -1. This function is used to extract a keyword/argument pair from
4178 a DEFUN parameter list. */
4181 get_key_arg (key
, nargs
, args
, used
)
4189 for (i
= 0; i
< nargs
- 1; ++i
)
4190 if (!used
[i
] && EQ (args
[i
], key
))
4205 /* Return a Lisp vector which has the same contents as VEC but has
4206 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4207 vector that are not copied from VEC are set to INIT. */
4210 larger_vector (vec
, new_size
, init
)
4215 struct Lisp_Vector
*v
;
4218 xassert (VECTORP (vec
));
4219 old_size
= XVECTOR (vec
)->size
;
4220 xassert (new_size
>= old_size
);
4222 v
= allocate_vector (new_size
);
4223 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4224 old_size
* sizeof *v
->contents
);
4225 for (i
= old_size
; i
< new_size
; ++i
)
4226 v
->contents
[i
] = init
;
4227 XSETVECTOR (vec
, v
);
4232 /***********************************************************************
4234 ***********************************************************************/
4236 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4237 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4238 KEY2 are the same. */
4241 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4242 struct Lisp_Hash_Table
*h
;
4243 Lisp_Object key1
, key2
;
4244 unsigned hash1
, hash2
;
4246 return (FLOATP (key1
)
4248 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4252 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4253 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4254 KEY2 are the same. */
4257 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4258 struct Lisp_Hash_Table
*h
;
4259 Lisp_Object key1
, key2
;
4260 unsigned hash1
, hash2
;
4262 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4266 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4267 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4268 if KEY1 and KEY2 are the same. */
4271 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4272 struct Lisp_Hash_Table
*h
;
4273 Lisp_Object key1
, key2
;
4274 unsigned hash1
, hash2
;
4278 Lisp_Object args
[3];
4280 args
[0] = h
->user_cmp_function
;
4283 return !NILP (Ffuncall (3, args
));
4290 /* Value is a hash code for KEY for use in hash table H which uses
4291 `eq' to compare keys. The hash code returned is guaranteed to fit
4292 in a Lisp integer. */
4296 struct Lisp_Hash_Table
*h
;
4299 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4300 xassert ((hash
& ~INTMASK
) == 0);
4305 /* Value is a hash code for KEY for use in hash table H which uses
4306 `eql' to compare keys. The hash code returned is guaranteed to fit
4307 in a Lisp integer. */
4311 struct Lisp_Hash_Table
*h
;
4316 hash
= sxhash (key
, 0);
4318 hash
= XUINT (key
) ^ XGCTYPE (key
);
4319 xassert ((hash
& ~INTMASK
) == 0);
4324 /* Value is a hash code for KEY for use in hash table H which uses
4325 `equal' to compare keys. The hash code returned is guaranteed to fit
4326 in a Lisp integer. */
4329 hashfn_equal (h
, key
)
4330 struct Lisp_Hash_Table
*h
;
4333 unsigned hash
= sxhash (key
, 0);
4334 xassert ((hash
& ~INTMASK
) == 0);
4339 /* Value is a hash code for KEY for use in hash table H which uses as
4340 user-defined function to compare keys. The hash code returned is
4341 guaranteed to fit in a Lisp integer. */
4344 hashfn_user_defined (h
, key
)
4345 struct Lisp_Hash_Table
*h
;
4348 Lisp_Object args
[2], hash
;
4350 args
[0] = h
->user_hash_function
;
4352 hash
= Ffuncall (2, args
);
4353 if (!INTEGERP (hash
))
4355 list2 (build_string ("Invalid hash code returned from \
4356 user-supplied hash function"),
4358 return XUINT (hash
);
4362 /* Create and initialize a new hash table.
4364 TEST specifies the test the hash table will use to compare keys.
4365 It must be either one of the predefined tests `eq', `eql' or
4366 `equal' or a symbol denoting a user-defined test named TEST with
4367 test and hash functions USER_TEST and USER_HASH.
4369 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4371 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4372 new size when it becomes full is computed by adding REHASH_SIZE to
4373 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4374 table's new size is computed by multiplying its old size with
4377 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4378 be resized when the ratio of (number of entries in the table) /
4379 (table size) is >= REHASH_THRESHOLD.
4381 WEAK specifies the weakness of the table. If non-nil, it must be
4382 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4385 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4386 user_test
, user_hash
)
4387 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4388 Lisp_Object user_test
, user_hash
;
4390 struct Lisp_Hash_Table
*h
;
4392 int index_size
, i
, sz
;
4394 /* Preconditions. */
4395 xassert (SYMBOLP (test
));
4396 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4397 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4398 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4399 xassert (FLOATP (rehash_threshold
)
4400 && XFLOATINT (rehash_threshold
) > 0
4401 && XFLOATINT (rehash_threshold
) <= 1.0);
4403 if (XFASTINT (size
) == 0)
4404 size
= make_number (1);
4406 /* Allocate a table and initialize it. */
4407 h
= allocate_hash_table ();
4409 /* Initialize hash table slots. */
4410 sz
= XFASTINT (size
);
4413 if (EQ (test
, Qeql
))
4415 h
->cmpfn
= cmpfn_eql
;
4416 h
->hashfn
= hashfn_eql
;
4418 else if (EQ (test
, Qeq
))
4421 h
->hashfn
= hashfn_eq
;
4423 else if (EQ (test
, Qequal
))
4425 h
->cmpfn
= cmpfn_equal
;
4426 h
->hashfn
= hashfn_equal
;
4430 h
->user_cmp_function
= user_test
;
4431 h
->user_hash_function
= user_hash
;
4432 h
->cmpfn
= cmpfn_user_defined
;
4433 h
->hashfn
= hashfn_user_defined
;
4437 h
->rehash_threshold
= rehash_threshold
;
4438 h
->rehash_size
= rehash_size
;
4439 h
->count
= make_number (0);
4440 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4441 h
->hash
= Fmake_vector (size
, Qnil
);
4442 h
->next
= Fmake_vector (size
, Qnil
);
4443 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4444 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4445 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4447 /* Set up the free list. */
4448 for (i
= 0; i
< sz
- 1; ++i
)
4449 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4450 h
->next_free
= make_number (0);
4452 XSET_HASH_TABLE (table
, h
);
4453 xassert (HASH_TABLE_P (table
));
4454 xassert (XHASH_TABLE (table
) == h
);
4456 /* Maybe add this hash table to the list of all weak hash tables. */
4458 h
->next_weak
= Qnil
;
4461 h
->next_weak
= Vweak_hash_tables
;
4462 Vweak_hash_tables
= table
;
4469 /* Return a copy of hash table H1. Keys and values are not copied,
4470 only the table itself is. */
4473 copy_hash_table (h1
)
4474 struct Lisp_Hash_Table
*h1
;
4477 struct Lisp_Hash_Table
*h2
;
4478 struct Lisp_Vector
*next
;
4480 h2
= allocate_hash_table ();
4481 next
= h2
->vec_next
;
4482 bcopy (h1
, h2
, sizeof *h2
);
4483 h2
->vec_next
= next
;
4484 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4485 h2
->hash
= Fcopy_sequence (h1
->hash
);
4486 h2
->next
= Fcopy_sequence (h1
->next
);
4487 h2
->index
= Fcopy_sequence (h1
->index
);
4488 XSET_HASH_TABLE (table
, h2
);
4490 /* Maybe add this hash table to the list of all weak hash tables. */
4491 if (!NILP (h2
->weak
))
4493 h2
->next_weak
= Vweak_hash_tables
;
4494 Vweak_hash_tables
= table
;
4501 /* Resize hash table H if it's too full. If H cannot be resized
4502 because it's already too large, throw an error. */
4505 maybe_resize_hash_table (h
)
4506 struct Lisp_Hash_Table
*h
;
4508 if (NILP (h
->next_free
))
4510 int old_size
= HASH_TABLE_SIZE (h
);
4511 int i
, new_size
, index_size
;
4513 if (INTEGERP (h
->rehash_size
))
4514 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4516 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4517 new_size
= max (old_size
+ 1, new_size
);
4518 index_size
= next_almost_prime ((int)
4520 / XFLOATINT (h
->rehash_threshold
)));
4521 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4522 error ("Hash table too large to resize");
4524 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4525 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4526 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4527 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4529 /* Update the free list. Do it so that new entries are added at
4530 the end of the free list. This makes some operations like
4532 for (i
= old_size
; i
< new_size
- 1; ++i
)
4533 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4535 if (!NILP (h
->next_free
))
4537 Lisp_Object last
, next
;
4539 last
= h
->next_free
;
4540 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4544 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4547 XSETFASTINT (h
->next_free
, old_size
);
4550 for (i
= 0; i
< old_size
; ++i
)
4551 if (!NILP (HASH_HASH (h
, i
)))
4553 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4554 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4555 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4556 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4562 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4563 the hash code of KEY. Value is the index of the entry in H
4564 matching KEY, or -1 if not found. */
4567 hash_lookup (h
, key
, hash
)
4568 struct Lisp_Hash_Table
*h
;
4573 int start_of_bucket
;
4576 hash_code
= h
->hashfn (h
, key
);
4580 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4581 idx
= HASH_INDEX (h
, start_of_bucket
);
4583 /* We need not gcpro idx since it's either an integer or nil. */
4586 int i
= XFASTINT (idx
);
4587 if (EQ (key
, HASH_KEY (h
, i
))
4589 && h
->cmpfn (h
, key
, hash_code
,
4590 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4592 idx
= HASH_NEXT (h
, i
);
4595 return NILP (idx
) ? -1 : XFASTINT (idx
);
4599 /* Put an entry into hash table H that associates KEY with VALUE.
4600 HASH is a previously computed hash code of KEY.
4601 Value is the index of the entry in H matching KEY. */
4604 hash_put (h
, key
, value
, hash
)
4605 struct Lisp_Hash_Table
*h
;
4606 Lisp_Object key
, value
;
4609 int start_of_bucket
, i
;
4611 xassert ((hash
& ~INTMASK
) == 0);
4613 /* Increment count after resizing because resizing may fail. */
4614 maybe_resize_hash_table (h
);
4615 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4617 /* Store key/value in the key_and_value vector. */
4618 i
= XFASTINT (h
->next_free
);
4619 h
->next_free
= HASH_NEXT (h
, i
);
4620 HASH_KEY (h
, i
) = key
;
4621 HASH_VALUE (h
, i
) = value
;
4623 /* Remember its hash code. */
4624 HASH_HASH (h
, i
) = make_number (hash
);
4626 /* Add new entry to its collision chain. */
4627 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4628 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4629 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4634 /* Remove the entry matching KEY from hash table H, if there is one. */
4637 hash_remove (h
, key
)
4638 struct Lisp_Hash_Table
*h
;
4642 int start_of_bucket
;
4643 Lisp_Object idx
, prev
;
4645 hash_code
= h
->hashfn (h
, key
);
4646 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4647 idx
= HASH_INDEX (h
, start_of_bucket
);
4650 /* We need not gcpro idx, prev since they're either integers or nil. */
4653 int i
= XFASTINT (idx
);
4655 if (EQ (key
, HASH_KEY (h
, i
))
4657 && h
->cmpfn (h
, key
, hash_code
,
4658 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4660 /* Take entry out of collision chain. */
4662 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4664 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4666 /* Clear slots in key_and_value and add the slots to
4668 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4669 HASH_NEXT (h
, i
) = h
->next_free
;
4670 h
->next_free
= make_number (i
);
4671 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4672 xassert (XINT (h
->count
) >= 0);
4678 idx
= HASH_NEXT (h
, i
);
4684 /* Clear hash table H. */
4688 struct Lisp_Hash_Table
*h
;
4690 if (XFASTINT (h
->count
) > 0)
4692 int i
, size
= HASH_TABLE_SIZE (h
);
4694 for (i
= 0; i
< size
; ++i
)
4696 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4697 HASH_KEY (h
, i
) = Qnil
;
4698 HASH_VALUE (h
, i
) = Qnil
;
4699 HASH_HASH (h
, i
) = Qnil
;
4702 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4703 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4705 h
->next_free
= make_number (0);
4706 h
->count
= make_number (0);
4712 /************************************************************************
4714 ************************************************************************/
4716 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4717 entries from the table that don't survive the current GC.
4718 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4719 non-zero if anything was marked. */
4722 sweep_weak_table (h
, remove_entries_p
)
4723 struct Lisp_Hash_Table
*h
;
4724 int remove_entries_p
;
4726 int bucket
, n
, marked
;
4728 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4731 for (bucket
= 0; bucket
< n
; ++bucket
)
4733 Lisp_Object idx
, next
, prev
;
4735 /* Follow collision chain, removing entries that
4736 don't survive this garbage collection. */
4738 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4740 int i
= XFASTINT (idx
);
4741 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4742 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4745 if (EQ (h
->weak
, Qkey
))
4746 remove_p
= !key_known_to_survive_p
;
4747 else if (EQ (h
->weak
, Qvalue
))
4748 remove_p
= !value_known_to_survive_p
;
4749 else if (EQ (h
->weak
, Qkey_or_value
))
4750 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4751 else if (EQ (h
->weak
, Qkey_and_value
))
4752 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4756 next
= HASH_NEXT (h
, i
);
4758 if (remove_entries_p
)
4762 /* Take out of collision chain. */
4764 HASH_INDEX (h
, bucket
) = next
;
4766 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4768 /* Add to free list. */
4769 HASH_NEXT (h
, i
) = h
->next_free
;
4772 /* Clear key, value, and hash. */
4773 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4774 HASH_HASH (h
, i
) = Qnil
;
4776 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4783 /* Make sure key and value survive. */
4784 if (!key_known_to_survive_p
)
4786 mark_object (HASH_KEY (h
, i
));
4790 if (!value_known_to_survive_p
)
4792 mark_object (HASH_VALUE (h
, i
));
4803 /* Remove elements from weak hash tables that don't survive the
4804 current garbage collection. Remove weak tables that don't survive
4805 from Vweak_hash_tables. Called from gc_sweep. */
4808 sweep_weak_hash_tables ()
4810 Lisp_Object table
, used
, next
;
4811 struct Lisp_Hash_Table
*h
;
4814 /* Mark all keys and values that are in use. Keep on marking until
4815 there is no more change. This is necessary for cases like
4816 value-weak table A containing an entry X -> Y, where Y is used in a
4817 key-weak table B, Z -> Y. If B comes after A in the list of weak
4818 tables, X -> Y might be removed from A, although when looking at B
4819 one finds that it shouldn't. */
4823 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4825 h
= XHASH_TABLE (table
);
4826 if (h
->size
& ARRAY_MARK_FLAG
)
4827 marked
|= sweep_weak_table (h
, 0);
4832 /* Remove tables and entries that aren't used. */
4833 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4835 h
= XHASH_TABLE (table
);
4836 next
= h
->next_weak
;
4838 if (h
->size
& ARRAY_MARK_FLAG
)
4840 /* TABLE is marked as used. Sweep its contents. */
4841 if (XFASTINT (h
->count
) > 0)
4842 sweep_weak_table (h
, 1);
4844 /* Add table to the list of used weak hash tables. */
4845 h
->next_weak
= used
;
4850 Vweak_hash_tables
= used
;
4855 /***********************************************************************
4856 Hash Code Computation
4857 ***********************************************************************/
4859 /* Maximum depth up to which to dive into Lisp structures. */
4861 #define SXHASH_MAX_DEPTH 3
4863 /* Maximum length up to which to take list and vector elements into
4866 #define SXHASH_MAX_LEN 7
4868 /* Combine two integers X and Y for hashing. */
4870 #define SXHASH_COMBINE(X, Y) \
4871 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4875 /* Return a hash for string PTR which has length LEN. The hash
4876 code returned is guaranteed to fit in a Lisp integer. */
4879 sxhash_string (ptr
, len
)
4883 unsigned char *p
= ptr
;
4884 unsigned char *end
= p
+ len
;
4893 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4896 return hash
& INTMASK
;
4900 /* Return a hash for list LIST. DEPTH is the current depth in the
4901 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4904 sxhash_list (list
, depth
)
4911 if (depth
< SXHASH_MAX_DEPTH
)
4913 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4914 list
= XCDR (list
), ++i
)
4916 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4917 hash
= SXHASH_COMBINE (hash
, hash2
);
4924 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4925 the Lisp structure. */
4928 sxhash_vector (vec
, depth
)
4932 unsigned hash
= XVECTOR (vec
)->size
;
4935 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4936 for (i
= 0; i
< n
; ++i
)
4938 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4939 hash
= SXHASH_COMBINE (hash
, hash2
);
4946 /* Return a hash for bool-vector VECTOR. */
4949 sxhash_bool_vector (vec
)
4952 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4955 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4956 for (i
= 0; i
< n
; ++i
)
4957 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4963 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4964 structure. Value is an unsigned integer clipped to INTMASK. */
4973 if (depth
> SXHASH_MAX_DEPTH
)
4976 switch (XTYPE (obj
))
4983 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4984 SCHARS (SYMBOL_NAME (obj
)));
4992 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4995 /* This can be everything from a vector to an overlay. */
4996 case Lisp_Vectorlike
:
4998 /* According to the CL HyperSpec, two arrays are equal only if
4999 they are `eq', except for strings and bit-vectors. In
5000 Emacs, this works differently. We have to compare element
5002 hash
= sxhash_vector (obj
, depth
);
5003 else if (BOOL_VECTOR_P (obj
))
5004 hash
= sxhash_bool_vector (obj
);
5006 /* Others are `equal' if they are `eq', so let's take their
5012 hash
= sxhash_list (obj
, depth
);
5017 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5018 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5019 for (hash
= 0; p
< e
; ++p
)
5020 hash
= SXHASH_COMBINE (hash
, *p
);
5028 return hash
& INTMASK
;
5033 /***********************************************************************
5035 ***********************************************************************/
5038 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5039 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5043 unsigned hash
= sxhash (obj
, 0);;
5044 return make_number (hash
);
5048 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5049 doc
: /* Create and return a new hash table.
5051 Arguments are specified as keyword/argument pairs. The following
5052 arguments are defined:
5054 :test TEST -- TEST must be a symbol that specifies how to compare
5055 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5056 `equal'. User-supplied test and hash functions can be specified via
5057 `define-hash-table-test'.
5059 :size SIZE -- A hint as to how many elements will be put in the table.
5062 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5063 fills up. If REHASH-SIZE is an integer, add that many space. If it
5064 is a float, it must be > 1.0, and the new size is computed by
5065 multiplying the old size with that factor. Default is 1.5.
5067 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5068 Resize the hash table when ratio of the number of entries in the
5069 table. Default is 0.8.
5071 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5072 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5073 returned is a weak table. Key/value pairs are removed from a weak
5074 hash table when there are no non-weak references pointing to their
5075 key, value, one of key or value, or both key and value, depending on
5076 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5079 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5084 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5085 Lisp_Object user_test
, user_hash
;
5089 /* The vector `used' is used to keep track of arguments that
5090 have been consumed. */
5091 used
= (char *) alloca (nargs
* sizeof *used
);
5092 bzero (used
, nargs
* sizeof *used
);
5094 /* See if there's a `:test TEST' among the arguments. */
5095 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5096 test
= i
< 0 ? Qeql
: args
[i
];
5097 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5099 /* See if it is a user-defined test. */
5102 prop
= Fget (test
, Qhash_table_test
);
5103 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5104 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5106 user_test
= XCAR (prop
);
5107 user_hash
= XCAR (XCDR (prop
));
5110 user_test
= user_hash
= Qnil
;
5112 /* See if there's a `:size SIZE' argument. */
5113 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5114 size
= i
< 0 ? Qnil
: args
[i
];
5116 size
= make_number (DEFAULT_HASH_SIZE
);
5117 else if (!INTEGERP (size
) || XINT (size
) < 0)
5119 list2 (build_string ("Invalid hash table size"),
5122 /* Look for `:rehash-size SIZE'. */
5123 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5124 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5125 if (!NUMBERP (rehash_size
)
5126 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5127 || XFLOATINT (rehash_size
) <= 1.0)
5129 list2 (build_string ("Invalid hash table rehash size"),
5132 /* Look for `:rehash-threshold THRESHOLD'. */
5133 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5134 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5135 if (!FLOATP (rehash_threshold
)
5136 || XFLOATINT (rehash_threshold
) <= 0.0
5137 || XFLOATINT (rehash_threshold
) > 1.0)
5139 list2 (build_string ("Invalid hash table rehash threshold"),
5142 /* Look for `:weakness WEAK'. */
5143 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5144 weak
= i
< 0 ? Qnil
: args
[i
];
5146 weak
= Qkey_and_value
;
5149 && !EQ (weak
, Qvalue
)
5150 && !EQ (weak
, Qkey_or_value
)
5151 && !EQ (weak
, Qkey_and_value
))
5152 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5155 /* Now, all args should have been used up, or there's a problem. */
5156 for (i
= 0; i
< nargs
; ++i
)
5159 list2 (build_string ("Invalid argument list"), args
[i
]));
5161 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5162 user_test
, user_hash
);
5166 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5167 doc
: /* Return a copy of hash table TABLE. */)
5171 return copy_hash_table (check_hash_table (table
));
5175 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5176 doc
: /* Return the number of elements in TABLE. */)
5180 return check_hash_table (table
)->count
;
5184 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5185 Shash_table_rehash_size
, 1, 1, 0,
5186 doc
: /* Return the current rehash size of TABLE. */)
5190 return check_hash_table (table
)->rehash_size
;
5194 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5195 Shash_table_rehash_threshold
, 1, 1, 0,
5196 doc
: /* Return the current rehash threshold of TABLE. */)
5200 return check_hash_table (table
)->rehash_threshold
;
5204 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5205 doc
: /* Return the size of TABLE.
5206 The size can be used as an argument to `make-hash-table' to create
5207 a hash table than can hold as many elements of TABLE holds
5208 without need for resizing. */)
5212 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5213 return make_number (HASH_TABLE_SIZE (h
));
5217 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5218 doc
: /* Return the test TABLE uses. */)
5222 return check_hash_table (table
)->test
;
5226 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5228 doc
: /* Return the weakness of TABLE. */)
5232 return check_hash_table (table
)->weak
;
5236 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5237 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5241 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5245 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5246 doc
: /* Clear hash table TABLE. */)
5250 hash_clear (check_hash_table (table
));
5255 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5256 doc
: /* Look up KEY in TABLE and return its associated value.
5257 If KEY is not found, return DFLT which defaults to nil. */)
5259 Lisp_Object key
, table
, dflt
;
5261 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5262 int i
= hash_lookup (h
, key
, NULL
);
5263 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5267 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5268 doc
: /* Associate KEY with VALUE in hash table TABLE.
5269 If KEY is already present in table, replace its current value with
5272 Lisp_Object key
, value
, table
;
5274 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5278 i
= hash_lookup (h
, key
, &hash
);
5280 HASH_VALUE (h
, i
) = value
;
5282 hash_put (h
, key
, value
, hash
);
5288 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5289 doc
: /* Remove KEY from TABLE. */)
5291 Lisp_Object key
, table
;
5293 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5294 hash_remove (h
, key
);
5299 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5300 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5301 FUNCTION is called with 2 arguments KEY and VALUE. */)
5303 Lisp_Object function
, table
;
5305 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5306 Lisp_Object args
[3];
5309 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5310 if (!NILP (HASH_HASH (h
, i
)))
5313 args
[1] = HASH_KEY (h
, i
);
5314 args
[2] = HASH_VALUE (h
, i
);
5322 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5323 Sdefine_hash_table_test
, 3, 3, 0,
5324 doc
: /* Define a new hash table test with name NAME, a symbol.
5326 In hash tables created with NAME specified as test, use TEST to
5327 compare keys, and HASH for computing hash codes of keys.
5329 TEST must be a function taking two arguments and returning non-nil if
5330 both arguments are the same. HASH must be a function taking one
5331 argument and return an integer that is the hash code of the argument.
5332 Hash code computation should use the whole value range of integers,
5333 including negative integers. */)
5335 Lisp_Object name
, test
, hash
;
5337 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5342 /************************************************************************
5344 ************************************************************************/
5349 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5350 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5352 A message digest is a cryptographic checksum of a document, and the
5353 algorithm to calculate it is defined in RFC 1321.
5355 The two optional arguments START and END are character positions
5356 specifying for which part of OBJECT the message digest should be
5357 computed. If nil or omitted, the digest is computed for the whole
5360 The MD5 message digest is computed from the result of encoding the
5361 text in a coding system, not directly from the internal Emacs form of
5362 the text. The optional fourth argument CODING-SYSTEM specifies which
5363 coding system to encode the text with. It should be the same coding
5364 system that you used or will use when actually writing the text into a
5367 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5368 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5369 system would be chosen by default for writing this text into a file.
5371 If OBJECT is a string, the most preferred coding system (see the
5372 command `prefer-coding-system') is used.
5374 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5375 guesswork fails. Normally, an error is signaled in such case. */)
5376 (object
, start
, end
, coding_system
, noerror
)
5377 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5379 unsigned char digest
[16];
5380 unsigned char value
[33];
5384 int start_char
= 0, end_char
= 0;
5385 int start_byte
= 0, end_byte
= 0;
5387 register struct buffer
*bp
;
5390 if (STRINGP (object
))
5392 if (NILP (coding_system
))
5394 /* Decide the coding-system to encode the data with. */
5396 if (STRING_MULTIBYTE (object
))
5397 /* use default, we can't guess correct value */
5398 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5400 coding_system
= Qraw_text
;
5403 if (NILP (Fcoding_system_p (coding_system
)))
5405 /* Invalid coding system. */
5407 if (!NILP (noerror
))
5408 coding_system
= Qraw_text
;
5411 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5414 if (STRING_MULTIBYTE (object
))
5415 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5417 size
= SCHARS (object
);
5418 size_byte
= SBYTES (object
);
5422 CHECK_NUMBER (start
);
5424 start_char
= XINT (start
);
5429 start_byte
= string_char_to_byte (object
, start_char
);
5435 end_byte
= size_byte
;
5441 end_char
= XINT (end
);
5446 end_byte
= string_char_to_byte (object
, end_char
);
5449 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5450 args_out_of_range_3 (object
, make_number (start_char
),
5451 make_number (end_char
));
5455 struct buffer
*prev
= current_buffer
;
5457 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5459 CHECK_BUFFER (object
);
5461 bp
= XBUFFER (object
);
5462 if (bp
!= current_buffer
)
5463 set_buffer_internal (bp
);
5469 CHECK_NUMBER_COERCE_MARKER (start
);
5477 CHECK_NUMBER_COERCE_MARKER (end
);
5482 temp
= b
, b
= e
, e
= temp
;
5484 if (!(BEGV
<= b
&& e
<= ZV
))
5485 args_out_of_range (start
, end
);
5487 if (NILP (coding_system
))
5489 /* Decide the coding-system to encode the data with.
5490 See fileio.c:Fwrite-region */
5492 if (!NILP (Vcoding_system_for_write
))
5493 coding_system
= Vcoding_system_for_write
;
5496 int force_raw_text
= 0;
5498 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5499 if (NILP (coding_system
)
5500 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5502 coding_system
= Qnil
;
5503 if (NILP (current_buffer
->enable_multibyte_characters
))
5507 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5509 /* Check file-coding-system-alist. */
5510 Lisp_Object args
[4], val
;
5512 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5513 args
[3] = Fbuffer_file_name(object
);
5514 val
= Ffind_operation_coding_system (4, args
);
5515 if (CONSP (val
) && !NILP (XCDR (val
)))
5516 coding_system
= XCDR (val
);
5519 if (NILP (coding_system
)
5520 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5522 /* If we still have not decided a coding system, use the
5523 default value of buffer-file-coding-system. */
5524 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5528 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5529 /* Confirm that VAL can surely encode the current region. */
5530 coding_system
= call4 (Vselect_safe_coding_system_function
,
5531 make_number (b
), make_number (e
),
5532 coding_system
, Qnil
);
5535 coding_system
= Qraw_text
;
5538 if (NILP (Fcoding_system_p (coding_system
)))
5540 /* Invalid coding system. */
5542 if (!NILP (noerror
))
5543 coding_system
= Qraw_text
;
5546 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5550 object
= make_buffer_string (b
, e
, 0);
5551 if (prev
!= current_buffer
)
5552 set_buffer_internal (prev
);
5553 /* Discard the unwind protect for recovering the current
5557 if (STRING_MULTIBYTE (object
))
5558 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5561 md5_buffer (SDATA (object
) + start_byte
,
5562 SBYTES (object
) - (size_byte
- end_byte
),
5565 for (i
= 0; i
< 16; i
++)
5566 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5569 return make_string (value
, 32);
5576 /* Hash table stuff. */
5577 Qhash_table_p
= intern ("hash-table-p");
5578 staticpro (&Qhash_table_p
);
5579 Qeq
= intern ("eq");
5581 Qeql
= intern ("eql");
5583 Qequal
= intern ("equal");
5584 staticpro (&Qequal
);
5585 QCtest
= intern (":test");
5586 staticpro (&QCtest
);
5587 QCsize
= intern (":size");
5588 staticpro (&QCsize
);
5589 QCrehash_size
= intern (":rehash-size");
5590 staticpro (&QCrehash_size
);
5591 QCrehash_threshold
= intern (":rehash-threshold");
5592 staticpro (&QCrehash_threshold
);
5593 QCweakness
= intern (":weakness");
5594 staticpro (&QCweakness
);
5595 Qkey
= intern ("key");
5597 Qvalue
= intern ("value");
5598 staticpro (&Qvalue
);
5599 Qhash_table_test
= intern ("hash-table-test");
5600 staticpro (&Qhash_table_test
);
5601 Qkey_or_value
= intern ("key-or-value");
5602 staticpro (&Qkey_or_value
);
5603 Qkey_and_value
= intern ("key-and-value");
5604 staticpro (&Qkey_and_value
);
5607 defsubr (&Smake_hash_table
);
5608 defsubr (&Scopy_hash_table
);
5609 defsubr (&Shash_table_count
);
5610 defsubr (&Shash_table_rehash_size
);
5611 defsubr (&Shash_table_rehash_threshold
);
5612 defsubr (&Shash_table_size
);
5613 defsubr (&Shash_table_test
);
5614 defsubr (&Shash_table_weakness
);
5615 defsubr (&Shash_table_p
);
5616 defsubr (&Sclrhash
);
5617 defsubr (&Sgethash
);
5618 defsubr (&Sputhash
);
5619 defsubr (&Sremhash
);
5620 defsubr (&Smaphash
);
5621 defsubr (&Sdefine_hash_table_test
);
5623 Qstring_lessp
= intern ("string-lessp");
5624 staticpro (&Qstring_lessp
);
5625 Qprovide
= intern ("provide");
5626 staticpro (&Qprovide
);
5627 Qrequire
= intern ("require");
5628 staticpro (&Qrequire
);
5629 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5630 staticpro (&Qyes_or_no_p_history
);
5631 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5632 staticpro (&Qcursor_in_echo_area
);
5633 Qwidget_type
= intern ("widget-type");
5634 staticpro (&Qwidget_type
);
5636 staticpro (&string_char_byte_cache_string
);
5637 string_char_byte_cache_string
= Qnil
;
5639 require_nesting_list
= Qnil
;
5640 staticpro (&require_nesting_list
);
5642 Fset (Qyes_or_no_p_history
, Qnil
);
5644 DEFVAR_LISP ("features", &Vfeatures
,
5645 doc
: /* A list of symbols which are the features of the executing emacs.
5646 Used by `featurep' and `require', and altered by `provide'. */);
5648 Qsubfeatures
= intern ("subfeatures");
5649 staticpro (&Qsubfeatures
);
5651 #ifdef HAVE_LANGINFO_CODESET
5652 Qcodeset
= intern ("codeset");
5653 staticpro (&Qcodeset
);
5654 Qdays
= intern ("days");
5656 Qmonths
= intern ("months");
5657 staticpro (&Qmonths
);
5658 Qpaper
= intern ("paper");
5659 staticpro (&Qpaper
);
5660 #endif /* HAVE_LANGINFO_CODESET */
5662 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5663 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5664 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5665 invoked by mouse clicks and mouse menu items. */);
5668 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5669 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5670 This applies to commands from menus and tool bar buttons. The value of
5671 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5672 used if both `use-dialog-box' and this variable are non-nil. */);
5673 use_file_dialog
= 1;
5675 defsubr (&Sidentity
);
5678 defsubr (&Ssafe_length
);
5679 defsubr (&Sstring_bytes
);
5680 defsubr (&Sstring_equal
);
5681 defsubr (&Scompare_strings
);
5682 defsubr (&Sstring_lessp
);
5685 defsubr (&Svconcat
);
5686 defsubr (&Scopy_sequence
);
5687 defsubr (&Sstring_make_multibyte
);
5688 defsubr (&Sstring_make_unibyte
);
5689 defsubr (&Sstring_as_multibyte
);
5690 defsubr (&Sstring_as_unibyte
);
5691 defsubr (&Sstring_to_multibyte
);
5692 defsubr (&Scopy_alist
);
5693 defsubr (&Ssubstring
);
5694 defsubr (&Ssubstring_no_properties
);
5706 defsubr (&Snreverse
);
5707 defsubr (&Sreverse
);
5709 defsubr (&Splist_get
);
5711 defsubr (&Splist_put
);
5713 defsubr (&Slax_plist_get
);
5714 defsubr (&Slax_plist_put
);
5716 defsubr (&Sfillarray
);
5717 defsubr (&Sclear_string
);
5718 defsubr (&Schar_table_subtype
);
5719 defsubr (&Schar_table_parent
);
5720 defsubr (&Sset_char_table_parent
);
5721 defsubr (&Schar_table_extra_slot
);
5722 defsubr (&Sset_char_table_extra_slot
);
5723 defsubr (&Schar_table_range
);
5724 defsubr (&Sset_char_table_range
);
5725 defsubr (&Sset_char_table_default
);
5726 defsubr (&Soptimize_char_table
);
5727 defsubr (&Smap_char_table
);
5731 defsubr (&Smapconcat
);
5732 defsubr (&Sy_or_n_p
);
5733 defsubr (&Syes_or_no_p
);
5734 defsubr (&Sload_average
);
5735 defsubr (&Sfeaturep
);
5736 defsubr (&Srequire
);
5737 defsubr (&Sprovide
);
5738 defsubr (&Splist_member
);
5739 defsubr (&Swidget_put
);
5740 defsubr (&Swidget_get
);
5741 defsubr (&Swidget_apply
);
5742 defsubr (&Sbase64_encode_region
);
5743 defsubr (&Sbase64_decode_region
);
5744 defsubr (&Sbase64_encode_string
);
5745 defsubr (&Sbase64_decode_string
);
5747 defsubr (&Slocale_info
);
5754 Vweak_hash_tables
= Qnil
;
5757 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5758 (do not change this comment) */