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 if (! STRING_MULTIBYTE (string
))
890 best_below
= best_below_byte
= 0;
891 best_above
= SCHARS (string
);
892 best_above_byte
= SBYTES (string
);
894 if (EQ (string
, string_char_byte_cache_string
))
896 if (string_char_byte_cache_charpos
< char_index
)
898 best_below
= string_char_byte_cache_charpos
;
899 best_below_byte
= string_char_byte_cache_bytepos
;
903 best_above
= string_char_byte_cache_charpos
;
904 best_above_byte
= string_char_byte_cache_bytepos
;
908 if (char_index
- best_below
< best_above
- char_index
)
910 while (best_below
< char_index
)
913 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
914 best_below
, best_below_byte
);
917 i_byte
= best_below_byte
;
921 while (best_above
> char_index
)
923 unsigned char *pend
= SDATA (string
) + best_above_byte
;
924 unsigned char *pbeg
= pend
- best_above_byte
;
925 unsigned char *p
= pend
- 1;
928 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
929 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
930 if (bytes
== pend
- p
)
931 best_above_byte
-= bytes
;
932 else if (bytes
> pend
- p
)
933 best_above_byte
-= (pend
- p
);
939 i_byte
= best_above_byte
;
942 string_char_byte_cache_bytepos
= i_byte
;
943 string_char_byte_cache_charpos
= i
;
944 string_char_byte_cache_string
= string
;
949 /* Return the character index corresponding to BYTE_INDEX in STRING. */
952 string_byte_to_char (string
, byte_index
)
957 int best_below
, best_below_byte
;
958 int best_above
, best_above_byte
;
960 if (! STRING_MULTIBYTE (string
))
963 best_below
= best_below_byte
= 0;
964 best_above
= SCHARS (string
);
965 best_above_byte
= SBYTES (string
);
967 if (EQ (string
, string_char_byte_cache_string
))
969 if (string_char_byte_cache_bytepos
< byte_index
)
971 best_below
= string_char_byte_cache_charpos
;
972 best_below_byte
= string_char_byte_cache_bytepos
;
976 best_above
= string_char_byte_cache_charpos
;
977 best_above_byte
= string_char_byte_cache_bytepos
;
981 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
983 while (best_below_byte
< byte_index
)
986 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
987 best_below
, best_below_byte
);
990 i_byte
= best_below_byte
;
994 while (best_above_byte
> byte_index
)
996 unsigned char *pend
= SDATA (string
) + best_above_byte
;
997 unsigned char *pbeg
= pend
- best_above_byte
;
998 unsigned char *p
= pend
- 1;
1001 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
1002 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
1003 if (bytes
== pend
- p
)
1004 best_above_byte
-= bytes
;
1005 else if (bytes
> pend
- p
)
1006 best_above_byte
-= (pend
- p
);
1012 i_byte
= best_above_byte
;
1015 string_char_byte_cache_bytepos
= i_byte
;
1016 string_char_byte_cache_charpos
= i
;
1017 string_char_byte_cache_string
= string
;
1022 /* Convert STRING to a multibyte string.
1023 Single-byte characters 0240 through 0377 are converted
1024 by adding nonascii_insert_offset to each. */
1027 string_make_multibyte (string
)
1033 if (STRING_MULTIBYTE (string
))
1036 nbytes
= count_size_as_multibyte (SDATA (string
),
1038 /* If all the chars are ASCII, they won't need any more bytes
1039 once converted. In that case, we can return STRING itself. */
1040 if (nbytes
== SBYTES (string
))
1043 buf
= (unsigned char *) alloca (nbytes
);
1044 copy_text (SDATA (string
), buf
, SBYTES (string
),
1047 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1051 /* Convert STRING to a multibyte string without changing each
1052 character codes. Thus, characters 0200 trough 0237 are converted
1053 to eight-bit-control characters, and characters 0240 through 0377
1054 are converted eight-bit-graphic characters. */
1057 string_to_multibyte (string
)
1063 if (STRING_MULTIBYTE (string
))
1066 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1067 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1068 any more bytes once converted. */
1069 if (nbytes
== SBYTES (string
))
1070 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1072 buf
= (unsigned char *) alloca (nbytes
);
1073 bcopy (SDATA (string
), buf
, SBYTES (string
));
1074 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1076 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1080 /* Convert STRING to a single-byte string. */
1083 string_make_unibyte (string
)
1088 if (! STRING_MULTIBYTE (string
))
1091 buf
= (unsigned char *) alloca (SCHARS (string
));
1093 copy_text (SDATA (string
), buf
, SBYTES (string
),
1096 return make_unibyte_string (buf
, SCHARS (string
));
1099 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1101 doc
: /* Return the multibyte equivalent of STRING.
1102 If STRING is unibyte and contains non-ASCII characters, the function
1103 `unibyte-char-to-multibyte' is used to convert each unibyte character
1104 to a multibyte character. In this case, the returned string is a
1105 newly created string with no text properties. If STRING is multibyte
1106 or entirely ASCII, it is returned unchanged. In particular, when
1107 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1108 \(When the characters are all ASCII, Emacs primitives will treat the
1109 string the same way whether it is unibyte or multibyte.) */)
1113 CHECK_STRING (string
);
1115 return string_make_multibyte (string
);
1118 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1120 doc
: /* Return the unibyte equivalent of STRING.
1121 Multibyte character codes are converted to unibyte according to
1122 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1123 If the lookup in the translation table fails, this function takes just
1124 the low 8 bits of each character. */)
1128 CHECK_STRING (string
);
1130 return string_make_unibyte (string
);
1133 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1135 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1136 If STRING is unibyte, the result is STRING itself.
1137 Otherwise it is a newly created string, with no text properties.
1138 If STRING is multibyte and contains a character of charset
1139 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1140 corresponding single byte. */)
1144 CHECK_STRING (string
);
1146 if (STRING_MULTIBYTE (string
))
1148 int bytes
= SBYTES (string
);
1149 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1151 bcopy (SDATA (string
), str
, bytes
);
1152 bytes
= str_as_unibyte (str
, bytes
);
1153 string
= make_unibyte_string (str
, bytes
);
1159 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1161 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1162 If STRING is multibyte, the result is STRING itself.
1163 Otherwise it is a newly created string, with no text properties.
1164 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1165 part of a multibyte form), it is converted to the corresponding
1166 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1170 CHECK_STRING (string
);
1172 if (! STRING_MULTIBYTE (string
))
1174 Lisp_Object new_string
;
1177 parse_str_as_multibyte (SDATA (string
),
1180 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1181 bcopy (SDATA (string
), SDATA (new_string
),
1183 if (nbytes
!= SBYTES (string
))
1184 str_as_multibyte (SDATA (new_string
), nbytes
,
1185 SBYTES (string
), NULL
);
1186 string
= new_string
;
1187 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1192 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1194 doc
: /* Return a multibyte string with the same individual chars as STRING.
1195 If STRING is multibyte, the result is STRING itself.
1196 Otherwise it is a newly created string, with no text properties.
1197 Characters 0200 through 0237 are converted to eight-bit-control
1198 characters of the same character code. Characters 0240 through 0377
1199 are converted to eight-bit-graphic characters of the same character
1204 CHECK_STRING (string
);
1206 return string_to_multibyte (string
);
1210 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1211 doc
: /* Return a copy of ALIST.
1212 This is an alist which represents the same mapping from objects to objects,
1213 but does not share the alist structure with ALIST.
1214 The objects mapped (cars and cdrs of elements of the alist)
1215 are shared, however.
1216 Elements of ALIST that are not conses are also shared. */)
1220 register Lisp_Object tem
;
1225 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1226 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1228 register Lisp_Object car
;
1232 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1237 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1238 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1239 TO may be nil or omitted; then the substring runs to the end of STRING.
1240 FROM and TO start at 0. If either is negative, it counts from the end.
1242 This function allows vectors as well as strings. */)
1245 register Lisp_Object from
, to
;
1250 int from_char
, to_char
;
1251 int from_byte
= 0, to_byte
= 0;
1253 if (! (STRINGP (string
) || VECTORP (string
)))
1254 wrong_type_argument (Qarrayp
, string
);
1256 CHECK_NUMBER (from
);
1258 if (STRINGP (string
))
1260 size
= SCHARS (string
);
1261 size_byte
= SBYTES (string
);
1264 size
= XVECTOR (string
)->size
;
1269 to_byte
= size_byte
;
1275 to_char
= XINT (to
);
1279 if (STRINGP (string
))
1280 to_byte
= string_char_to_byte (string
, to_char
);
1283 from_char
= XINT (from
);
1286 if (STRINGP (string
))
1287 from_byte
= string_char_to_byte (string
, from_char
);
1289 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1290 args_out_of_range_3 (string
, make_number (from_char
),
1291 make_number (to_char
));
1293 if (STRINGP (string
))
1295 res
= make_specified_string (SDATA (string
) + from_byte
,
1296 to_char
- from_char
, to_byte
- from_byte
,
1297 STRING_MULTIBYTE (string
));
1298 copy_text_properties (make_number (from_char
), make_number (to_char
),
1299 string
, make_number (0), res
, Qnil
);
1302 res
= Fvector (to_char
- from_char
,
1303 XVECTOR (string
)->contents
+ from_char
);
1309 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1310 doc
: /* Return a substring of STRING, without text properties.
1311 It starts at index FROM and ending before TO.
1312 TO may be nil or omitted; then the substring runs to the end of STRING.
1313 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1314 If FROM or TO is negative, it counts from the end.
1316 With one argument, just copy STRING without its properties. */)
1319 register Lisp_Object from
, to
;
1321 int size
, size_byte
;
1322 int from_char
, to_char
;
1323 int from_byte
, to_byte
;
1325 CHECK_STRING (string
);
1327 size
= SCHARS (string
);
1328 size_byte
= SBYTES (string
);
1331 from_char
= from_byte
= 0;
1334 CHECK_NUMBER (from
);
1335 from_char
= XINT (from
);
1339 from_byte
= string_char_to_byte (string
, from_char
);
1345 to_byte
= size_byte
;
1351 to_char
= XINT (to
);
1355 to_byte
= string_char_to_byte (string
, to_char
);
1358 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1359 args_out_of_range_3 (string
, make_number (from_char
),
1360 make_number (to_char
));
1362 return make_specified_string (SDATA (string
) + from_byte
,
1363 to_char
- from_char
, to_byte
- from_byte
,
1364 STRING_MULTIBYTE (string
));
1367 /* Extract a substring of STRING, giving start and end positions
1368 both in characters and in bytes. */
1371 substring_both (string
, from
, from_byte
, to
, to_byte
)
1373 int from
, from_byte
, to
, to_byte
;
1379 if (! (STRINGP (string
) || VECTORP (string
)))
1380 wrong_type_argument (Qarrayp
, string
);
1382 if (STRINGP (string
))
1384 size
= SCHARS (string
);
1385 size_byte
= SBYTES (string
);
1388 size
= XVECTOR (string
)->size
;
1390 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1391 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1393 if (STRINGP (string
))
1395 res
= make_specified_string (SDATA (string
) + from_byte
,
1396 to
- from
, to_byte
- from_byte
,
1397 STRING_MULTIBYTE (string
));
1398 copy_text_properties (make_number (from
), make_number (to
),
1399 string
, make_number (0), res
, Qnil
);
1402 res
= Fvector (to
- from
,
1403 XVECTOR (string
)->contents
+ from
);
1408 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1409 doc
: /* Take cdr N times on LIST, returns the result. */)
1412 register Lisp_Object list
;
1414 register int i
, num
;
1417 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1421 wrong_type_argument (Qlistp
, list
);
1427 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1428 doc
: /* Return the Nth element of LIST.
1429 N counts from zero. If LIST is not that long, nil is returned. */)
1431 Lisp_Object n
, list
;
1433 return Fcar (Fnthcdr (n
, list
));
1436 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1437 doc
: /* Return element of SEQUENCE at index N. */)
1439 register Lisp_Object sequence
, n
;
1444 if (CONSP (sequence
) || NILP (sequence
))
1445 return Fcar (Fnthcdr (n
, sequence
));
1446 else if (STRINGP (sequence
) || VECTORP (sequence
)
1447 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1448 return Faref (sequence
, n
);
1450 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1454 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1455 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1456 The value is actually the tail of LIST whose car is ELT. */)
1458 register Lisp_Object elt
;
1461 register Lisp_Object tail
;
1462 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1464 register Lisp_Object tem
;
1466 wrong_type_argument (Qlistp
, list
);
1468 if (! NILP (Fequal (elt
, tem
)))
1475 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1476 doc
: /* Return non-nil if ELT is an element of LIST.
1477 Comparison done with EQ. The value is actually the tail of LIST
1478 whose car is ELT. */)
1480 Lisp_Object elt
, list
;
1484 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1488 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1492 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1499 if (!CONSP (list
) && !NILP (list
))
1500 list
= wrong_type_argument (Qlistp
, list
);
1505 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1506 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1507 The value is actually the first element of LIST whose car is KEY.
1508 Elements of LIST that are not conses are ignored. */)
1510 Lisp_Object key
, list
;
1517 || (CONSP (XCAR (list
))
1518 && EQ (XCAR (XCAR (list
)), key
)))
1523 || (CONSP (XCAR (list
))
1524 && EQ (XCAR (XCAR (list
)), key
)))
1529 || (CONSP (XCAR (list
))
1530 && EQ (XCAR (XCAR (list
)), key
)))
1538 result
= XCAR (list
);
1539 else if (NILP (list
))
1542 result
= wrong_type_argument (Qlistp
, list
);
1547 /* Like Fassq but never report an error and do not allow quits.
1548 Use only on lists known never to be circular. */
1551 assq_no_quit (key
, list
)
1552 Lisp_Object key
, list
;
1555 && (!CONSP (XCAR (list
))
1556 || !EQ (XCAR (XCAR (list
)), key
)))
1559 return CONSP (list
) ? XCAR (list
) : Qnil
;
1562 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1563 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1564 The value is actually the first element of LIST whose car equals KEY. */)
1566 Lisp_Object key
, list
;
1568 Lisp_Object result
, car
;
1573 || (CONSP (XCAR (list
))
1574 && (car
= XCAR (XCAR (list
)),
1575 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1580 || (CONSP (XCAR (list
))
1581 && (car
= XCAR (XCAR (list
)),
1582 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1587 || (CONSP (XCAR (list
))
1588 && (car
= XCAR (XCAR (list
)),
1589 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1597 result
= XCAR (list
);
1598 else if (NILP (list
))
1601 result
= wrong_type_argument (Qlistp
, list
);
1606 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1607 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1608 The value is actually the first element of LIST whose cdr is KEY. */)
1610 register Lisp_Object key
;
1618 || (CONSP (XCAR (list
))
1619 && EQ (XCDR (XCAR (list
)), key
)))
1624 || (CONSP (XCAR (list
))
1625 && EQ (XCDR (XCAR (list
)), key
)))
1630 || (CONSP (XCAR (list
))
1631 && EQ (XCDR (XCAR (list
)), key
)))
1640 else if (CONSP (list
))
1641 result
= XCAR (list
);
1643 result
= wrong_type_argument (Qlistp
, list
);
1648 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1649 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1650 The value is actually the first element of LIST whose cdr equals KEY. */)
1652 Lisp_Object key
, list
;
1654 Lisp_Object result
, cdr
;
1659 || (CONSP (XCAR (list
))
1660 && (cdr
= XCDR (XCAR (list
)),
1661 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1666 || (CONSP (XCAR (list
))
1667 && (cdr
= XCDR (XCAR (list
)),
1668 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1673 || (CONSP (XCAR (list
))
1674 && (cdr
= XCDR (XCAR (list
)),
1675 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1683 result
= XCAR (list
);
1684 else if (NILP (list
))
1687 result
= wrong_type_argument (Qlistp
, list
);
1692 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1693 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1694 The modified LIST is returned. Comparison is done with `eq'.
1695 If the first member of LIST is ELT, there is no way to remove it by side effect;
1696 therefore, write `(setq foo (delq element foo))'
1697 to be sure of changing the value of `foo'. */)
1699 register Lisp_Object elt
;
1702 register Lisp_Object tail
, prev
;
1703 register Lisp_Object tem
;
1707 while (!NILP (tail
))
1710 wrong_type_argument (Qlistp
, list
);
1717 Fsetcdr (prev
, XCDR (tail
));
1727 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1728 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1729 SEQ must be a list, a vector, or a string.
1730 The modified SEQ is returned. Comparison is done with `equal'.
1731 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1732 is not a side effect; it is simply using a different sequence.
1733 Therefore, write `(setq foo (delete element foo))'
1734 to be sure of changing the value of `foo'. */)
1736 Lisp_Object elt
, seq
;
1742 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1743 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1746 if (n
!= ASIZE (seq
))
1748 struct Lisp_Vector
*p
= allocate_vector (n
);
1750 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1751 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1752 p
->contents
[n
++] = AREF (seq
, i
);
1754 XSETVECTOR (seq
, p
);
1757 else if (STRINGP (seq
))
1759 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1762 for (i
= nchars
= nbytes
= ibyte
= 0;
1764 ++i
, ibyte
+= cbytes
)
1766 if (STRING_MULTIBYTE (seq
))
1768 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1769 SBYTES (seq
) - ibyte
);
1770 cbytes
= CHAR_BYTES (c
);
1778 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1785 if (nchars
!= SCHARS (seq
))
1789 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1790 if (!STRING_MULTIBYTE (seq
))
1791 STRING_SET_UNIBYTE (tem
);
1793 for (i
= nchars
= nbytes
= ibyte
= 0;
1795 ++i
, ibyte
+= cbytes
)
1797 if (STRING_MULTIBYTE (seq
))
1799 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1800 SBYTES (seq
) - ibyte
);
1801 cbytes
= CHAR_BYTES (c
);
1809 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1811 unsigned char *from
= SDATA (seq
) + ibyte
;
1812 unsigned char *to
= SDATA (tem
) + nbytes
;
1818 for (n
= cbytes
; n
--; )
1828 Lisp_Object tail
, prev
;
1830 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1833 wrong_type_argument (Qlistp
, seq
);
1835 if (!NILP (Fequal (elt
, XCAR (tail
))))
1840 Fsetcdr (prev
, XCDR (tail
));
1851 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1852 doc
: /* Reverse LIST by modifying cdr pointers.
1853 Return the reversed list. */)
1857 register Lisp_Object prev
, tail
, next
;
1859 if (NILP (list
)) return list
;
1862 while (!NILP (tail
))
1866 wrong_type_argument (Qlistp
, list
);
1868 Fsetcdr (tail
, prev
);
1875 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1876 doc
: /* Reverse LIST, copying. Return the reversed list.
1877 See also the function `nreverse', which is used more often. */)
1883 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1886 new = Fcons (XCAR (list
), new);
1889 wrong_type_argument (Qconsp
, list
);
1893 Lisp_Object
merge ();
1895 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1896 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1897 Returns the sorted list. LIST is modified by side effects.
1898 PREDICATE is called with two elements of LIST, and should return t
1899 if the first element is "less" than the second. */)
1901 Lisp_Object list
, predicate
;
1903 Lisp_Object front
, back
;
1904 register Lisp_Object len
, tem
;
1905 struct gcpro gcpro1
, gcpro2
;
1906 register int length
;
1909 len
= Flength (list
);
1910 length
= XINT (len
);
1914 XSETINT (len
, (length
/ 2) - 1);
1915 tem
= Fnthcdr (len
, list
);
1917 Fsetcdr (tem
, Qnil
);
1919 GCPRO2 (front
, back
);
1920 front
= Fsort (front
, predicate
);
1921 back
= Fsort (back
, predicate
);
1923 return merge (front
, back
, predicate
);
1927 merge (org_l1
, org_l2
, pred
)
1928 Lisp_Object org_l1
, org_l2
;
1932 register Lisp_Object tail
;
1934 register Lisp_Object l1
, l2
;
1935 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1942 /* It is sufficient to protect org_l1 and org_l2.
1943 When l1 and l2 are updated, we copy the new values
1944 back into the org_ vars. */
1945 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1965 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1981 Fsetcdr (tail
, tem
);
1987 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1988 doc
: /* Extract a value from a property list.
1989 PLIST is a property list, which is a list of the form
1990 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1991 corresponding to the given PROP, or nil if PROP is not
1992 one of the properties on the list. */)
2000 CONSP (tail
) && CONSP (XCDR (tail
));
2001 tail
= XCDR (XCDR (tail
)))
2003 if (EQ (prop
, XCAR (tail
)))
2004 return XCAR (XCDR (tail
));
2006 /* This function can be called asynchronously
2007 (setup_coding_system). Don't QUIT in that case. */
2008 if (!interrupt_input_blocked
)
2013 wrong_type_argument (Qlistp
, prop
);
2018 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2019 doc
: /* Return the value of SYMBOL's PROPNAME property.
2020 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2022 Lisp_Object symbol
, propname
;
2024 CHECK_SYMBOL (symbol
);
2025 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2028 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2029 doc
: /* Change value in PLIST of PROP to VAL.
2030 PLIST is a property list, which is a list of the form
2031 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2032 If PROP is already a property on the list, its value is set to VAL,
2033 otherwise the new PROP VAL pair is added. The new plist is returned;
2034 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2035 The PLIST is modified by side effects. */)
2038 register Lisp_Object prop
;
2041 register Lisp_Object tail
, prev
;
2042 Lisp_Object newcell
;
2044 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2045 tail
= XCDR (XCDR (tail
)))
2047 if (EQ (prop
, XCAR (tail
)))
2049 Fsetcar (XCDR (tail
), val
);
2056 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2060 Fsetcdr (XCDR (prev
), newcell
);
2064 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2065 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2066 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2067 (symbol
, propname
, value
)
2068 Lisp_Object symbol
, propname
, value
;
2070 CHECK_SYMBOL (symbol
);
2071 XSYMBOL (symbol
)->plist
2072 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2076 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2077 doc
: /* Extract a value from a property list, comparing with `equal'.
2078 PLIST is a property list, which is a list of the form
2079 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2080 corresponding to the given PROP, or nil if PROP is not
2081 one of the properties on the list. */)
2089 CONSP (tail
) && CONSP (XCDR (tail
));
2090 tail
= XCDR (XCDR (tail
)))
2092 if (! NILP (Fequal (prop
, XCAR (tail
))))
2093 return XCAR (XCDR (tail
));
2099 wrong_type_argument (Qlistp
, prop
);
2104 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2105 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2106 PLIST is a property list, which is a list of the form
2107 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2108 If PROP is already a property on the list, its value is set to VAL,
2109 otherwise the new PROP VAL pair is added. The new plist is returned;
2110 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2111 The PLIST is modified by side effects. */)
2114 register Lisp_Object prop
;
2117 register Lisp_Object tail
, prev
;
2118 Lisp_Object newcell
;
2120 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2121 tail
= XCDR (XCDR (tail
)))
2123 if (! NILP (Fequal (prop
, XCAR (tail
))))
2125 Fsetcar (XCDR (tail
), val
);
2132 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2136 Fsetcdr (XCDR (prev
), newcell
);
2140 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2141 doc
: /* Return t if two Lisp objects have similar structure and contents.
2142 They must have the same data type.
2143 Conses are compared by comparing the cars and the cdrs.
2144 Vectors and strings are compared element by element.
2145 Numbers are compared by value, but integers cannot equal floats.
2146 (Use `=' if you want integers and floats to be able to be equal.)
2147 Symbols must match exactly. */)
2149 register Lisp_Object o1
, o2
;
2151 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2155 internal_equal (o1
, o2
, depth
)
2156 register Lisp_Object o1
, o2
;
2160 error ("Stack overflow in equal");
2166 if (XTYPE (o1
) != XTYPE (o2
))
2175 d1
= extract_float (o1
);
2176 d2
= extract_float (o2
);
2177 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2178 though they are not =. */
2179 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2183 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2190 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2194 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2196 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2199 o1
= XOVERLAY (o1
)->plist
;
2200 o2
= XOVERLAY (o2
)->plist
;
2205 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2206 && (XMARKER (o1
)->buffer
== 0
2207 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2211 case Lisp_Vectorlike
:
2214 EMACS_INT size
= XVECTOR (o1
)->size
;
2215 /* Pseudovectors have the type encoded in the size field, so this test
2216 actually checks that the objects have the same type as well as the
2218 if (XVECTOR (o2
)->size
!= size
)
2220 /* Boolvectors are compared much like strings. */
2221 if (BOOL_VECTOR_P (o1
))
2224 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2226 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2228 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2233 if (WINDOW_CONFIGURATIONP (o1
))
2234 return compare_window_configurations (o1
, o2
, 0);
2236 /* Aside from them, only true vectors, char-tables, and compiled
2237 functions are sensible to compare, so eliminate the others now. */
2238 if (size
& PSEUDOVECTOR_FLAG
)
2240 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2242 size
&= PSEUDOVECTOR_SIZE_MASK
;
2244 for (i
= 0; i
< size
; i
++)
2247 v1
= XVECTOR (o1
)->contents
[i
];
2248 v2
= XVECTOR (o2
)->contents
[i
];
2249 if (!internal_equal (v1
, v2
, depth
+ 1))
2257 if (SCHARS (o1
) != SCHARS (o2
))
2259 if (SBYTES (o1
) != SBYTES (o2
))
2261 if (bcmp (SDATA (o1
), SDATA (o2
),
2268 case Lisp_Type_Limit
:
2275 extern Lisp_Object
Fmake_char_internal ();
2277 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2278 doc
: /* Store each element of ARRAY with ITEM.
2279 ARRAY is a vector, string, char-table, or bool-vector. */)
2281 Lisp_Object array
, item
;
2283 register int size
, index
, charval
;
2285 if (VECTORP (array
))
2287 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2288 size
= XVECTOR (array
)->size
;
2289 for (index
= 0; index
< size
; index
++)
2292 else if (CHAR_TABLE_P (array
))
2294 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2295 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2296 for (index
= 0; index
< size
; index
++)
2298 XCHAR_TABLE (array
)->defalt
= Qnil
;
2300 else if (STRINGP (array
))
2302 register unsigned char *p
= SDATA (array
);
2303 CHECK_NUMBER (item
);
2304 charval
= XINT (item
);
2305 size
= SCHARS (array
);
2306 if (STRING_MULTIBYTE (array
))
2308 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2309 int len
= CHAR_STRING (charval
, str
);
2310 int size_byte
= SBYTES (array
);
2311 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2314 if (size
!= size_byte
)
2317 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2318 if (len
!= this_len
)
2319 error ("Attempt to change byte length of a string");
2322 for (i
= 0; i
< size_byte
; i
++)
2323 *p
++ = str
[i
% len
];
2326 for (index
= 0; index
< size
; index
++)
2329 else if (BOOL_VECTOR_P (array
))
2331 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2333 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2335 charval
= (! NILP (item
) ? -1 : 0);
2336 for (index
= 0; index
< size_in_chars
- 1; index
++)
2338 if (index
< size_in_chars
)
2340 /* Mask out bits beyond the vector size. */
2341 if (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)
2342 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)) - 1;
2348 array
= wrong_type_argument (Qarrayp
, array
);
2354 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2356 doc
: /* Clear the contents of STRING.
2357 This makes STRING unibyte and may change its length. */)
2361 int len
= SBYTES (string
);
2362 bzero (SDATA (string
), len
);
2363 STRING_SET_CHARS (string
, len
);
2364 STRING_SET_UNIBYTE (string
);
2368 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2370 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2372 Lisp_Object char_table
;
2374 CHECK_CHAR_TABLE (char_table
);
2376 return XCHAR_TABLE (char_table
)->purpose
;
2379 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2381 doc
: /* Return the parent char-table of CHAR-TABLE.
2382 The value is either nil or another char-table.
2383 If CHAR-TABLE holds nil for a given character,
2384 then the actual applicable value is inherited from the parent char-table
2385 \(or from its parents, if necessary). */)
2387 Lisp_Object char_table
;
2389 CHECK_CHAR_TABLE (char_table
);
2391 return XCHAR_TABLE (char_table
)->parent
;
2394 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2396 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2397 Return PARENT. PARENT must be either nil or another char-table. */)
2398 (char_table
, parent
)
2399 Lisp_Object char_table
, parent
;
2403 CHECK_CHAR_TABLE (char_table
);
2407 CHECK_CHAR_TABLE (parent
);
2409 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2410 if (EQ (temp
, char_table
))
2411 error ("Attempt to make a chartable be its own parent");
2414 XCHAR_TABLE (char_table
)->parent
= parent
;
2419 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2421 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2423 Lisp_Object char_table
, n
;
2425 CHECK_CHAR_TABLE (char_table
);
2428 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2429 args_out_of_range (char_table
, n
);
2431 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2434 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2435 Sset_char_table_extra_slot
,
2437 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2438 (char_table
, n
, value
)
2439 Lisp_Object char_table
, n
, value
;
2441 CHECK_CHAR_TABLE (char_table
);
2444 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2445 args_out_of_range (char_table
, n
);
2447 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2450 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2452 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2453 RANGE should be nil (for the default value)
2454 a vector which identifies a character set or a row of a character set,
2455 a character set name, or a character code. */)
2457 Lisp_Object char_table
, range
;
2459 CHECK_CHAR_TABLE (char_table
);
2461 if (EQ (range
, Qnil
))
2462 return XCHAR_TABLE (char_table
)->defalt
;
2463 else if (INTEGERP (range
))
2464 return Faref (char_table
, range
);
2465 else if (SYMBOLP (range
))
2467 Lisp_Object charset_info
;
2469 charset_info
= Fget (range
, Qcharset
);
2470 CHECK_VECTOR (charset_info
);
2472 return Faref (char_table
,
2473 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2476 else if (VECTORP (range
))
2478 if (XVECTOR (range
)->size
== 1)
2479 return Faref (char_table
,
2480 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2483 int size
= XVECTOR (range
)->size
;
2484 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2485 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2486 size
<= 1 ? Qnil
: val
[1],
2487 size
<= 2 ? Qnil
: val
[2]);
2488 return Faref (char_table
, ch
);
2492 error ("Invalid RANGE argument to `char-table-range'");
2496 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2498 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2499 RANGE should be t (for all characters), nil (for the default value),
2500 a character set, a vector which identifies a character set, a row of a
2501 character set, or a character code. Return VALUE. */)
2502 (char_table
, range
, value
)
2503 Lisp_Object char_table
, range
, value
;
2507 CHECK_CHAR_TABLE (char_table
);
2510 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2511 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2512 else if (EQ (range
, Qnil
))
2513 XCHAR_TABLE (char_table
)->defalt
= value
;
2514 else if (SYMBOLP (range
))
2516 Lisp_Object charset_info
;
2518 charset_info
= Fget (range
, Qcharset
);
2519 CHECK_VECTOR (charset_info
);
2521 return Faset (char_table
,
2522 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2526 else if (INTEGERP (range
))
2527 Faset (char_table
, range
, value
);
2528 else if (VECTORP (range
))
2530 if (XVECTOR (range
)->size
== 1)
2531 return Faset (char_table
,
2532 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2536 int size
= XVECTOR (range
)->size
;
2537 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2538 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2539 size
<= 1 ? Qnil
: val
[1],
2540 size
<= 2 ? Qnil
: val
[2]);
2541 return Faset (char_table
, ch
, value
);
2545 error ("Invalid RANGE argument to `set-char-table-range'");
2550 DEFUN ("set-char-table-default", Fset_char_table_default
,
2551 Sset_char_table_default
, 3, 3, 0,
2552 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2553 The generic character specifies the group of characters.
2554 See also the documentation of `make-char'. */)
2555 (char_table
, ch
, value
)
2556 Lisp_Object char_table
, ch
, value
;
2558 int c
, charset
, code1
, code2
;
2561 CHECK_CHAR_TABLE (char_table
);
2565 SPLIT_CHAR (c
, charset
, code1
, code2
);
2567 /* Since we may want to set the default value for a character set
2568 not yet defined, we check only if the character set is in the
2569 valid range or not, instead of it is already defined or not. */
2570 if (! CHARSET_VALID_P (charset
))
2571 invalid_character (c
);
2573 if (charset
== CHARSET_ASCII
)
2574 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2576 /* Even if C is not a generic char, we had better behave as if a
2577 generic char is specified. */
2578 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2580 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2583 if (SUB_CHAR_TABLE_P (temp
))
2584 XCHAR_TABLE (temp
)->defalt
= value
;
2586 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2589 if (SUB_CHAR_TABLE_P (temp
))
2592 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2593 = make_sub_char_table (temp
));
2594 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2595 if (SUB_CHAR_TABLE_P (temp
))
2596 XCHAR_TABLE (temp
)->defalt
= value
;
2598 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2602 /* Look up the element in TABLE at index CH,
2603 and return it as an integer.
2604 If the element is nil, return CH itself.
2605 (Actually we do that for any non-integer.) */
2608 char_table_translate (table
, ch
)
2613 value
= Faref (table
, make_number (ch
));
2614 if (! INTEGERP (value
))
2616 return XINT (value
);
2620 optimize_sub_char_table (table
, chars
)
2628 from
= 33, to
= 127;
2630 from
= 32, to
= 128;
2632 if (!SUB_CHAR_TABLE_P (*table
))
2634 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2635 for (; from
< to
; from
++)
2636 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2641 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2642 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2650 CHECK_CHAR_TABLE (table
);
2652 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2654 elt
= XCHAR_TABLE (table
)->contents
[i
];
2655 if (!SUB_CHAR_TABLE_P (elt
))
2657 dim
= CHARSET_DIMENSION (i
- 128);
2659 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2660 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2661 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2667 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2668 character or group of characters that share a value.
2669 DEPTH is the current depth in the originally specified
2670 chartable, and INDICES contains the vector indices
2671 for the levels our callers have descended.
2673 ARG is passed to C_FUNCTION when that is called. */
2676 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2677 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2678 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2685 /* At first, handle ASCII and 8-bit European characters. */
2686 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2688 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2690 elt
= XCHAR_TABLE (subtable
)->defalt
;
2692 elt
= Faref (subtable
, make_number (i
));
2694 (*c_function
) (arg
, make_number (i
), elt
);
2696 call2 (function
, make_number (i
), elt
);
2698 #if 0 /* If the char table has entries for higher characters,
2699 we should report them. */
2700 if (NILP (current_buffer
->enable_multibyte_characters
))
2703 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2707 int charset
= XFASTINT (indices
[0]) - 128;
2710 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2711 if (CHARSET_CHARS (charset
) == 94)
2720 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2721 XSETFASTINT (indices
[depth
], i
);
2722 charset
= XFASTINT (indices
[0]) - 128;
2724 && (!CHARSET_DEFINED_P (charset
)
2725 || charset
== CHARSET_8_BIT_CONTROL
2726 || charset
== CHARSET_8_BIT_GRAPHIC
))
2729 if (SUB_CHAR_TABLE_P (elt
))
2732 error ("Too deep char table");
2733 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2739 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2740 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2741 c
= MAKE_CHAR (charset
, c1
, c2
);
2744 elt
= XCHAR_TABLE (subtable
)->defalt
;
2746 elt
= Faref (table
, make_number (c
));
2749 (*c_function
) (arg
, make_number (c
), elt
);
2751 call2 (function
, make_number (c
), elt
);
2756 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2758 void_call2 (a
, b
, c
)
2759 Lisp_Object a
, b
, c
;
2764 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2766 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2767 FUNCTION is called with two arguments--a key and a value.
2768 The key is always a possible IDX argument to `aref'. */)
2769 (function
, char_table
)
2770 Lisp_Object function
, char_table
;
2772 /* The depth of char table is at most 3. */
2773 Lisp_Object indices
[3];
2775 CHECK_CHAR_TABLE (char_table
);
2777 /* When Lisp_Object is represented as a union, `call2' cannot directly
2778 be passed to map_char_table because it returns a Lisp_Object rather
2779 than returning nothing.
2780 Casting leads to crashes on some architectures. -stef */
2781 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2785 /* Return a value for character C in char-table TABLE. Store the
2786 actual index for that value in *IDX. Ignore the default value of
2790 char_table_ref_and_index (table
, c
, idx
)
2794 int charset
, c1
, c2
;
2797 if (SINGLE_BYTE_CHAR_P (c
))
2800 return XCHAR_TABLE (table
)->contents
[c
];
2802 SPLIT_CHAR (c
, charset
, c1
, c2
);
2803 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2804 *idx
= MAKE_CHAR (charset
, 0, 0);
2805 if (!SUB_CHAR_TABLE_P (elt
))
2807 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2808 return XCHAR_TABLE (elt
)->defalt
;
2809 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2810 *idx
= MAKE_CHAR (charset
, c1
, 0);
2811 if (!SUB_CHAR_TABLE_P (elt
))
2813 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2814 return XCHAR_TABLE (elt
)->defalt
;
2816 return XCHAR_TABLE (elt
)->contents
[c2
];
2826 Lisp_Object args
[2];
2829 return Fnconc (2, args
);
2831 return Fnconc (2, &s1
);
2832 #endif /* NO_ARG_ARRAY */
2835 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2836 doc
: /* Concatenate any number of lists by altering them.
2837 Only the last argument is not altered, and need not be a list.
2838 usage: (nconc &rest LISTS) */)
2843 register int argnum
;
2844 register Lisp_Object tail
, tem
, val
;
2848 for (argnum
= 0; argnum
< nargs
; argnum
++)
2851 if (NILP (tem
)) continue;
2856 if (argnum
+ 1 == nargs
) break;
2859 tem
= wrong_type_argument (Qlistp
, tem
);
2868 tem
= args
[argnum
+ 1];
2869 Fsetcdr (tail
, tem
);
2871 args
[argnum
+ 1] = tail
;
2877 /* This is the guts of all mapping functions.
2878 Apply FN to each element of SEQ, one by one,
2879 storing the results into elements of VALS, a C vector of Lisp_Objects.
2880 LENI is the length of VALS, which should also be the length of SEQ. */
2883 mapcar1 (leni
, vals
, fn
, seq
)
2886 Lisp_Object fn
, seq
;
2888 register Lisp_Object tail
;
2891 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2895 /* Don't let vals contain any garbage when GC happens. */
2896 for (i
= 0; i
< leni
; i
++)
2899 GCPRO3 (dummy
, fn
, seq
);
2901 gcpro1
.nvars
= leni
;
2905 /* We need not explicitly protect `tail' because it is used only on lists, and
2906 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2910 for (i
= 0; i
< leni
; i
++)
2912 dummy
= XVECTOR (seq
)->contents
[i
];
2913 dummy
= call1 (fn
, dummy
);
2918 else if (BOOL_VECTOR_P (seq
))
2920 for (i
= 0; i
< leni
; i
++)
2923 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2924 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2929 dummy
= call1 (fn
, dummy
);
2934 else if (STRINGP (seq
))
2938 for (i
= 0, i_byte
= 0; i
< leni
;)
2943 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2944 XSETFASTINT (dummy
, c
);
2945 dummy
= call1 (fn
, dummy
);
2947 vals
[i_before
] = dummy
;
2950 else /* Must be a list, since Flength did not get an error */
2953 for (i
= 0; i
< leni
; i
++)
2955 dummy
= call1 (fn
, Fcar (tail
));
2965 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2966 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2967 In between each pair of results, stick in SEPARATOR. Thus, " " as
2968 SEPARATOR results in spaces between the values returned by FUNCTION.
2969 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2970 (function
, sequence
, separator
)
2971 Lisp_Object function
, sequence
, separator
;
2976 register Lisp_Object
*args
;
2978 struct gcpro gcpro1
;
2980 len
= Flength (sequence
);
2982 nargs
= leni
+ leni
- 1;
2983 if (nargs
< 0) return build_string ("");
2985 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2988 mapcar1 (leni
, args
, function
, sequence
);
2991 for (i
= leni
- 1; i
>= 0; i
--)
2992 args
[i
+ i
] = args
[i
];
2994 for (i
= 1; i
< nargs
; i
+= 2)
2995 args
[i
] = separator
;
2997 return Fconcat (nargs
, args
);
3000 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3001 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3002 The result is a list just as long as SEQUENCE.
3003 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3004 (function
, sequence
)
3005 Lisp_Object function
, sequence
;
3007 register Lisp_Object len
;
3009 register Lisp_Object
*args
;
3011 len
= Flength (sequence
);
3012 leni
= XFASTINT (len
);
3013 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
3015 mapcar1 (leni
, args
, function
, sequence
);
3017 return Flist (leni
, args
);
3020 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3021 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3022 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3023 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3024 (function
, sequence
)
3025 Lisp_Object function
, sequence
;
3029 leni
= XFASTINT (Flength (sequence
));
3030 mapcar1 (leni
, 0, function
, sequence
);
3035 /* Anything that calls this function must protect from GC! */
3037 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3038 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3039 Takes one argument, which is the string to display to ask the question.
3040 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3041 No confirmation of the answer is requested; a single character is enough.
3042 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3043 the bindings in `query-replace-map'; see the documentation of that variable
3044 for more information. In this case, the useful bindings are `act', `skip',
3045 `recenter', and `quit'.\)
3047 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3048 is nil and `use-dialog-box' is non-nil. */)
3052 register Lisp_Object obj
, key
, def
, map
;
3053 register int answer
;
3054 Lisp_Object xprompt
;
3055 Lisp_Object args
[2];
3056 struct gcpro gcpro1
, gcpro2
;
3057 int count
= SPECPDL_INDEX ();
3059 specbind (Qcursor_in_echo_area
, Qt
);
3061 map
= Fsymbol_value (intern ("query-replace-map"));
3063 CHECK_STRING (prompt
);
3065 GCPRO2 (prompt
, xprompt
);
3067 #ifdef HAVE_X_WINDOWS
3068 if (display_hourglass_p
)
3069 cancel_hourglass ();
3076 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3080 Lisp_Object pane
, menu
;
3081 redisplay_preserve_echo_area (3);
3082 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3083 Fcons (Fcons (build_string ("No"), Qnil
),
3085 menu
= Fcons (prompt
, pane
);
3086 obj
= Fx_popup_dialog (Qt
, menu
);
3087 answer
= !NILP (obj
);
3090 #endif /* HAVE_MENUS */
3091 cursor_in_echo_area
= 1;
3092 choose_minibuf_frame ();
3095 Lisp_Object pargs
[3];
3097 /* Colorize prompt according to `minibuffer-prompt' face. */
3098 pargs
[0] = build_string ("%s(y or n) ");
3099 pargs
[1] = intern ("face");
3100 pargs
[2] = intern ("minibuffer-prompt");
3101 args
[0] = Fpropertize (3, pargs
);
3106 if (minibuffer_auto_raise
)
3108 Lisp_Object mini_frame
;
3110 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3112 Fraise_frame (mini_frame
);
3115 obj
= read_filtered_event (1, 0, 0, 0);
3116 cursor_in_echo_area
= 0;
3117 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3120 key
= Fmake_vector (make_number (1), obj
);
3121 def
= Flookup_key (map
, key
, Qt
);
3123 if (EQ (def
, intern ("skip")))
3128 else if (EQ (def
, intern ("act")))
3133 else if (EQ (def
, intern ("recenter")))
3139 else if (EQ (def
, intern ("quit")))
3141 /* We want to exit this command for exit-prefix,
3142 and this is the only way to do it. */
3143 else if (EQ (def
, intern ("exit-prefix")))
3148 /* If we don't clear this, then the next call to read_char will
3149 return quit_char again, and we'll enter an infinite loop. */
3154 if (EQ (xprompt
, prompt
))
3156 args
[0] = build_string ("Please answer y or n. ");
3158 xprompt
= Fconcat (2, args
);
3163 if (! noninteractive
)
3165 cursor_in_echo_area
= -1;
3166 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3170 unbind_to (count
, Qnil
);
3171 return answer
? Qt
: Qnil
;
3174 /* This is how C code calls `yes-or-no-p' and allows the user
3177 Anything that calls this function must protect from GC! */
3180 do_yes_or_no_p (prompt
)
3183 return call1 (intern ("yes-or-no-p"), prompt
);
3186 /* Anything that calls this function must protect from GC! */
3188 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3189 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3190 Takes one argument, which is the string to display to ask the question.
3191 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3192 The user must confirm the answer with RET,
3193 and can edit it until it has been confirmed.
3195 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3196 is nil, and `use-dialog-box' is non-nil. */)
3200 register Lisp_Object ans
;
3201 Lisp_Object args
[2];
3202 struct gcpro gcpro1
;
3204 CHECK_STRING (prompt
);
3207 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3211 Lisp_Object pane
, menu
, obj
;
3212 redisplay_preserve_echo_area (4);
3213 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3214 Fcons (Fcons (build_string ("No"), Qnil
),
3217 menu
= Fcons (prompt
, pane
);
3218 obj
= Fx_popup_dialog (Qt
, menu
);
3222 #endif /* HAVE_MENUS */
3225 args
[1] = build_string ("(yes or no) ");
3226 prompt
= Fconcat (2, args
);
3232 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3233 Qyes_or_no_p_history
, Qnil
,
3235 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3240 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3248 message ("Please answer yes or no.");
3249 Fsleep_for (make_number (2), Qnil
);
3253 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3254 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3256 Each of the three load averages is multiplied by 100, then converted
3259 When USE-FLOATS is non-nil, floats will be used instead of integers.
3260 These floats are not multiplied by 100.
3262 If the 5-minute or 15-minute load averages are not available, return a
3263 shortened list, containing only those averages which are available.
3265 An error is thrown if the load average can't be obtained. In some
3266 cases making it work would require Emacs being installed setuid or
3267 setgid so that it can read kernel information, and that usually isn't
3270 Lisp_Object use_floats
;
3273 int loads
= getloadavg (load_ave
, 3);
3274 Lisp_Object ret
= Qnil
;
3277 error ("load-average not implemented for this operating system");
3281 Lisp_Object load
= (NILP (use_floats
) ?
3282 make_number ((int) (100.0 * load_ave
[loads
]))
3283 : make_float (load_ave
[loads
]));
3284 ret
= Fcons (load
, ret
);
3290 Lisp_Object Vfeatures
, Qsubfeatures
;
3291 extern Lisp_Object Vafter_load_alist
;
3293 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3294 doc
: /* Returns t if FEATURE is present in this Emacs.
3296 Use this to conditionalize execution of lisp code based on the
3297 presence or absence of emacs or environment extensions.
3298 Use `provide' to declare that a feature is available. This function
3299 looks at the value of the variable `features'. The optional argument
3300 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3301 (feature
, subfeature
)
3302 Lisp_Object feature
, subfeature
;
3304 register Lisp_Object tem
;
3305 CHECK_SYMBOL (feature
);
3306 tem
= Fmemq (feature
, Vfeatures
);
3307 if (!NILP (tem
) && !NILP (subfeature
))
3308 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3309 return (NILP (tem
)) ? Qnil
: Qt
;
3312 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3313 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3314 The optional argument SUBFEATURES should be a list of symbols listing
3315 particular subfeatures supported in this version of FEATURE. */)
3316 (feature
, subfeatures
)
3317 Lisp_Object feature
, subfeatures
;
3319 register Lisp_Object tem
;
3320 CHECK_SYMBOL (feature
);
3321 CHECK_LIST (subfeatures
);
3322 if (!NILP (Vautoload_queue
))
3323 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3324 tem
= Fmemq (feature
, Vfeatures
);
3326 Vfeatures
= Fcons (feature
, Vfeatures
);
3327 if (!NILP (subfeatures
))
3328 Fput (feature
, Qsubfeatures
, subfeatures
);
3329 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3331 /* Run any load-hooks for this file. */
3332 tem
= Fassq (feature
, Vafter_load_alist
);
3334 Fprogn (XCDR (tem
));
3339 /* `require' and its subroutines. */
3341 /* List of features currently being require'd, innermost first. */
3343 Lisp_Object require_nesting_list
;
3346 require_unwind (old_value
)
3347 Lisp_Object old_value
;
3349 return require_nesting_list
= old_value
;
3352 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3353 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3354 If FEATURE is not a member of the list `features', then the feature
3355 is not loaded; so load the file FILENAME.
3356 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3357 and `load' will try to load this name appended with the suffix `.elc' or
3358 `.el', in that order. The name without appended suffix will not be used.
3359 If the optional third argument NOERROR is non-nil,
3360 then return nil if the file is not found instead of signaling an error.
3361 Normally the return value is FEATURE.
3362 The normal messages at start and end of loading FILENAME are suppressed. */)
3363 (feature
, filename
, noerror
)
3364 Lisp_Object feature
, filename
, noerror
;
3366 register Lisp_Object tem
;
3367 struct gcpro gcpro1
, gcpro2
;
3369 CHECK_SYMBOL (feature
);
3371 tem
= Fmemq (feature
, Vfeatures
);
3375 int count
= SPECPDL_INDEX ();
3378 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3380 /* This is to make sure that loadup.el gives a clear picture
3381 of what files are preloaded and when. */
3382 if (! NILP (Vpurify_flag
))
3383 error ("(require %s) while preparing to dump",
3384 SDATA (SYMBOL_NAME (feature
)));
3386 /* A certain amount of recursive `require' is legitimate,
3387 but if we require the same feature recursively 3 times,
3389 tem
= require_nesting_list
;
3390 while (! NILP (tem
))
3392 if (! NILP (Fequal (feature
, XCAR (tem
))))
3397 error ("Recursive `require' for feature `%s'",
3398 SDATA (SYMBOL_NAME (feature
)));
3400 /* Update the list for any nested `require's that occur. */
3401 record_unwind_protect (require_unwind
, require_nesting_list
);
3402 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3404 /* Value saved here is to be restored into Vautoload_queue */
3405 record_unwind_protect (un_autoload
, Vautoload_queue
);
3406 Vautoload_queue
= Qt
;
3408 /* Load the file. */
3409 GCPRO2 (feature
, filename
);
3410 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3411 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3414 /* If load failed entirely, return nil. */
3416 return unbind_to (count
, Qnil
);
3418 tem
= Fmemq (feature
, Vfeatures
);
3420 error ("Required feature `%s' was not provided",
3421 SDATA (SYMBOL_NAME (feature
)));
3423 /* Once loading finishes, don't undo it. */
3424 Vautoload_queue
= Qt
;
3425 feature
= unbind_to (count
, feature
);
3431 /* Primitives for work of the "widget" library.
3432 In an ideal world, this section would not have been necessary.
3433 However, lisp function calls being as slow as they are, it turns
3434 out that some functions in the widget library (wid-edit.el) are the
3435 bottleneck of Widget operation. Here is their translation to C,
3436 for the sole reason of efficiency. */
3438 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3439 doc
: /* Return non-nil if PLIST has the property PROP.
3440 PLIST is a property list, which is a list of the form
3441 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3442 Unlike `plist-get', this allows you to distinguish between a missing
3443 property and a property with the value nil.
3444 The value is actually the tail of PLIST whose car is PROP. */)
3446 Lisp_Object plist
, prop
;
3448 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3451 plist
= XCDR (plist
);
3452 plist
= CDR (plist
);
3457 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3458 doc
: /* In WIDGET, set PROPERTY to VALUE.
3459 The value can later be retrieved with `widget-get'. */)
3460 (widget
, property
, value
)
3461 Lisp_Object widget
, property
, value
;
3463 CHECK_CONS (widget
);
3464 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3468 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3469 doc
: /* In WIDGET, get the value of PROPERTY.
3470 The value could either be specified when the widget was created, or
3471 later with `widget-put'. */)
3473 Lisp_Object widget
, property
;
3481 CHECK_CONS (widget
);
3482 tmp
= Fplist_member (XCDR (widget
), property
);
3488 tmp
= XCAR (widget
);
3491 widget
= Fget (tmp
, Qwidget_type
);
3495 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3496 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3497 ARGS are passed as extra arguments to the function.
3498 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3503 /* This function can GC. */
3504 Lisp_Object newargs
[3];
3505 struct gcpro gcpro1
, gcpro2
;
3508 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3509 newargs
[1] = args
[0];
3510 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3511 GCPRO2 (newargs
[0], newargs
[2]);
3512 result
= Fapply (3, newargs
);
3517 #ifdef HAVE_LANGINFO_CODESET
3518 #include <langinfo.h>
3521 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3522 doc
: /* Access locale data ITEM for the current C locale, if available.
3523 ITEM should be one of the following:
3525 `codeset', returning the character set as a string (locale item CODESET);
3527 `days', returning a 7-element vector of day names (locale items DAY_n);
3529 `months', returning a 12-element vector of month names (locale items MON_n);
3531 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3532 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3534 If the system can't provide such information through a call to
3535 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3537 See also Info node `(libc)Locales'.
3539 The data read from the system are decoded using `locale-coding-system'. */)
3544 #ifdef HAVE_LANGINFO_CODESET
3546 if (EQ (item
, Qcodeset
))
3548 str
= nl_langinfo (CODESET
);
3549 return build_string (str
);
3552 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3554 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3555 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3557 synchronize_system_time_locale ();
3558 for (i
= 0; i
< 7; i
++)
3560 str
= nl_langinfo (days
[i
]);
3561 val
= make_unibyte_string (str
, strlen (str
));
3562 /* Fixme: Is this coding system necessarily right, even if
3563 it is consistent with CODESET? If not, what to do? */
3564 Faset (v
, make_number (i
),
3565 code_convert_string_norecord (val
, Vlocale_coding_system
,
3572 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3574 struct Lisp_Vector
*p
= allocate_vector (12);
3575 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3576 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3578 synchronize_system_time_locale ();
3579 for (i
= 0; i
< 12; i
++)
3581 str
= nl_langinfo (months
[i
]);
3582 val
= make_unibyte_string (str
, strlen (str
));
3584 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3586 XSETVECTOR (val
, p
);
3590 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3591 but is in the locale files. This could be used by ps-print. */
3593 else if (EQ (item
, Qpaper
))
3595 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3596 make_number (nl_langinfo (PAPER_HEIGHT
)));
3598 #endif /* PAPER_WIDTH */
3599 #endif /* HAVE_LANGINFO_CODESET*/
3603 /* base64 encode/decode functions (RFC 2045).
3604 Based on code from GNU recode. */
3606 #define MIME_LINE_LENGTH 76
3608 #define IS_ASCII(Character) \
3610 #define IS_BASE64(Character) \
3611 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3612 #define IS_BASE64_IGNORABLE(Character) \
3613 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3614 || (Character) == '\f' || (Character) == '\r')
3616 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3617 character or return retval if there are no characters left to
3619 #define READ_QUADRUPLET_BYTE(retval) \
3624 if (nchars_return) \
3625 *nchars_return = nchars; \
3630 while (IS_BASE64_IGNORABLE (c))
3632 /* Don't use alloca for regions larger than this, lest we overflow
3634 #define MAX_ALLOCA 16*1024
3636 /* Table of characters coding the 64 values. */
3637 static char base64_value_to_char
[64] =
3639 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3640 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3641 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3642 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3643 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3644 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3645 '8', '9', '+', '/' /* 60-63 */
3648 /* Table of base64 values for first 128 characters. */
3649 static short base64_char_to_value
[128] =
3651 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3652 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3653 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3654 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3655 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3656 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3657 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3658 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3659 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3660 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3661 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3662 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3663 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3666 /* The following diagram shows the logical steps by which three octets
3667 get transformed into four base64 characters.
3669 .--------. .--------. .--------.
3670 |aaaaaabb| |bbbbcccc| |ccdddddd|
3671 `--------' `--------' `--------'
3673 .--------+--------+--------+--------.
3674 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3675 `--------+--------+--------+--------'
3677 .--------+--------+--------+--------.
3678 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3679 `--------+--------+--------+--------'
3681 The octets are divided into 6 bit chunks, which are then encoded into
3682 base64 characters. */
3685 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3686 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3688 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3690 doc
: /* Base64-encode the region between BEG and END.
3691 Return the length of the encoded text.
3692 Optional third argument NO-LINE-BREAK means do not break long lines
3693 into shorter lines. */)
3694 (beg
, end
, no_line_break
)
3695 Lisp_Object beg
, end
, no_line_break
;
3698 int allength
, length
;
3699 int ibeg
, iend
, encoded_length
;
3702 validate_region (&beg
, &end
);
3704 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3705 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3706 move_gap_both (XFASTINT (beg
), ibeg
);
3708 /* We need to allocate enough room for encoding the text.
3709 We need 33 1/3% more space, plus a newline every 76
3710 characters, and then we round up. */
3711 length
= iend
- ibeg
;
3712 allength
= length
+ length
/3 + 1;
3713 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3715 if (allength
<= MAX_ALLOCA
)
3716 encoded
= (char *) alloca (allength
);
3718 encoded
= (char *) xmalloc (allength
);
3719 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3720 NILP (no_line_break
),
3721 !NILP (current_buffer
->enable_multibyte_characters
));
3722 if (encoded_length
> allength
)
3725 if (encoded_length
< 0)
3727 /* The encoding wasn't possible. */
3728 if (length
> MAX_ALLOCA
)
3730 error ("Multibyte character in data for base64 encoding");
3733 /* Now we have encoded the region, so we insert the new contents
3734 and delete the old. (Insert first in order to preserve markers.) */
3735 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3736 insert (encoded
, encoded_length
);
3737 if (allength
> MAX_ALLOCA
)
3739 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3741 /* If point was outside of the region, restore it exactly; else just
3742 move to the beginning of the region. */
3743 if (old_pos
>= XFASTINT (end
))
3744 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3745 else if (old_pos
> XFASTINT (beg
))
3746 old_pos
= XFASTINT (beg
);
3749 /* We return the length of the encoded text. */
3750 return make_number (encoded_length
);
3753 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3755 doc
: /* Base64-encode STRING and return the result.
3756 Optional second argument NO-LINE-BREAK means do not break long lines
3757 into shorter lines. */)
3758 (string
, no_line_break
)
3759 Lisp_Object string
, no_line_break
;
3761 int allength
, length
, encoded_length
;
3763 Lisp_Object encoded_string
;
3765 CHECK_STRING (string
);
3767 /* We need to allocate enough room for encoding the text.
3768 We need 33 1/3% more space, plus a newline every 76
3769 characters, and then we round up. */
3770 length
= SBYTES (string
);
3771 allength
= length
+ length
/3 + 1;
3772 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3774 /* We need to allocate enough room for decoding the text. */
3775 if (allength
<= MAX_ALLOCA
)
3776 encoded
= (char *) alloca (allength
);
3778 encoded
= (char *) xmalloc (allength
);
3780 encoded_length
= base64_encode_1 (SDATA (string
),
3781 encoded
, length
, NILP (no_line_break
),
3782 STRING_MULTIBYTE (string
));
3783 if (encoded_length
> allength
)
3786 if (encoded_length
< 0)
3788 /* The encoding wasn't possible. */
3789 if (length
> MAX_ALLOCA
)
3791 error ("Multibyte character in data for base64 encoding");
3794 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3795 if (allength
> MAX_ALLOCA
)
3798 return encoded_string
;
3802 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3809 int counter
= 0, i
= 0;
3819 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3827 /* Wrap line every 76 characters. */
3831 if (counter
< MIME_LINE_LENGTH
/ 4)
3840 /* Process first byte of a triplet. */
3842 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3843 value
= (0x03 & c
) << 4;
3845 /* Process second byte of a triplet. */
3849 *e
++ = base64_value_to_char
[value
];
3857 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3865 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3866 value
= (0x0f & c
) << 2;
3868 /* Process third byte of a triplet. */
3872 *e
++ = base64_value_to_char
[value
];
3879 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3887 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3888 *e
++ = base64_value_to_char
[0x3f & c
];
3895 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3897 doc
: /* Base64-decode the region between BEG and END.
3898 Return the length of the decoded text.
3899 If the region can't be decoded, signal an error and don't modify the buffer. */)
3901 Lisp_Object beg
, end
;
3903 int ibeg
, iend
, length
, allength
;
3908 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3910 validate_region (&beg
, &end
);
3912 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3913 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3915 length
= iend
- ibeg
;
3917 /* We need to allocate enough room for decoding the text. If we are
3918 working on a multibyte buffer, each decoded code may occupy at
3920 allength
= multibyte
? length
* 2 : length
;
3921 if (allength
<= MAX_ALLOCA
)
3922 decoded
= (char *) alloca (allength
);
3924 decoded
= (char *) xmalloc (allength
);
3926 move_gap_both (XFASTINT (beg
), ibeg
);
3927 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3928 multibyte
, &inserted_chars
);
3929 if (decoded_length
> allength
)
3932 if (decoded_length
< 0)
3934 /* The decoding wasn't possible. */
3935 if (allength
> MAX_ALLOCA
)
3937 error ("Invalid base64 data");
3940 /* Now we have decoded the region, so we insert the new contents
3941 and delete the old. (Insert first in order to preserve markers.) */
3942 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3943 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3944 if (allength
> MAX_ALLOCA
)
3946 /* Delete the original text. */
3947 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3948 iend
+ decoded_length
, 1);
3950 /* If point was outside of the region, restore it exactly; else just
3951 move to the beginning of the region. */
3952 if (old_pos
>= XFASTINT (end
))
3953 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3954 else if (old_pos
> XFASTINT (beg
))
3955 old_pos
= XFASTINT (beg
);
3956 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3958 return make_number (inserted_chars
);
3961 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3963 doc
: /* Base64-decode STRING and return the result. */)
3968 int length
, decoded_length
;
3969 Lisp_Object decoded_string
;
3971 CHECK_STRING (string
);
3973 length
= SBYTES (string
);
3974 /* We need to allocate enough room for decoding the text. */
3975 if (length
<= MAX_ALLOCA
)
3976 decoded
= (char *) alloca (length
);
3978 decoded
= (char *) xmalloc (length
);
3980 /* The decoded result should be unibyte. */
3981 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3983 if (decoded_length
> length
)
3985 else if (decoded_length
>= 0)
3986 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3988 decoded_string
= Qnil
;
3990 if (length
> MAX_ALLOCA
)
3992 if (!STRINGP (decoded_string
))
3993 error ("Invalid base64 data");
3995 return decoded_string
;
3998 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3999 MULTIBYTE is nonzero, the decoded result should be in multibyte
4000 form. If NCHARS_RETRUN is not NULL, store the number of produced
4001 characters in *NCHARS_RETURN. */
4004 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4014 unsigned long value
;
4019 /* Process first byte of a quadruplet. */
4021 READ_QUADRUPLET_BYTE (e
-to
);
4025 value
= base64_char_to_value
[c
] << 18;
4027 /* Process second byte of a quadruplet. */
4029 READ_QUADRUPLET_BYTE (-1);
4033 value
|= base64_char_to_value
[c
] << 12;
4035 c
= (unsigned char) (value
>> 16);
4037 e
+= CHAR_STRING (c
, e
);
4042 /* Process third byte of a quadruplet. */
4044 READ_QUADRUPLET_BYTE (-1);
4048 READ_QUADRUPLET_BYTE (-1);
4057 value
|= base64_char_to_value
[c
] << 6;
4059 c
= (unsigned char) (0xff & value
>> 8);
4061 e
+= CHAR_STRING (c
, e
);
4066 /* Process fourth byte of a quadruplet. */
4068 READ_QUADRUPLET_BYTE (-1);
4075 value
|= base64_char_to_value
[c
];
4077 c
= (unsigned char) (0xff & value
);
4079 e
+= CHAR_STRING (c
, e
);
4088 /***********************************************************************
4090 ***** Hash Tables *****
4092 ***********************************************************************/
4094 /* Implemented by gerd@gnu.org. This hash table implementation was
4095 inspired by CMUCL hash tables. */
4099 1. For small tables, association lists are probably faster than
4100 hash tables because they have lower overhead.
4102 For uses of hash tables where the O(1) behavior of table
4103 operations is not a requirement, it might therefore be a good idea
4104 not to hash. Instead, we could just do a linear search in the
4105 key_and_value vector of the hash table. This could be done
4106 if a `:linear-search t' argument is given to make-hash-table. */
4109 /* The list of all weak hash tables. Don't staticpro this one. */
4111 Lisp_Object Vweak_hash_tables
;
4113 /* Various symbols. */
4115 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4116 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4117 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4119 /* Function prototypes. */
4121 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4122 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4123 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4124 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4125 Lisp_Object
, unsigned));
4126 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4127 Lisp_Object
, unsigned));
4128 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4129 unsigned, Lisp_Object
, unsigned));
4130 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4131 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4132 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4133 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4135 static unsigned sxhash_string
P_ ((unsigned char *, int));
4136 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4137 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4138 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4139 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4143 /***********************************************************************
4145 ***********************************************************************/
4147 /* If OBJ is a Lisp hash table, return a pointer to its struct
4148 Lisp_Hash_Table. Otherwise, signal an error. */
4150 static struct Lisp_Hash_Table
*
4151 check_hash_table (obj
)
4154 CHECK_HASH_TABLE (obj
);
4155 return XHASH_TABLE (obj
);
4159 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4163 next_almost_prime (n
)
4176 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4177 which USED[I] is non-zero. If found at index I in ARGS, set
4178 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4179 -1. This function is used to extract a keyword/argument pair from
4180 a DEFUN parameter list. */
4183 get_key_arg (key
, nargs
, args
, used
)
4191 for (i
= 0; i
< nargs
- 1; ++i
)
4192 if (!used
[i
] && EQ (args
[i
], key
))
4207 /* Return a Lisp vector which has the same contents as VEC but has
4208 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4209 vector that are not copied from VEC are set to INIT. */
4212 larger_vector (vec
, new_size
, init
)
4217 struct Lisp_Vector
*v
;
4220 xassert (VECTORP (vec
));
4221 old_size
= XVECTOR (vec
)->size
;
4222 xassert (new_size
>= old_size
);
4224 v
= allocate_vector (new_size
);
4225 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4226 old_size
* sizeof *v
->contents
);
4227 for (i
= old_size
; i
< new_size
; ++i
)
4228 v
->contents
[i
] = init
;
4229 XSETVECTOR (vec
, v
);
4234 /***********************************************************************
4236 ***********************************************************************/
4238 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4239 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4240 KEY2 are the same. */
4243 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4244 struct Lisp_Hash_Table
*h
;
4245 Lisp_Object key1
, key2
;
4246 unsigned hash1
, hash2
;
4248 return (FLOATP (key1
)
4250 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4254 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4255 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4256 KEY2 are the same. */
4259 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4260 struct Lisp_Hash_Table
*h
;
4261 Lisp_Object key1
, key2
;
4262 unsigned hash1
, hash2
;
4264 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4268 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4269 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4270 if KEY1 and KEY2 are the same. */
4273 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4274 struct Lisp_Hash_Table
*h
;
4275 Lisp_Object key1
, key2
;
4276 unsigned hash1
, hash2
;
4280 Lisp_Object args
[3];
4282 args
[0] = h
->user_cmp_function
;
4285 return !NILP (Ffuncall (3, args
));
4292 /* Value is a hash code for KEY for use in hash table H which uses
4293 `eq' to compare keys. The hash code returned is guaranteed to fit
4294 in a Lisp integer. */
4298 struct Lisp_Hash_Table
*h
;
4301 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4302 xassert ((hash
& ~INTMASK
) == 0);
4307 /* Value is a hash code for KEY for use in hash table H which uses
4308 `eql' to compare keys. The hash code returned is guaranteed to fit
4309 in a Lisp integer. */
4313 struct Lisp_Hash_Table
*h
;
4318 hash
= sxhash (key
, 0);
4320 hash
= XUINT (key
) ^ XGCTYPE (key
);
4321 xassert ((hash
& ~INTMASK
) == 0);
4326 /* Value is a hash code for KEY for use in hash table H which uses
4327 `equal' to compare keys. The hash code returned is guaranteed to fit
4328 in a Lisp integer. */
4331 hashfn_equal (h
, key
)
4332 struct Lisp_Hash_Table
*h
;
4335 unsigned hash
= sxhash (key
, 0);
4336 xassert ((hash
& ~INTMASK
) == 0);
4341 /* Value is a hash code for KEY for use in hash table H which uses as
4342 user-defined function to compare keys. The hash code returned is
4343 guaranteed to fit in a Lisp integer. */
4346 hashfn_user_defined (h
, key
)
4347 struct Lisp_Hash_Table
*h
;
4350 Lisp_Object args
[2], hash
;
4352 args
[0] = h
->user_hash_function
;
4354 hash
= Ffuncall (2, args
);
4355 if (!INTEGERP (hash
))
4357 list2 (build_string ("Invalid hash code returned from \
4358 user-supplied hash function"),
4360 return XUINT (hash
);
4364 /* Create and initialize a new hash table.
4366 TEST specifies the test the hash table will use to compare keys.
4367 It must be either one of the predefined tests `eq', `eql' or
4368 `equal' or a symbol denoting a user-defined test named TEST with
4369 test and hash functions USER_TEST and USER_HASH.
4371 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4373 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4374 new size when it becomes full is computed by adding REHASH_SIZE to
4375 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4376 table's new size is computed by multiplying its old size with
4379 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4380 be resized when the ratio of (number of entries in the table) /
4381 (table size) is >= REHASH_THRESHOLD.
4383 WEAK specifies the weakness of the table. If non-nil, it must be
4384 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4387 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4388 user_test
, user_hash
)
4389 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4390 Lisp_Object user_test
, user_hash
;
4392 struct Lisp_Hash_Table
*h
;
4394 int index_size
, i
, sz
;
4396 /* Preconditions. */
4397 xassert (SYMBOLP (test
));
4398 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4399 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4400 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4401 xassert (FLOATP (rehash_threshold
)
4402 && XFLOATINT (rehash_threshold
) > 0
4403 && XFLOATINT (rehash_threshold
) <= 1.0);
4405 if (XFASTINT (size
) == 0)
4406 size
= make_number (1);
4408 /* Allocate a table and initialize it. */
4409 h
= allocate_hash_table ();
4411 /* Initialize hash table slots. */
4412 sz
= XFASTINT (size
);
4415 if (EQ (test
, Qeql
))
4417 h
->cmpfn
= cmpfn_eql
;
4418 h
->hashfn
= hashfn_eql
;
4420 else if (EQ (test
, Qeq
))
4423 h
->hashfn
= hashfn_eq
;
4425 else if (EQ (test
, Qequal
))
4427 h
->cmpfn
= cmpfn_equal
;
4428 h
->hashfn
= hashfn_equal
;
4432 h
->user_cmp_function
= user_test
;
4433 h
->user_hash_function
= user_hash
;
4434 h
->cmpfn
= cmpfn_user_defined
;
4435 h
->hashfn
= hashfn_user_defined
;
4439 h
->rehash_threshold
= rehash_threshold
;
4440 h
->rehash_size
= rehash_size
;
4441 h
->count
= make_number (0);
4442 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4443 h
->hash
= Fmake_vector (size
, Qnil
);
4444 h
->next
= Fmake_vector (size
, Qnil
);
4445 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4446 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4447 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4449 /* Set up the free list. */
4450 for (i
= 0; i
< sz
- 1; ++i
)
4451 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4452 h
->next_free
= make_number (0);
4454 XSET_HASH_TABLE (table
, h
);
4455 xassert (HASH_TABLE_P (table
));
4456 xassert (XHASH_TABLE (table
) == h
);
4458 /* Maybe add this hash table to the list of all weak hash tables. */
4460 h
->next_weak
= Qnil
;
4463 h
->next_weak
= Vweak_hash_tables
;
4464 Vweak_hash_tables
= table
;
4471 /* Return a copy of hash table H1. Keys and values are not copied,
4472 only the table itself is. */
4475 copy_hash_table (h1
)
4476 struct Lisp_Hash_Table
*h1
;
4479 struct Lisp_Hash_Table
*h2
;
4480 struct Lisp_Vector
*next
;
4482 h2
= allocate_hash_table ();
4483 next
= h2
->vec_next
;
4484 bcopy (h1
, h2
, sizeof *h2
);
4485 h2
->vec_next
= next
;
4486 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4487 h2
->hash
= Fcopy_sequence (h1
->hash
);
4488 h2
->next
= Fcopy_sequence (h1
->next
);
4489 h2
->index
= Fcopy_sequence (h1
->index
);
4490 XSET_HASH_TABLE (table
, h2
);
4492 /* Maybe add this hash table to the list of all weak hash tables. */
4493 if (!NILP (h2
->weak
))
4495 h2
->next_weak
= Vweak_hash_tables
;
4496 Vweak_hash_tables
= table
;
4503 /* Resize hash table H if it's too full. If H cannot be resized
4504 because it's already too large, throw an error. */
4507 maybe_resize_hash_table (h
)
4508 struct Lisp_Hash_Table
*h
;
4510 if (NILP (h
->next_free
))
4512 int old_size
= HASH_TABLE_SIZE (h
);
4513 int i
, new_size
, index_size
;
4515 if (INTEGERP (h
->rehash_size
))
4516 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4518 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4519 new_size
= max (old_size
+ 1, new_size
);
4520 index_size
= next_almost_prime ((int)
4522 / XFLOATINT (h
->rehash_threshold
)));
4523 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4524 error ("Hash table too large to resize");
4526 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4527 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4528 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4529 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4531 /* Update the free list. Do it so that new entries are added at
4532 the end of the free list. This makes some operations like
4534 for (i
= old_size
; i
< new_size
- 1; ++i
)
4535 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4537 if (!NILP (h
->next_free
))
4539 Lisp_Object last
, next
;
4541 last
= h
->next_free
;
4542 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4546 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4549 XSETFASTINT (h
->next_free
, old_size
);
4552 for (i
= 0; i
< old_size
; ++i
)
4553 if (!NILP (HASH_HASH (h
, i
)))
4555 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4556 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4557 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4558 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4564 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4565 the hash code of KEY. Value is the index of the entry in H
4566 matching KEY, or -1 if not found. */
4569 hash_lookup (h
, key
, hash
)
4570 struct Lisp_Hash_Table
*h
;
4575 int start_of_bucket
;
4578 hash_code
= h
->hashfn (h
, key
);
4582 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4583 idx
= HASH_INDEX (h
, start_of_bucket
);
4585 /* We need not gcpro idx since it's either an integer or nil. */
4588 int i
= XFASTINT (idx
);
4589 if (EQ (key
, HASH_KEY (h
, i
))
4591 && h
->cmpfn (h
, key
, hash_code
,
4592 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4594 idx
= HASH_NEXT (h
, i
);
4597 return NILP (idx
) ? -1 : XFASTINT (idx
);
4601 /* Put an entry into hash table H that associates KEY with VALUE.
4602 HASH is a previously computed hash code of KEY.
4603 Value is the index of the entry in H matching KEY. */
4606 hash_put (h
, key
, value
, hash
)
4607 struct Lisp_Hash_Table
*h
;
4608 Lisp_Object key
, value
;
4611 int start_of_bucket
, i
;
4613 xassert ((hash
& ~INTMASK
) == 0);
4615 /* Increment count after resizing because resizing may fail. */
4616 maybe_resize_hash_table (h
);
4617 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4619 /* Store key/value in the key_and_value vector. */
4620 i
= XFASTINT (h
->next_free
);
4621 h
->next_free
= HASH_NEXT (h
, i
);
4622 HASH_KEY (h
, i
) = key
;
4623 HASH_VALUE (h
, i
) = value
;
4625 /* Remember its hash code. */
4626 HASH_HASH (h
, i
) = make_number (hash
);
4628 /* Add new entry to its collision chain. */
4629 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4630 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4631 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4636 /* Remove the entry matching KEY from hash table H, if there is one. */
4639 hash_remove (h
, key
)
4640 struct Lisp_Hash_Table
*h
;
4644 int start_of_bucket
;
4645 Lisp_Object idx
, prev
;
4647 hash_code
= h
->hashfn (h
, key
);
4648 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4649 idx
= HASH_INDEX (h
, start_of_bucket
);
4652 /* We need not gcpro idx, prev since they're either integers or nil. */
4655 int i
= XFASTINT (idx
);
4657 if (EQ (key
, HASH_KEY (h
, i
))
4659 && h
->cmpfn (h
, key
, hash_code
,
4660 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4662 /* Take entry out of collision chain. */
4664 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4666 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4668 /* Clear slots in key_and_value and add the slots to
4670 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4671 HASH_NEXT (h
, i
) = h
->next_free
;
4672 h
->next_free
= make_number (i
);
4673 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4674 xassert (XINT (h
->count
) >= 0);
4680 idx
= HASH_NEXT (h
, i
);
4686 /* Clear hash table H. */
4690 struct Lisp_Hash_Table
*h
;
4692 if (XFASTINT (h
->count
) > 0)
4694 int i
, size
= HASH_TABLE_SIZE (h
);
4696 for (i
= 0; i
< size
; ++i
)
4698 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4699 HASH_KEY (h
, i
) = Qnil
;
4700 HASH_VALUE (h
, i
) = Qnil
;
4701 HASH_HASH (h
, i
) = Qnil
;
4704 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4705 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4707 h
->next_free
= make_number (0);
4708 h
->count
= make_number (0);
4714 /************************************************************************
4716 ************************************************************************/
4718 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4719 entries from the table that don't survive the current GC.
4720 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4721 non-zero if anything was marked. */
4724 sweep_weak_table (h
, remove_entries_p
)
4725 struct Lisp_Hash_Table
*h
;
4726 int remove_entries_p
;
4728 int bucket
, n
, marked
;
4730 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4733 for (bucket
= 0; bucket
< n
; ++bucket
)
4735 Lisp_Object idx
, next
, prev
;
4737 /* Follow collision chain, removing entries that
4738 don't survive this garbage collection. */
4740 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4742 int i
= XFASTINT (idx
);
4743 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4744 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4747 if (EQ (h
->weak
, Qkey
))
4748 remove_p
= !key_known_to_survive_p
;
4749 else if (EQ (h
->weak
, Qvalue
))
4750 remove_p
= !value_known_to_survive_p
;
4751 else if (EQ (h
->weak
, Qkey_or_value
))
4752 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4753 else if (EQ (h
->weak
, Qkey_and_value
))
4754 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4758 next
= HASH_NEXT (h
, i
);
4760 if (remove_entries_p
)
4764 /* Take out of collision chain. */
4766 HASH_INDEX (h
, bucket
) = next
;
4768 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4770 /* Add to free list. */
4771 HASH_NEXT (h
, i
) = h
->next_free
;
4774 /* Clear key, value, and hash. */
4775 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4776 HASH_HASH (h
, i
) = Qnil
;
4778 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4785 /* Make sure key and value survive. */
4786 if (!key_known_to_survive_p
)
4788 mark_object (HASH_KEY (h
, i
));
4792 if (!value_known_to_survive_p
)
4794 mark_object (HASH_VALUE (h
, i
));
4805 /* Remove elements from weak hash tables that don't survive the
4806 current garbage collection. Remove weak tables that don't survive
4807 from Vweak_hash_tables. Called from gc_sweep. */
4810 sweep_weak_hash_tables ()
4812 Lisp_Object table
, used
, next
;
4813 struct Lisp_Hash_Table
*h
;
4816 /* Mark all keys and values that are in use. Keep on marking until
4817 there is no more change. This is necessary for cases like
4818 value-weak table A containing an entry X -> Y, where Y is used in a
4819 key-weak table B, Z -> Y. If B comes after A in the list of weak
4820 tables, X -> Y might be removed from A, although when looking at B
4821 one finds that it shouldn't. */
4825 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4827 h
= XHASH_TABLE (table
);
4828 if (h
->size
& ARRAY_MARK_FLAG
)
4829 marked
|= sweep_weak_table (h
, 0);
4834 /* Remove tables and entries that aren't used. */
4835 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4837 h
= XHASH_TABLE (table
);
4838 next
= h
->next_weak
;
4840 if (h
->size
& ARRAY_MARK_FLAG
)
4842 /* TABLE is marked as used. Sweep its contents. */
4843 if (XFASTINT (h
->count
) > 0)
4844 sweep_weak_table (h
, 1);
4846 /* Add table to the list of used weak hash tables. */
4847 h
->next_weak
= used
;
4852 Vweak_hash_tables
= used
;
4857 /***********************************************************************
4858 Hash Code Computation
4859 ***********************************************************************/
4861 /* Maximum depth up to which to dive into Lisp structures. */
4863 #define SXHASH_MAX_DEPTH 3
4865 /* Maximum length up to which to take list and vector elements into
4868 #define SXHASH_MAX_LEN 7
4870 /* Combine two integers X and Y for hashing. */
4872 #define SXHASH_COMBINE(X, Y) \
4873 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4877 /* Return a hash for string PTR which has length LEN. The hash
4878 code returned is guaranteed to fit in a Lisp integer. */
4881 sxhash_string (ptr
, len
)
4885 unsigned char *p
= ptr
;
4886 unsigned char *end
= p
+ len
;
4895 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4898 return hash
& INTMASK
;
4902 /* Return a hash for list LIST. DEPTH is the current depth in the
4903 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4906 sxhash_list (list
, depth
)
4913 if (depth
< SXHASH_MAX_DEPTH
)
4915 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4916 list
= XCDR (list
), ++i
)
4918 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4919 hash
= SXHASH_COMBINE (hash
, hash2
);
4926 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4927 the Lisp structure. */
4930 sxhash_vector (vec
, depth
)
4934 unsigned hash
= XVECTOR (vec
)->size
;
4937 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4938 for (i
= 0; i
< n
; ++i
)
4940 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4941 hash
= SXHASH_COMBINE (hash
, hash2
);
4948 /* Return a hash for bool-vector VECTOR. */
4951 sxhash_bool_vector (vec
)
4954 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4957 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4958 for (i
= 0; i
< n
; ++i
)
4959 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4965 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4966 structure. Value is an unsigned integer clipped to INTMASK. */
4975 if (depth
> SXHASH_MAX_DEPTH
)
4978 switch (XTYPE (obj
))
4985 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4986 SCHARS (SYMBOL_NAME (obj
)));
4994 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4997 /* This can be everything from a vector to an overlay. */
4998 case Lisp_Vectorlike
:
5000 /* According to the CL HyperSpec, two arrays are equal only if
5001 they are `eq', except for strings and bit-vectors. In
5002 Emacs, this works differently. We have to compare element
5004 hash
= sxhash_vector (obj
, depth
);
5005 else if (BOOL_VECTOR_P (obj
))
5006 hash
= sxhash_bool_vector (obj
);
5008 /* Others are `equal' if they are `eq', so let's take their
5014 hash
= sxhash_list (obj
, depth
);
5019 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5020 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5021 for (hash
= 0; p
< e
; ++p
)
5022 hash
= SXHASH_COMBINE (hash
, *p
);
5030 return hash
& INTMASK
;
5035 /***********************************************************************
5037 ***********************************************************************/
5040 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5041 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5045 unsigned hash
= sxhash (obj
, 0);;
5046 return make_number (hash
);
5050 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5051 doc
: /* Create and return a new hash table.
5053 Arguments are specified as keyword/argument pairs. The following
5054 arguments are defined:
5056 :test TEST -- TEST must be a symbol that specifies how to compare
5057 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5058 `equal'. User-supplied test and hash functions can be specified via
5059 `define-hash-table-test'.
5061 :size SIZE -- A hint as to how many elements will be put in the table.
5064 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5065 fills up. If REHASH-SIZE is an integer, add that many space. If it
5066 is a float, it must be > 1.0, and the new size is computed by
5067 multiplying the old size with that factor. Default is 1.5.
5069 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5070 Resize the hash table when ratio of the number of entries in the
5071 table. Default is 0.8.
5073 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5074 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5075 returned is a weak table. Key/value pairs are removed from a weak
5076 hash table when there are no non-weak references pointing to their
5077 key, value, one of key or value, or both key and value, depending on
5078 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5081 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5086 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5087 Lisp_Object user_test
, user_hash
;
5091 /* The vector `used' is used to keep track of arguments that
5092 have been consumed. */
5093 used
= (char *) alloca (nargs
* sizeof *used
);
5094 bzero (used
, nargs
* sizeof *used
);
5096 /* See if there's a `:test TEST' among the arguments. */
5097 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5098 test
= i
< 0 ? Qeql
: args
[i
];
5099 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5101 /* See if it is a user-defined test. */
5104 prop
= Fget (test
, Qhash_table_test
);
5105 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5106 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5108 user_test
= XCAR (prop
);
5109 user_hash
= XCAR (XCDR (prop
));
5112 user_test
= user_hash
= Qnil
;
5114 /* See if there's a `:size SIZE' argument. */
5115 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5116 size
= i
< 0 ? Qnil
: args
[i
];
5118 size
= make_number (DEFAULT_HASH_SIZE
);
5119 else if (!INTEGERP (size
) || XINT (size
) < 0)
5121 list2 (build_string ("Invalid hash table size"),
5124 /* Look for `:rehash-size SIZE'. */
5125 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5126 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5127 if (!NUMBERP (rehash_size
)
5128 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5129 || XFLOATINT (rehash_size
) <= 1.0)
5131 list2 (build_string ("Invalid hash table rehash size"),
5134 /* Look for `:rehash-threshold THRESHOLD'. */
5135 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5136 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5137 if (!FLOATP (rehash_threshold
)
5138 || XFLOATINT (rehash_threshold
) <= 0.0
5139 || XFLOATINT (rehash_threshold
) > 1.0)
5141 list2 (build_string ("Invalid hash table rehash threshold"),
5144 /* Look for `:weakness WEAK'. */
5145 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5146 weak
= i
< 0 ? Qnil
: args
[i
];
5148 weak
= Qkey_and_value
;
5151 && !EQ (weak
, Qvalue
)
5152 && !EQ (weak
, Qkey_or_value
)
5153 && !EQ (weak
, Qkey_and_value
))
5154 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5157 /* Now, all args should have been used up, or there's a problem. */
5158 for (i
= 0; i
< nargs
; ++i
)
5161 list2 (build_string ("Invalid argument list"), args
[i
]));
5163 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5164 user_test
, user_hash
);
5168 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5169 doc
: /* Return a copy of hash table TABLE. */)
5173 return copy_hash_table (check_hash_table (table
));
5177 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5178 doc
: /* Return the number of elements in TABLE. */)
5182 return check_hash_table (table
)->count
;
5186 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5187 Shash_table_rehash_size
, 1, 1, 0,
5188 doc
: /* Return the current rehash size of TABLE. */)
5192 return check_hash_table (table
)->rehash_size
;
5196 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5197 Shash_table_rehash_threshold
, 1, 1, 0,
5198 doc
: /* Return the current rehash threshold of TABLE. */)
5202 return check_hash_table (table
)->rehash_threshold
;
5206 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5207 doc
: /* Return the size of TABLE.
5208 The size can be used as an argument to `make-hash-table' to create
5209 a hash table than can hold as many elements of TABLE holds
5210 without need for resizing. */)
5214 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5215 return make_number (HASH_TABLE_SIZE (h
));
5219 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5220 doc
: /* Return the test TABLE uses. */)
5224 return check_hash_table (table
)->test
;
5228 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5230 doc
: /* Return the weakness of TABLE. */)
5234 return check_hash_table (table
)->weak
;
5238 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5239 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5243 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5247 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5248 doc
: /* Clear hash table TABLE. */)
5252 hash_clear (check_hash_table (table
));
5257 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5258 doc
: /* Look up KEY in TABLE and return its associated value.
5259 If KEY is not found, return DFLT which defaults to nil. */)
5261 Lisp_Object key
, table
, dflt
;
5263 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5264 int i
= hash_lookup (h
, key
, NULL
);
5265 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5269 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5270 doc
: /* Associate KEY with VALUE in hash table TABLE.
5271 If KEY is already present in table, replace its current value with
5274 Lisp_Object key
, value
, table
;
5276 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5280 i
= hash_lookup (h
, key
, &hash
);
5282 HASH_VALUE (h
, i
) = value
;
5284 hash_put (h
, key
, value
, hash
);
5290 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5291 doc
: /* Remove KEY from TABLE. */)
5293 Lisp_Object key
, table
;
5295 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5296 hash_remove (h
, key
);
5301 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5302 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5303 FUNCTION is called with 2 arguments KEY and VALUE. */)
5305 Lisp_Object function
, table
;
5307 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5308 Lisp_Object args
[3];
5311 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5312 if (!NILP (HASH_HASH (h
, i
)))
5315 args
[1] = HASH_KEY (h
, i
);
5316 args
[2] = HASH_VALUE (h
, i
);
5324 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5325 Sdefine_hash_table_test
, 3, 3, 0,
5326 doc
: /* Define a new hash table test with name NAME, a symbol.
5328 In hash tables created with NAME specified as test, use TEST to
5329 compare keys, and HASH for computing hash codes of keys.
5331 TEST must be a function taking two arguments and returning non-nil if
5332 both arguments are the same. HASH must be a function taking one
5333 argument and return an integer that is the hash code of the argument.
5334 Hash code computation should use the whole value range of integers,
5335 including negative integers. */)
5337 Lisp_Object name
, test
, hash
;
5339 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5344 /************************************************************************
5346 ************************************************************************/
5351 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5352 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5354 A message digest is a cryptographic checksum of a document, and the
5355 algorithm to calculate it is defined in RFC 1321.
5357 The two optional arguments START and END are character positions
5358 specifying for which part of OBJECT the message digest should be
5359 computed. If nil or omitted, the digest is computed for the whole
5362 The MD5 message digest is computed from the result of encoding the
5363 text in a coding system, not directly from the internal Emacs form of
5364 the text. The optional fourth argument CODING-SYSTEM specifies which
5365 coding system to encode the text with. It should be the same coding
5366 system that you used or will use when actually writing the text into a
5369 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5370 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5371 system would be chosen by default for writing this text into a file.
5373 If OBJECT is a string, the most preferred coding system (see the
5374 command `prefer-coding-system') is used.
5376 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5377 guesswork fails. Normally, an error is signaled in such case. */)
5378 (object
, start
, end
, coding_system
, noerror
)
5379 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5381 unsigned char digest
[16];
5382 unsigned char value
[33];
5386 int start_char
= 0, end_char
= 0;
5387 int start_byte
= 0, end_byte
= 0;
5389 register struct buffer
*bp
;
5392 if (STRINGP (object
))
5394 if (NILP (coding_system
))
5396 /* Decide the coding-system to encode the data with. */
5398 if (STRING_MULTIBYTE (object
))
5399 /* use default, we can't guess correct value */
5400 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5402 coding_system
= Qraw_text
;
5405 if (NILP (Fcoding_system_p (coding_system
)))
5407 /* Invalid coding system. */
5409 if (!NILP (noerror
))
5410 coding_system
= Qraw_text
;
5413 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5416 if (STRING_MULTIBYTE (object
))
5417 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5419 size
= SCHARS (object
);
5420 size_byte
= SBYTES (object
);
5424 CHECK_NUMBER (start
);
5426 start_char
= XINT (start
);
5431 start_byte
= string_char_to_byte (object
, start_char
);
5437 end_byte
= size_byte
;
5443 end_char
= XINT (end
);
5448 end_byte
= string_char_to_byte (object
, end_char
);
5451 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5452 args_out_of_range_3 (object
, make_number (start_char
),
5453 make_number (end_char
));
5457 CHECK_BUFFER (object
);
5459 bp
= XBUFFER (object
);
5465 CHECK_NUMBER_COERCE_MARKER (start
);
5473 CHECK_NUMBER_COERCE_MARKER (end
);
5478 temp
= b
, b
= e
, e
= temp
;
5480 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5481 args_out_of_range (start
, end
);
5483 if (NILP (coding_system
))
5485 /* Decide the coding-system to encode the data with.
5486 See fileio.c:Fwrite-region */
5488 if (!NILP (Vcoding_system_for_write
))
5489 coding_system
= Vcoding_system_for_write
;
5492 int force_raw_text
= 0;
5494 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5495 if (NILP (coding_system
)
5496 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5498 coding_system
= Qnil
;
5499 if (NILP (current_buffer
->enable_multibyte_characters
))
5503 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5505 /* Check file-coding-system-alist. */
5506 Lisp_Object args
[4], val
;
5508 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5509 args
[3] = Fbuffer_file_name(object
);
5510 val
= Ffind_operation_coding_system (4, args
);
5511 if (CONSP (val
) && !NILP (XCDR (val
)))
5512 coding_system
= XCDR (val
);
5515 if (NILP (coding_system
)
5516 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5518 /* If we still have not decided a coding system, use the
5519 default value of buffer-file-coding-system. */
5520 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5524 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5525 /* Confirm that VAL can surely encode the current region. */
5526 coding_system
= call4 (Vselect_safe_coding_system_function
,
5527 make_number (b
), make_number (e
),
5528 coding_system
, Qnil
);
5531 coding_system
= Qraw_text
;
5534 if (NILP (Fcoding_system_p (coding_system
)))
5536 /* Invalid coding system. */
5538 if (!NILP (noerror
))
5539 coding_system
= Qraw_text
;
5542 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5546 object
= make_buffer_string (b
, e
, 0);
5548 if (STRING_MULTIBYTE (object
))
5549 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5552 md5_buffer (SDATA (object
) + start_byte
,
5553 SBYTES (object
) - (size_byte
- end_byte
),
5556 for (i
= 0; i
< 16; i
++)
5557 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5560 return make_string (value
, 32);
5567 /* Hash table stuff. */
5568 Qhash_table_p
= intern ("hash-table-p");
5569 staticpro (&Qhash_table_p
);
5570 Qeq
= intern ("eq");
5572 Qeql
= intern ("eql");
5574 Qequal
= intern ("equal");
5575 staticpro (&Qequal
);
5576 QCtest
= intern (":test");
5577 staticpro (&QCtest
);
5578 QCsize
= intern (":size");
5579 staticpro (&QCsize
);
5580 QCrehash_size
= intern (":rehash-size");
5581 staticpro (&QCrehash_size
);
5582 QCrehash_threshold
= intern (":rehash-threshold");
5583 staticpro (&QCrehash_threshold
);
5584 QCweakness
= intern (":weakness");
5585 staticpro (&QCweakness
);
5586 Qkey
= intern ("key");
5588 Qvalue
= intern ("value");
5589 staticpro (&Qvalue
);
5590 Qhash_table_test
= intern ("hash-table-test");
5591 staticpro (&Qhash_table_test
);
5592 Qkey_or_value
= intern ("key-or-value");
5593 staticpro (&Qkey_or_value
);
5594 Qkey_and_value
= intern ("key-and-value");
5595 staticpro (&Qkey_and_value
);
5598 defsubr (&Smake_hash_table
);
5599 defsubr (&Scopy_hash_table
);
5600 defsubr (&Shash_table_count
);
5601 defsubr (&Shash_table_rehash_size
);
5602 defsubr (&Shash_table_rehash_threshold
);
5603 defsubr (&Shash_table_size
);
5604 defsubr (&Shash_table_test
);
5605 defsubr (&Shash_table_weakness
);
5606 defsubr (&Shash_table_p
);
5607 defsubr (&Sclrhash
);
5608 defsubr (&Sgethash
);
5609 defsubr (&Sputhash
);
5610 defsubr (&Sremhash
);
5611 defsubr (&Smaphash
);
5612 defsubr (&Sdefine_hash_table_test
);
5614 Qstring_lessp
= intern ("string-lessp");
5615 staticpro (&Qstring_lessp
);
5616 Qprovide
= intern ("provide");
5617 staticpro (&Qprovide
);
5618 Qrequire
= intern ("require");
5619 staticpro (&Qrequire
);
5620 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5621 staticpro (&Qyes_or_no_p_history
);
5622 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5623 staticpro (&Qcursor_in_echo_area
);
5624 Qwidget_type
= intern ("widget-type");
5625 staticpro (&Qwidget_type
);
5627 staticpro (&string_char_byte_cache_string
);
5628 string_char_byte_cache_string
= Qnil
;
5630 require_nesting_list
= Qnil
;
5631 staticpro (&require_nesting_list
);
5633 Fset (Qyes_or_no_p_history
, Qnil
);
5635 DEFVAR_LISP ("features", &Vfeatures
,
5636 doc
: /* A list of symbols which are the features of the executing emacs.
5637 Used by `featurep' and `require', and altered by `provide'. */);
5639 Qsubfeatures
= intern ("subfeatures");
5640 staticpro (&Qsubfeatures
);
5642 #ifdef HAVE_LANGINFO_CODESET
5643 Qcodeset
= intern ("codeset");
5644 staticpro (&Qcodeset
);
5645 Qdays
= intern ("days");
5647 Qmonths
= intern ("months");
5648 staticpro (&Qmonths
);
5649 Qpaper
= intern ("paper");
5650 staticpro (&Qpaper
);
5651 #endif /* HAVE_LANGINFO_CODESET */
5653 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5654 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5655 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5656 invoked by mouse clicks and mouse menu items. */);
5659 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5660 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5661 This applies to commands from menus and tool bar buttons. The value of
5662 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5663 used if both `use-dialog-box' and this variable are non-nil. */);
5664 use_file_dialog
= 1;
5666 defsubr (&Sidentity
);
5669 defsubr (&Ssafe_length
);
5670 defsubr (&Sstring_bytes
);
5671 defsubr (&Sstring_equal
);
5672 defsubr (&Scompare_strings
);
5673 defsubr (&Sstring_lessp
);
5676 defsubr (&Svconcat
);
5677 defsubr (&Scopy_sequence
);
5678 defsubr (&Sstring_make_multibyte
);
5679 defsubr (&Sstring_make_unibyte
);
5680 defsubr (&Sstring_as_multibyte
);
5681 defsubr (&Sstring_as_unibyte
);
5682 defsubr (&Sstring_to_multibyte
);
5683 defsubr (&Scopy_alist
);
5684 defsubr (&Ssubstring
);
5685 defsubr (&Ssubstring_no_properties
);
5697 defsubr (&Snreverse
);
5698 defsubr (&Sreverse
);
5700 defsubr (&Splist_get
);
5702 defsubr (&Splist_put
);
5704 defsubr (&Slax_plist_get
);
5705 defsubr (&Slax_plist_put
);
5707 defsubr (&Sfillarray
);
5708 defsubr (&Sclear_string
);
5709 defsubr (&Schar_table_subtype
);
5710 defsubr (&Schar_table_parent
);
5711 defsubr (&Sset_char_table_parent
);
5712 defsubr (&Schar_table_extra_slot
);
5713 defsubr (&Sset_char_table_extra_slot
);
5714 defsubr (&Schar_table_range
);
5715 defsubr (&Sset_char_table_range
);
5716 defsubr (&Sset_char_table_default
);
5717 defsubr (&Soptimize_char_table
);
5718 defsubr (&Smap_char_table
);
5722 defsubr (&Smapconcat
);
5723 defsubr (&Sy_or_n_p
);
5724 defsubr (&Syes_or_no_p
);
5725 defsubr (&Sload_average
);
5726 defsubr (&Sfeaturep
);
5727 defsubr (&Srequire
);
5728 defsubr (&Sprovide
);
5729 defsubr (&Splist_member
);
5730 defsubr (&Swidget_put
);
5731 defsubr (&Swidget_get
);
5732 defsubr (&Swidget_apply
);
5733 defsubr (&Sbase64_encode_region
);
5734 defsubr (&Sbase64_decode_region
);
5735 defsubr (&Sbase64_encode_string
);
5736 defsubr (&Sbase64_decode_string
);
5738 defsubr (&Slocale_info
);
5745 Vweak_hash_tables
= Qnil
;
5748 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5749 (do not change this comment) */