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 extern int minibuffer_auto_raise
;
63 extern Lisp_Object minibuf_window
;
64 extern Lisp_Object Vlocale_coding_system
;
66 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
67 Lisp_Object Qyes_or_no_p_history
;
68 Lisp_Object Qcursor_in_echo_area
;
69 Lisp_Object Qwidget_type
;
70 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
72 extern Lisp_Object Qinput_method_function
;
74 static int internal_equal ();
76 extern long get_random ();
77 extern void seed_random ();
83 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
84 doc
: /* Return the argument unchanged. */)
91 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
92 doc
: /* Return a pseudo-random number.
93 All integers representable in Lisp are equally likely.
94 On most systems, this is 28 bits' worth.
95 With positive integer argument N, return random number in interval [0,N).
96 With argument t, set the random number seed from the current time and pid. */)
101 Lisp_Object lispy_val
;
102 unsigned long denominator
;
105 seed_random (getpid () + time (NULL
));
106 if (NATNUMP (n
) && XFASTINT (n
) != 0)
108 /* Try to take our random number from the higher bits of VAL,
109 not the lower, since (says Gentzel) the low bits of `random'
110 are less random than the higher ones. We do this by using the
111 quotient rather than the remainder. At the high end of the RNG
112 it's possible to get a quotient larger than n; discarding
113 these values eliminates the bias that would otherwise appear
114 when using a large n. */
115 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
117 val
= get_random () / denominator
;
118 while (val
>= XFASTINT (n
));
122 XSETINT (lispy_val
, val
);
126 /* Random data-structure functions */
128 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
129 doc
: /* Return the length of vector, list or string SEQUENCE.
130 A byte-code function object is also allowed.
131 If the string contains multibyte characters, this is not necessarily
132 the number of bytes in the string; it is the number of characters.
133 To get the number of bytes, use `string-bytes'. */)
135 register Lisp_Object sequence
;
137 register Lisp_Object val
;
141 if (STRINGP (sequence
))
142 XSETFASTINT (val
, SCHARS (sequence
));
143 else if (VECTORP (sequence
))
144 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
145 else if (SUB_CHAR_TABLE_P (sequence
))
146 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
147 else if (CHAR_TABLE_P (sequence
))
148 XSETFASTINT (val
, MAX_CHAR
);
149 else if (BOOL_VECTOR_P (sequence
))
150 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
151 else if (COMPILEDP (sequence
))
152 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
153 else if (CONSP (sequence
))
156 while (CONSP (sequence
))
158 sequence
= XCDR (sequence
);
161 if (!CONSP (sequence
))
164 sequence
= XCDR (sequence
);
169 if (!NILP (sequence
))
170 wrong_type_argument (Qlistp
, sequence
);
172 val
= make_number (i
);
174 else if (NILP (sequence
))
175 XSETFASTINT (val
, 0);
178 sequence
= wrong_type_argument (Qsequencep
, sequence
);
184 /* This does not check for quits. That is safe
185 since it must terminate. */
187 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
188 doc
: /* Return the length of a list, but avoid error or infinite loop.
189 This function never gets an error. If LIST is not really a list,
190 it returns 0. If LIST is circular, it returns a finite value
191 which is at least the number of distinct elements. */)
195 Lisp_Object tail
, halftail
, length
;
198 /* halftail is used to detect circular lists. */
200 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
202 if (EQ (tail
, halftail
) && len
!= 0)
206 halftail
= XCDR (halftail
);
209 XSETINT (length
, len
);
213 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
214 doc
: /* Return the number of bytes in STRING.
215 If STRING is a multibyte string, this is greater than the length of STRING. */)
219 CHECK_STRING (string
);
220 return make_number (SBYTES (string
));
223 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
224 doc
: /* Return t if two strings have identical contents.
225 Case is significant, but text properties are ignored.
226 Symbols are also allowed; their print names are used instead. */)
228 register Lisp_Object s1
, s2
;
231 s1
= SYMBOL_NAME (s1
);
233 s2
= SYMBOL_NAME (s2
);
237 if (SCHARS (s1
) != SCHARS (s2
)
238 || SBYTES (s1
) != SBYTES (s2
)
239 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
244 DEFUN ("compare-strings", Fcompare_strings
,
245 Scompare_strings
, 6, 7, 0,
246 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
247 In string STR1, skip the first START1 characters and stop at END1.
248 In string STR2, skip the first START2 characters and stop at END2.
249 END1 and END2 default to the full lengths of the respective strings.
251 Case is significant in this comparison if IGNORE-CASE is nil.
252 Unibyte strings are converted to multibyte for comparison.
254 The value is t if the strings (or specified portions) match.
255 If string STR1 is less, the value is a negative number N;
256 - 1 - N is the number of characters that match at the beginning.
257 If string STR1 is greater, the value is a positive number N;
258 N - 1 is the number of characters that match at the beginning. */)
259 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
260 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
262 register int end1_char
, end2_char
;
263 register int i1
, i1_byte
, i2
, i2_byte
;
268 start1
= make_number (0);
270 start2
= make_number (0);
271 CHECK_NATNUM (start1
);
272 CHECK_NATNUM (start2
);
281 i1_byte
= string_char_to_byte (str1
, i1
);
282 i2_byte
= string_char_to_byte (str2
, i2
);
284 end1_char
= SCHARS (str1
);
285 if (! NILP (end1
) && end1_char
> XINT (end1
))
286 end1_char
= XINT (end1
);
288 end2_char
= SCHARS (str2
);
289 if (! NILP (end2
) && end2_char
> XINT (end2
))
290 end2_char
= XINT (end2
);
292 while (i1
< end1_char
&& i2
< end2_char
)
294 /* When we find a mismatch, we must compare the
295 characters, not just the bytes. */
298 if (STRING_MULTIBYTE (str1
))
299 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
302 c1
= SREF (str1
, i1
++);
303 c1
= unibyte_char_to_multibyte (c1
);
306 if (STRING_MULTIBYTE (str2
))
307 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
310 c2
= SREF (str2
, i2
++);
311 c2
= unibyte_char_to_multibyte (c2
);
317 if (! NILP (ignore_case
))
321 tem
= Fupcase (make_number (c1
));
323 tem
= Fupcase (make_number (c2
));
330 /* Note that I1 has already been incremented
331 past the character that we are comparing;
332 hence we don't add or subtract 1 here. */
334 return make_number (- i1
+ XINT (start1
));
336 return make_number (i1
- XINT (start1
));
340 return make_number (i1
- XINT (start1
) + 1);
342 return make_number (- i1
+ XINT (start1
) - 1);
347 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
348 doc
: /* Return t if first arg string is less than second in lexicographic order.
350 Symbols are also allowed; their print names are used instead. */)
352 register Lisp_Object s1
, s2
;
355 register int i1
, i1_byte
, i2
, i2_byte
;
358 s1
= SYMBOL_NAME (s1
);
360 s2
= SYMBOL_NAME (s2
);
364 i1
= i1_byte
= i2
= i2_byte
= 0;
367 if (end
> SCHARS (s2
))
372 /* When we find a mismatch, we must compare the
373 characters, not just the bytes. */
376 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
377 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
380 return c1
< c2
? Qt
: Qnil
;
382 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
385 static Lisp_Object
concat ();
396 return concat (2, args
, Lisp_String
, 0);
398 return concat (2, &s1
, Lisp_String
, 0);
399 #endif /* NO_ARG_ARRAY */
405 Lisp_Object s1
, s2
, s3
;
412 return concat (3, args
, Lisp_String
, 0);
414 return concat (3, &s1
, Lisp_String
, 0);
415 #endif /* NO_ARG_ARRAY */
418 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
419 doc
: /* Concatenate all the arguments and make the result a list.
420 The result is a list whose elements are the elements of all the arguments.
421 Each argument may be a list, vector or string.
422 The last argument is not copied, just used as the tail of the new list.
423 usage: (append &rest SEQUENCES) */)
428 return concat (nargs
, args
, Lisp_Cons
, 1);
431 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
432 doc
: /* Concatenate all the arguments and make the result a string.
433 The result is a string whose elements are the elements of all the arguments.
434 Each argument may be a string or a list or vector of characters (integers).
435 usage: (concat &rest SEQUENCES) */)
440 return concat (nargs
, args
, Lisp_String
, 0);
443 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
444 doc
: /* Concatenate all the arguments and make the result a vector.
445 The result is a vector whose elements are the elements of all the arguments.
446 Each argument may be a list, vector or string.
447 usage: (vconcat &rest SEQUENCES) */)
452 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
455 /* Return a copy of a sub char table ARG. The elements except for a
456 nested sub char table are not copied. */
458 copy_sub_char_table (arg
)
461 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
464 /* Copy all the contents. */
465 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
466 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
467 /* Recursively copy any sub char-tables in the ordinary slots. */
468 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
469 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
470 XCHAR_TABLE (copy
)->contents
[i
]
471 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
477 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
478 doc
: /* Return a copy of a list, vector, string or char-table.
479 The elements of a list or vector are not copied; they are shared
480 with the original. */)
484 if (NILP (arg
)) return arg
;
486 if (CHAR_TABLE_P (arg
))
491 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
492 /* Copy all the slots, including the extra ones. */
493 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
494 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
495 * sizeof (Lisp_Object
)));
497 /* Recursively copy any sub char tables in the ordinary slots
498 for multibyte characters. */
499 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
500 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
501 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
502 XCHAR_TABLE (copy
)->contents
[i
]
503 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
508 if (BOOL_VECTOR_P (arg
))
512 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
514 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
515 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
520 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
521 arg
= wrong_type_argument (Qsequencep
, arg
);
522 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
525 /* In string STR of length LEN, see if bytes before STR[I] combine
526 with bytes after STR[I] to form a single character. If so, return
527 the number of bytes after STR[I] which combine in this way.
528 Otherwize, return 0. */
531 count_combining (str
, len
, i
)
535 int j
= i
- 1, bytes
;
537 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
539 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
540 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
542 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
543 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
546 /* This structure holds information of an argument of `concat' that is
547 a string and has text properties to be copied. */
550 int argnum
; /* refer to ARGS (arguments of `concat') */
551 int from
; /* refer to ARGS[argnum] (argument string) */
552 int to
; /* refer to VAL (the target string) */
556 concat (nargs
, args
, target_type
, last_special
)
559 enum Lisp_Type target_type
;
563 register Lisp_Object tail
;
564 register Lisp_Object
this;
566 int toindex_byte
= 0;
567 register int result_len
;
568 register int result_len_byte
;
570 Lisp_Object last_tail
;
573 /* When we make a multibyte string, we can't copy text properties
574 while concatinating each string because the length of resulting
575 string can't be decided until we finish the whole concatination.
576 So, we record strings that have text properties to be copied
577 here, and copy the text properties after the concatination. */
578 struct textprop_rec
*textprops
= NULL
;
579 /* Number of elments in textprops. */
580 int num_textprops
= 0;
584 /* In append, the last arg isn't treated like the others */
585 if (last_special
&& nargs
> 0)
588 last_tail
= args
[nargs
];
593 /* Canonicalize each argument. */
594 for (argnum
= 0; argnum
< nargs
; argnum
++)
597 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
598 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
600 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
604 /* Compute total length in chars of arguments in RESULT_LEN.
605 If desired output is a string, also compute length in bytes
606 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
607 whether the result should be a multibyte string. */
611 for (argnum
= 0; argnum
< nargs
; argnum
++)
615 len
= XFASTINT (Flength (this));
616 if (target_type
== Lisp_String
)
618 /* We must count the number of bytes needed in the string
619 as well as the number of characters. */
625 for (i
= 0; i
< len
; i
++)
627 ch
= XVECTOR (this)->contents
[i
];
629 wrong_type_argument (Qintegerp
, ch
);
630 this_len_byte
= CHAR_BYTES (XINT (ch
));
631 result_len_byte
+= this_len_byte
;
632 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
635 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
636 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
637 else if (CONSP (this))
638 for (; CONSP (this); this = XCDR (this))
642 wrong_type_argument (Qintegerp
, ch
);
643 this_len_byte
= CHAR_BYTES (XINT (ch
));
644 result_len_byte
+= this_len_byte
;
645 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
648 else if (STRINGP (this))
650 if (STRING_MULTIBYTE (this))
653 result_len_byte
+= SBYTES (this);
656 result_len_byte
+= count_size_as_multibyte (SDATA (this),
664 if (! some_multibyte
)
665 result_len_byte
= result_len
;
667 /* Create the output object. */
668 if (target_type
== Lisp_Cons
)
669 val
= Fmake_list (make_number (result_len
), Qnil
);
670 else if (target_type
== Lisp_Vectorlike
)
671 val
= Fmake_vector (make_number (result_len
), Qnil
);
672 else if (some_multibyte
)
673 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
675 val
= make_uninit_string (result_len
);
677 /* In `append', if all but last arg are nil, return last arg. */
678 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
681 /* Copy the contents of the args into the result. */
683 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
685 toindex
= 0, toindex_byte
= 0;
690 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
692 for (argnum
= 0; argnum
< nargs
; argnum
++)
696 register unsigned int thisindex
= 0;
697 register unsigned int thisindex_byte
= 0;
701 thislen
= Flength (this), thisleni
= XINT (thislen
);
703 /* Between strings of the same kind, copy fast. */
704 if (STRINGP (this) && STRINGP (val
)
705 && STRING_MULTIBYTE (this) == some_multibyte
)
707 int thislen_byte
= SBYTES (this);
710 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
712 combined
= (some_multibyte
&& toindex_byte
> 0
713 ? count_combining (SDATA (val
),
714 toindex_byte
+ thislen_byte
,
717 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
719 textprops
[num_textprops
].argnum
= argnum
;
720 /* We ignore text properties on characters being combined. */
721 textprops
[num_textprops
].from
= combined
;
722 textprops
[num_textprops
++].to
= toindex
;
724 toindex_byte
+= thislen_byte
;
725 toindex
+= thisleni
- combined
;
726 STRING_SET_CHARS (val
, SCHARS (val
) - combined
);
728 /* Copy a single-byte string to a multibyte string. */
729 else if (STRINGP (this) && STRINGP (val
))
731 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
733 textprops
[num_textprops
].argnum
= argnum
;
734 textprops
[num_textprops
].from
= 0;
735 textprops
[num_textprops
++].to
= toindex
;
737 toindex_byte
+= copy_text (SDATA (this),
738 SDATA (val
) + toindex_byte
,
739 SCHARS (this), 0, 1);
743 /* Copy element by element. */
746 register Lisp_Object elt
;
748 /* Fetch next element of `this' arg into `elt', or break if
749 `this' is exhausted. */
750 if (NILP (this)) break;
752 elt
= XCAR (this), this = XCDR (this);
753 else if (thisindex
>= thisleni
)
755 else if (STRINGP (this))
758 if (STRING_MULTIBYTE (this))
760 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
763 XSETFASTINT (elt
, c
);
767 XSETFASTINT (elt
, SREF (this, thisindex
++));
769 && (XINT (elt
) >= 0240
770 || (XINT (elt
) >= 0200
771 && ! NILP (Vnonascii_translation_table
)))
772 && XINT (elt
) < 0400)
774 c
= unibyte_char_to_multibyte (XINT (elt
));
779 else if (BOOL_VECTOR_P (this))
782 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
783 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
790 elt
= XVECTOR (this)->contents
[thisindex
++];
792 /* Store this element into the result. */
799 else if (VECTORP (val
))
800 XVECTOR (val
)->contents
[toindex
++] = elt
;
804 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
808 += CHAR_STRING (XINT (elt
),
809 SDATA (val
) + toindex_byte
);
811 SSET (val
, toindex_byte
++, XINT (elt
));
814 && count_combining (SDATA (val
),
815 toindex_byte
, toindex_byte
- 1))
816 STRING_SET_CHARS (val
, SCHARS (val
) - 1);
821 /* If we have any multibyte characters,
822 we already decided to make a multibyte string. */
825 /* P exists as a variable
826 to avoid a bug on the Masscomp C compiler. */
827 unsigned char *p
= SDATA (val
) + toindex_byte
;
829 toindex_byte
+= CHAR_STRING (c
, p
);
836 XSETCDR (prev
, last_tail
);
838 if (num_textprops
> 0)
841 int last_to_end
= -1;
843 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
845 this = args
[textprops
[argnum
].argnum
];
846 props
= text_property_list (this,
848 make_number (SCHARS (this)),
850 /* If successive arguments have properites, be sure that the
851 value of `composition' property be the copy. */
852 if (last_to_end
== textprops
[argnum
].to
)
853 make_composition_value_copy (props
);
854 add_text_properties_from_list (val
, props
,
855 make_number (textprops
[argnum
].to
));
856 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
862 static Lisp_Object string_char_byte_cache_string
;
863 static int string_char_byte_cache_charpos
;
864 static int string_char_byte_cache_bytepos
;
867 clear_string_char_byte_cache ()
869 string_char_byte_cache_string
= Qnil
;
872 /* Return the character index corresponding to CHAR_INDEX in STRING. */
875 string_char_to_byte (string
, char_index
)
880 int best_below
, best_below_byte
;
881 int best_above
, best_above_byte
;
883 if (! STRING_MULTIBYTE (string
))
886 best_below
= best_below_byte
= 0;
887 best_above
= SCHARS (string
);
888 best_above_byte
= SBYTES (string
);
890 if (EQ (string
, string_char_byte_cache_string
))
892 if (string_char_byte_cache_charpos
< char_index
)
894 best_below
= string_char_byte_cache_charpos
;
895 best_below_byte
= string_char_byte_cache_bytepos
;
899 best_above
= string_char_byte_cache_charpos
;
900 best_above_byte
= string_char_byte_cache_bytepos
;
904 if (char_index
- best_below
< best_above
- char_index
)
906 while (best_below
< char_index
)
909 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
910 best_below
, best_below_byte
);
913 i_byte
= best_below_byte
;
917 while (best_above
> char_index
)
919 unsigned char *pend
= SDATA (string
) + best_above_byte
;
920 unsigned char *pbeg
= pend
- best_above_byte
;
921 unsigned char *p
= pend
- 1;
924 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
925 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
926 if (bytes
== pend
- p
)
927 best_above_byte
-= bytes
;
928 else if (bytes
> pend
- p
)
929 best_above_byte
-= (pend
- p
);
935 i_byte
= best_above_byte
;
938 string_char_byte_cache_bytepos
= i_byte
;
939 string_char_byte_cache_charpos
= i
;
940 string_char_byte_cache_string
= string
;
945 /* Return the character index corresponding to BYTE_INDEX in STRING. */
948 string_byte_to_char (string
, byte_index
)
953 int best_below
, best_below_byte
;
954 int best_above
, best_above_byte
;
956 if (! STRING_MULTIBYTE (string
))
959 best_below
= best_below_byte
= 0;
960 best_above
= SCHARS (string
);
961 best_above_byte
= SBYTES (string
);
963 if (EQ (string
, string_char_byte_cache_string
))
965 if (string_char_byte_cache_bytepos
< byte_index
)
967 best_below
= string_char_byte_cache_charpos
;
968 best_below_byte
= string_char_byte_cache_bytepos
;
972 best_above
= string_char_byte_cache_charpos
;
973 best_above_byte
= string_char_byte_cache_bytepos
;
977 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
979 while (best_below_byte
< byte_index
)
982 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
983 best_below
, best_below_byte
);
986 i_byte
= best_below_byte
;
990 while (best_above_byte
> byte_index
)
992 unsigned char *pend
= SDATA (string
) + best_above_byte
;
993 unsigned char *pbeg
= pend
- best_above_byte
;
994 unsigned char *p
= pend
- 1;
997 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
998 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
999 if (bytes
== pend
- p
)
1000 best_above_byte
-= bytes
;
1001 else if (bytes
> pend
- p
)
1002 best_above_byte
-= (pend
- p
);
1008 i_byte
= best_above_byte
;
1011 string_char_byte_cache_bytepos
= i_byte
;
1012 string_char_byte_cache_charpos
= i
;
1013 string_char_byte_cache_string
= string
;
1018 /* Convert STRING to a multibyte string.
1019 Single-byte characters 0240 through 0377 are converted
1020 by adding nonascii_insert_offset to each. */
1023 string_make_multibyte (string
)
1029 if (STRING_MULTIBYTE (string
))
1032 nbytes
= count_size_as_multibyte (SDATA (string
),
1034 /* If all the chars are ASCII, they won't need any more bytes
1035 once converted. In that case, we can return STRING itself. */
1036 if (nbytes
== SBYTES (string
))
1039 buf
= (unsigned char *) alloca (nbytes
);
1040 copy_text (SDATA (string
), buf
, SBYTES (string
),
1043 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1047 /* Convert STRING to a multibyte string without changing each
1048 character codes. Thus, characters 0200 trough 0237 are converted
1049 to eight-bit-control characters, and characters 0240 through 0377
1050 are converted eight-bit-graphic characters. */
1053 string_to_multibyte (string
)
1059 if (STRING_MULTIBYTE (string
))
1062 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1063 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1064 any more bytes once converted. */
1065 if (nbytes
== SBYTES (string
))
1066 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1068 buf
= (unsigned char *) alloca (nbytes
);
1069 bcopy (SDATA (string
), buf
, SBYTES (string
));
1070 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1072 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1076 /* Convert STRING to a single-byte string. */
1079 string_make_unibyte (string
)
1084 if (! STRING_MULTIBYTE (string
))
1087 buf
= (unsigned char *) alloca (SCHARS (string
));
1089 copy_text (SDATA (string
), buf
, SBYTES (string
),
1092 return make_unibyte_string (buf
, SCHARS (string
));
1095 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1097 doc
: /* Return the multibyte equivalent of STRING.
1098 The function `unibyte-char-to-multibyte' is used to convert
1099 each unibyte character to a multibyte character. */)
1103 CHECK_STRING (string
);
1105 return string_make_multibyte (string
);
1108 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1110 doc
: /* Return the unibyte equivalent of STRING.
1111 Multibyte character codes are converted to unibyte according to
1112 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1113 If the lookup in the translation table fails, this function takes just
1114 the low 8 bits of each character. */)
1118 CHECK_STRING (string
);
1120 return string_make_unibyte (string
);
1123 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1125 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1126 If STRING is unibyte, the result is STRING itself.
1127 Otherwise it is a newly created string, with no text properties.
1128 If STRING is multibyte and contains a character of charset
1129 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1130 corresponding single byte. */)
1134 CHECK_STRING (string
);
1136 if (STRING_MULTIBYTE (string
))
1138 int bytes
= SBYTES (string
);
1139 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1141 bcopy (SDATA (string
), str
, bytes
);
1142 bytes
= str_as_unibyte (str
, bytes
);
1143 string
= make_unibyte_string (str
, bytes
);
1149 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1151 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1152 If STRING is multibyte, the result is STRING itself.
1153 Otherwise it is a newly created string, with no text properties.
1154 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1155 part of a multibyte form), it is converted to the corresponding
1156 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1160 CHECK_STRING (string
);
1162 if (! STRING_MULTIBYTE (string
))
1164 Lisp_Object new_string
;
1167 parse_str_as_multibyte (SDATA (string
),
1170 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1171 bcopy (SDATA (string
), SDATA (new_string
),
1173 if (nbytes
!= SBYTES (string
))
1174 str_as_multibyte (SDATA (new_string
), nbytes
,
1175 SBYTES (string
), NULL
);
1176 string
= new_string
;
1177 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1182 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1184 doc
: /* Return a multibyte string with the same individual chars as STRING.
1185 If STRING is multibyte, the result is STRING itself.
1186 Otherwise it is a newly created string, with no text properties.
1187 Characters 0200 through 0237 are converted to eight-bit-control
1188 characters of the same character code. Characters 0240 through 0377
1189 are converted to eight-bit-graphic characters of the same character
1194 CHECK_STRING (string
);
1196 return string_to_multibyte (string
);
1200 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1201 doc
: /* Return a copy of ALIST.
1202 This is an alist which represents the same mapping from objects to objects,
1203 but does not share the alist structure with ALIST.
1204 The objects mapped (cars and cdrs of elements of the alist)
1205 are shared, however.
1206 Elements of ALIST that are not conses are also shared. */)
1210 register Lisp_Object tem
;
1215 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1216 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1218 register Lisp_Object car
;
1222 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1227 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1228 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1229 TO may be nil or omitted; then the substring runs to the end of STRING.
1230 FROM and TO start at 0. If either is negative, it counts from the end.
1232 This function allows vectors as well as strings. */)
1235 register Lisp_Object from
, to
;
1240 int from_char
, to_char
;
1241 int from_byte
= 0, to_byte
= 0;
1243 if (! (STRINGP (string
) || VECTORP (string
)))
1244 wrong_type_argument (Qarrayp
, string
);
1246 CHECK_NUMBER (from
);
1248 if (STRINGP (string
))
1250 size
= SCHARS (string
);
1251 size_byte
= SBYTES (string
);
1254 size
= XVECTOR (string
)->size
;
1259 to_byte
= size_byte
;
1265 to_char
= XINT (to
);
1269 if (STRINGP (string
))
1270 to_byte
= string_char_to_byte (string
, to_char
);
1273 from_char
= XINT (from
);
1276 if (STRINGP (string
))
1277 from_byte
= string_char_to_byte (string
, from_char
);
1279 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1280 args_out_of_range_3 (string
, make_number (from_char
),
1281 make_number (to_char
));
1283 if (STRINGP (string
))
1285 res
= make_specified_string (SDATA (string
) + from_byte
,
1286 to_char
- from_char
, to_byte
- from_byte
,
1287 STRING_MULTIBYTE (string
));
1288 copy_text_properties (make_number (from_char
), make_number (to_char
),
1289 string
, make_number (0), res
, Qnil
);
1292 res
= Fvector (to_char
- from_char
,
1293 XVECTOR (string
)->contents
+ from_char
);
1299 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1300 doc
: /* Return a substring of STRING, without text properties.
1301 It starts at index FROM and ending before TO.
1302 TO may be nil or omitted; then the substring runs to the end of STRING.
1303 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1304 If FROM or TO is negative, it counts from the end.
1306 With one argument, just copy STRING without its properties. */)
1309 register Lisp_Object from
, to
;
1311 int size
, size_byte
;
1312 int from_char
, to_char
;
1313 int from_byte
, to_byte
;
1315 CHECK_STRING (string
);
1317 size
= SCHARS (string
);
1318 size_byte
= SBYTES (string
);
1321 from_char
= from_byte
= 0;
1324 CHECK_NUMBER (from
);
1325 from_char
= XINT (from
);
1329 from_byte
= string_char_to_byte (string
, from_char
);
1335 to_byte
= size_byte
;
1341 to_char
= XINT (to
);
1345 to_byte
= string_char_to_byte (string
, to_char
);
1348 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1349 args_out_of_range_3 (string
, make_number (from_char
),
1350 make_number (to_char
));
1352 return make_specified_string (SDATA (string
) + from_byte
,
1353 to_char
- from_char
, to_byte
- from_byte
,
1354 STRING_MULTIBYTE (string
));
1357 /* Extract a substring of STRING, giving start and end positions
1358 both in characters and in bytes. */
1361 substring_both (string
, from
, from_byte
, to
, to_byte
)
1363 int from
, from_byte
, to
, to_byte
;
1369 if (! (STRINGP (string
) || VECTORP (string
)))
1370 wrong_type_argument (Qarrayp
, string
);
1372 if (STRINGP (string
))
1374 size
= SCHARS (string
);
1375 size_byte
= SBYTES (string
);
1378 size
= XVECTOR (string
)->size
;
1380 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1381 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1383 if (STRINGP (string
))
1385 res
= make_specified_string (SDATA (string
) + from_byte
,
1386 to
- from
, to_byte
- from_byte
,
1387 STRING_MULTIBYTE (string
));
1388 copy_text_properties (make_number (from
), make_number (to
),
1389 string
, make_number (0), res
, Qnil
);
1392 res
= Fvector (to
- from
,
1393 XVECTOR (string
)->contents
+ from
);
1398 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1399 doc
: /* Take cdr N times on LIST, returns the result. */)
1402 register Lisp_Object list
;
1404 register int i
, num
;
1407 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1411 wrong_type_argument (Qlistp
, list
);
1417 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1418 doc
: /* Return the Nth element of LIST.
1419 N counts from zero. If LIST is not that long, nil is returned. */)
1421 Lisp_Object n
, list
;
1423 return Fcar (Fnthcdr (n
, list
));
1426 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1427 doc
: /* Return element of SEQUENCE at index N. */)
1429 register Lisp_Object sequence
, n
;
1434 if (CONSP (sequence
) || NILP (sequence
))
1435 return Fcar (Fnthcdr (n
, sequence
));
1436 else if (STRINGP (sequence
) || VECTORP (sequence
)
1437 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1438 return Faref (sequence
, n
);
1440 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1444 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1445 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1446 The value is actually the tail of LIST whose car is ELT. */)
1448 register Lisp_Object elt
;
1451 register Lisp_Object tail
;
1452 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1454 register Lisp_Object tem
;
1456 wrong_type_argument (Qlistp
, list
);
1458 if (! NILP (Fequal (elt
, tem
)))
1465 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1466 doc
: /* Return non-nil if ELT is an element of LIST.
1467 Comparison done with EQ. The value is actually the tail of LIST
1468 whose car is ELT. */)
1470 Lisp_Object elt
, list
;
1474 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1478 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1482 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1489 if (!CONSP (list
) && !NILP (list
))
1490 list
= wrong_type_argument (Qlistp
, list
);
1495 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1496 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1497 The value is actually the first element of LIST whose car is KEY.
1498 Elements of LIST that are not conses are ignored. */)
1500 Lisp_Object key
, list
;
1507 || (CONSP (XCAR (list
))
1508 && EQ (XCAR (XCAR (list
)), key
)))
1513 || (CONSP (XCAR (list
))
1514 && EQ (XCAR (XCAR (list
)), key
)))
1519 || (CONSP (XCAR (list
))
1520 && EQ (XCAR (XCAR (list
)), key
)))
1528 result
= XCAR (list
);
1529 else if (NILP (list
))
1532 result
= wrong_type_argument (Qlistp
, list
);
1537 /* Like Fassq but never report an error and do not allow quits.
1538 Use only on lists known never to be circular. */
1541 assq_no_quit (key
, list
)
1542 Lisp_Object key
, list
;
1545 && (!CONSP (XCAR (list
))
1546 || !EQ (XCAR (XCAR (list
)), key
)))
1549 return CONSP (list
) ? XCAR (list
) : Qnil
;
1552 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1553 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1554 The value is actually the first element of LIST whose car equals KEY. */)
1556 Lisp_Object key
, list
;
1558 Lisp_Object result
, car
;
1563 || (CONSP (XCAR (list
))
1564 && (car
= XCAR (XCAR (list
)),
1565 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1570 || (CONSP (XCAR (list
))
1571 && (car
= XCAR (XCAR (list
)),
1572 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1577 || (CONSP (XCAR (list
))
1578 && (car
= XCAR (XCAR (list
)),
1579 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1587 result
= XCAR (list
);
1588 else if (NILP (list
))
1591 result
= wrong_type_argument (Qlistp
, list
);
1596 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1597 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1598 The value is actually the first element of LIST whose cdr is KEY. */)
1600 register Lisp_Object key
;
1608 || (CONSP (XCAR (list
))
1609 && EQ (XCDR (XCAR (list
)), key
)))
1614 || (CONSP (XCAR (list
))
1615 && EQ (XCDR (XCAR (list
)), key
)))
1620 || (CONSP (XCAR (list
))
1621 && EQ (XCDR (XCAR (list
)), key
)))
1630 else if (CONSP (list
))
1631 result
= XCAR (list
);
1633 result
= wrong_type_argument (Qlistp
, list
);
1638 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1639 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1640 The value is actually the first element of LIST whose cdr equals KEY. */)
1642 Lisp_Object key
, list
;
1644 Lisp_Object result
, cdr
;
1649 || (CONSP (XCAR (list
))
1650 && (cdr
= XCDR (XCAR (list
)),
1651 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1656 || (CONSP (XCAR (list
))
1657 && (cdr
= XCDR (XCAR (list
)),
1658 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1663 || (CONSP (XCAR (list
))
1664 && (cdr
= XCDR (XCAR (list
)),
1665 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1673 result
= XCAR (list
);
1674 else if (NILP (list
))
1677 result
= wrong_type_argument (Qlistp
, list
);
1682 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1683 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1684 The modified LIST is returned. Comparison is done with `eq'.
1685 If the first member of LIST is ELT, there is no way to remove it by side effect;
1686 therefore, write `(setq foo (delq element foo))'
1687 to be sure of changing the value of `foo'. */)
1689 register Lisp_Object elt
;
1692 register Lisp_Object tail
, prev
;
1693 register Lisp_Object tem
;
1697 while (!NILP (tail
))
1700 wrong_type_argument (Qlistp
, list
);
1707 Fsetcdr (prev
, XCDR (tail
));
1717 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1718 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1719 SEQ must be a list, a vector, or a string.
1720 The modified SEQ is returned. Comparison is done with `equal'.
1721 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1722 is not a side effect; it is simply using a different sequence.
1723 Therefore, write `(setq foo (delete element foo))'
1724 to be sure of changing the value of `foo'. */)
1726 Lisp_Object elt
, seq
;
1732 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1733 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1736 if (n
!= ASIZE (seq
))
1738 struct Lisp_Vector
*p
= allocate_vector (n
);
1740 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1741 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1742 p
->contents
[n
++] = AREF (seq
, i
);
1744 XSETVECTOR (seq
, p
);
1747 else if (STRINGP (seq
))
1749 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1752 for (i
= nchars
= nbytes
= ibyte
= 0;
1754 ++i
, ibyte
+= cbytes
)
1756 if (STRING_MULTIBYTE (seq
))
1758 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1759 SBYTES (seq
) - ibyte
);
1760 cbytes
= CHAR_BYTES (c
);
1768 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1775 if (nchars
!= SCHARS (seq
))
1779 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1780 if (!STRING_MULTIBYTE (seq
))
1781 STRING_SET_UNIBYTE (tem
);
1783 for (i
= nchars
= nbytes
= ibyte
= 0;
1785 ++i
, ibyte
+= cbytes
)
1787 if (STRING_MULTIBYTE (seq
))
1789 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1790 SBYTES (seq
) - ibyte
);
1791 cbytes
= CHAR_BYTES (c
);
1799 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1801 unsigned char *from
= SDATA (seq
) + ibyte
;
1802 unsigned char *to
= SDATA (tem
) + nbytes
;
1808 for (n
= cbytes
; n
--; )
1818 Lisp_Object tail
, prev
;
1820 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1823 wrong_type_argument (Qlistp
, seq
);
1825 if (!NILP (Fequal (elt
, XCAR (tail
))))
1830 Fsetcdr (prev
, XCDR (tail
));
1841 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1842 doc
: /* Reverse LIST by modifying cdr pointers.
1843 Return the reversed list. */)
1847 register Lisp_Object prev
, tail
, next
;
1849 if (NILP (list
)) return list
;
1852 while (!NILP (tail
))
1856 wrong_type_argument (Qlistp
, list
);
1858 Fsetcdr (tail
, prev
);
1865 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1866 doc
: /* Reverse LIST, copying. Return the reversed list.
1867 See also the function `nreverse', which is used more often. */)
1873 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1876 new = Fcons (XCAR (list
), new);
1879 wrong_type_argument (Qconsp
, list
);
1883 Lisp_Object
merge ();
1885 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1886 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1887 Returns the sorted list. LIST is modified by side effects.
1888 PREDICATE is called with two elements of LIST, and should return t
1889 if the first element is "less" than the second. */)
1891 Lisp_Object list
, predicate
;
1893 Lisp_Object front
, back
;
1894 register Lisp_Object len
, tem
;
1895 struct gcpro gcpro1
, gcpro2
;
1896 register int length
;
1899 len
= Flength (list
);
1900 length
= XINT (len
);
1904 XSETINT (len
, (length
/ 2) - 1);
1905 tem
= Fnthcdr (len
, list
);
1907 Fsetcdr (tem
, Qnil
);
1909 GCPRO2 (front
, back
);
1910 front
= Fsort (front
, predicate
);
1911 back
= Fsort (back
, predicate
);
1913 return merge (front
, back
, predicate
);
1917 merge (org_l1
, org_l2
, pred
)
1918 Lisp_Object org_l1
, org_l2
;
1922 register Lisp_Object tail
;
1924 register Lisp_Object l1
, l2
;
1925 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1932 /* It is sufficient to protect org_l1 and org_l2.
1933 When l1 and l2 are updated, we copy the new values
1934 back into the org_ vars. */
1935 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1955 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1971 Fsetcdr (tail
, tem
);
1977 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1978 doc
: /* Extract a value from a property list.
1979 PLIST is a property list, which is a list of the form
1980 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1981 corresponding to the given PROP, or nil if PROP is not
1982 one of the properties on the list. */)
1990 CONSP (tail
) && CONSP (XCDR (tail
));
1991 tail
= XCDR (XCDR (tail
)))
1993 if (EQ (prop
, XCAR (tail
)))
1994 return XCAR (XCDR (tail
));
1996 /* This function can be called asynchronously
1997 (setup_coding_system). Don't QUIT in that case. */
1998 if (!interrupt_input_blocked
)
2003 wrong_type_argument (Qlistp
, prop
);
2008 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2009 doc
: /* Return the value of SYMBOL's PROPNAME property.
2010 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2012 Lisp_Object symbol
, propname
;
2014 CHECK_SYMBOL (symbol
);
2015 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2018 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2019 doc
: /* Change value in PLIST of PROP to VAL.
2020 PLIST is a property list, which is a list of the form
2021 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2022 If PROP is already a property on the list, its value is set to VAL,
2023 otherwise the new PROP VAL pair is added. The new plist is returned;
2024 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2025 The PLIST is modified by side effects. */)
2028 register Lisp_Object prop
;
2031 register Lisp_Object tail
, prev
;
2032 Lisp_Object newcell
;
2034 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2035 tail
= XCDR (XCDR (tail
)))
2037 if (EQ (prop
, XCAR (tail
)))
2039 Fsetcar (XCDR (tail
), val
);
2046 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2050 Fsetcdr (XCDR (prev
), newcell
);
2054 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2055 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2056 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2057 (symbol
, propname
, value
)
2058 Lisp_Object symbol
, propname
, value
;
2060 CHECK_SYMBOL (symbol
);
2061 XSYMBOL (symbol
)->plist
2062 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2066 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2067 doc
: /* Extract a value from a property list, comparing with `equal'.
2068 PLIST is a property list, which is a list of the form
2069 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2070 corresponding to the given PROP, or nil if PROP is not
2071 one of the properties on the list. */)
2079 CONSP (tail
) && CONSP (XCDR (tail
));
2080 tail
= XCDR (XCDR (tail
)))
2082 if (! NILP (Fequal (prop
, XCAR (tail
))))
2083 return XCAR (XCDR (tail
));
2089 wrong_type_argument (Qlistp
, prop
);
2094 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2095 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2096 PLIST is a property list, which is a list of the form
2097 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2098 If PROP is already a property on the list, its value is set to VAL,
2099 otherwise the new PROP VAL pair is added. The new plist is returned;
2100 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2101 The PLIST is modified by side effects. */)
2104 register Lisp_Object prop
;
2107 register Lisp_Object tail
, prev
;
2108 Lisp_Object newcell
;
2110 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2111 tail
= XCDR (XCDR (tail
)))
2113 if (! NILP (Fequal (prop
, XCAR (tail
))))
2115 Fsetcar (XCDR (tail
), val
);
2122 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2126 Fsetcdr (XCDR (prev
), newcell
);
2130 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2131 doc
: /* Return t if two Lisp objects have similar structure and contents.
2132 They must have the same data type.
2133 Conses are compared by comparing the cars and the cdrs.
2134 Vectors and strings are compared element by element.
2135 Numbers are compared by value, but integers cannot equal floats.
2136 (Use `=' if you want integers and floats to be able to be equal.)
2137 Symbols must match exactly. */)
2139 register Lisp_Object o1
, o2
;
2141 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2145 internal_equal (o1
, o2
, depth
)
2146 register Lisp_Object o1
, o2
;
2150 error ("Stack overflow in equal");
2156 if (XTYPE (o1
) != XTYPE (o2
))
2162 return (extract_float (o1
) == extract_float (o2
));
2165 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2172 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2176 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2178 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2181 o1
= XOVERLAY (o1
)->plist
;
2182 o2
= XOVERLAY (o2
)->plist
;
2187 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2188 && (XMARKER (o1
)->buffer
== 0
2189 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2193 case Lisp_Vectorlike
:
2196 EMACS_INT size
= XVECTOR (o1
)->size
;
2197 /* Pseudovectors have the type encoded in the size field, so this test
2198 actually checks that the objects have the same type as well as the
2200 if (XVECTOR (o2
)->size
!= size
)
2202 /* Boolvectors are compared much like strings. */
2203 if (BOOL_VECTOR_P (o1
))
2206 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2208 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2210 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2215 if (WINDOW_CONFIGURATIONP (o1
))
2216 return compare_window_configurations (o1
, o2
, 0);
2218 /* Aside from them, only true vectors, char-tables, and compiled
2219 functions are sensible to compare, so eliminate the others now. */
2220 if (size
& PSEUDOVECTOR_FLAG
)
2222 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2224 size
&= PSEUDOVECTOR_SIZE_MASK
;
2226 for (i
= 0; i
< size
; i
++)
2229 v1
= XVECTOR (o1
)->contents
[i
];
2230 v2
= XVECTOR (o2
)->contents
[i
];
2231 if (!internal_equal (v1
, v2
, depth
+ 1))
2239 if (SCHARS (o1
) != SCHARS (o2
))
2241 if (SBYTES (o1
) != SBYTES (o2
))
2243 if (bcmp (SDATA (o1
), SDATA (o2
),
2250 case Lisp_Type_Limit
:
2257 extern Lisp_Object
Fmake_char_internal ();
2259 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2260 doc
: /* Store each element of ARRAY with ITEM.
2261 ARRAY is a vector, string, char-table, or bool-vector. */)
2263 Lisp_Object array
, item
;
2265 register int size
, index
, charval
;
2267 if (VECTORP (array
))
2269 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2270 size
= XVECTOR (array
)->size
;
2271 for (index
= 0; index
< size
; index
++)
2274 else if (CHAR_TABLE_P (array
))
2276 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2277 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2278 for (index
= 0; index
< size
; index
++)
2280 XCHAR_TABLE (array
)->defalt
= Qnil
;
2282 else if (STRINGP (array
))
2284 register unsigned char *p
= SDATA (array
);
2285 CHECK_NUMBER (item
);
2286 charval
= XINT (item
);
2287 size
= SCHARS (array
);
2288 if (STRING_MULTIBYTE (array
))
2290 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2291 int len
= CHAR_STRING (charval
, str
);
2292 int size_byte
= SBYTES (array
);
2293 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2296 if (size
!= size_byte
)
2299 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2300 if (len
!= this_len
)
2301 error ("Attempt to change byte length of a string");
2304 for (i
= 0; i
< size_byte
; i
++)
2305 *p
++ = str
[i
% len
];
2308 for (index
= 0; index
< size
; index
++)
2311 else if (BOOL_VECTOR_P (array
))
2313 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2315 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2317 charval
= (! NILP (item
) ? -1 : 0);
2318 for (index
= 0; index
< size_in_chars
- 1; index
++)
2320 if (index
< size_in_chars
)
2322 /* Mask out bits beyond the vector size. */
2323 if (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)
2324 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BITS_PER_CHAR
)) - 1;
2330 array
= wrong_type_argument (Qarrayp
, array
);
2336 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2338 doc
: /* Clear the contents of STRING.
2339 This makes STRING unibyte and may change its length. */)
2343 int len
= SBYTES (string
);
2344 bzero (SDATA (string
), len
);
2345 STRING_SET_CHARS (string
, len
);
2346 STRING_SET_UNIBYTE (string
);
2350 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2352 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2354 Lisp_Object char_table
;
2356 CHECK_CHAR_TABLE (char_table
);
2358 return XCHAR_TABLE (char_table
)->purpose
;
2361 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2363 doc
: /* Return the parent char-table of CHAR-TABLE.
2364 The value is either nil or another char-table.
2365 If CHAR-TABLE holds nil for a given character,
2366 then the actual applicable value is inherited from the parent char-table
2367 \(or from its parents, if necessary). */)
2369 Lisp_Object char_table
;
2371 CHECK_CHAR_TABLE (char_table
);
2373 return XCHAR_TABLE (char_table
)->parent
;
2376 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2378 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2379 Return PARENT. PARENT must be either nil or another char-table. */)
2380 (char_table
, parent
)
2381 Lisp_Object char_table
, parent
;
2385 CHECK_CHAR_TABLE (char_table
);
2389 CHECK_CHAR_TABLE (parent
);
2391 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2392 if (EQ (temp
, char_table
))
2393 error ("Attempt to make a chartable be its own parent");
2396 XCHAR_TABLE (char_table
)->parent
= parent
;
2401 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2403 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2405 Lisp_Object char_table
, n
;
2407 CHECK_CHAR_TABLE (char_table
);
2410 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2411 args_out_of_range (char_table
, n
);
2413 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2416 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2417 Sset_char_table_extra_slot
,
2419 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2420 (char_table
, n
, value
)
2421 Lisp_Object char_table
, n
, value
;
2423 CHECK_CHAR_TABLE (char_table
);
2426 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2427 args_out_of_range (char_table
, n
);
2429 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2432 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2434 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2435 RANGE should be nil (for the default value)
2436 a vector which identifies a character set or a row of a character set,
2437 a character set name, or a character code. */)
2439 Lisp_Object char_table
, range
;
2441 CHECK_CHAR_TABLE (char_table
);
2443 if (EQ (range
, Qnil
))
2444 return XCHAR_TABLE (char_table
)->defalt
;
2445 else if (INTEGERP (range
))
2446 return Faref (char_table
, range
);
2447 else if (SYMBOLP (range
))
2449 Lisp_Object charset_info
;
2451 charset_info
= Fget (range
, Qcharset
);
2452 CHECK_VECTOR (charset_info
);
2454 return Faref (char_table
,
2455 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2458 else if (VECTORP (range
))
2460 if (XVECTOR (range
)->size
== 1)
2461 return Faref (char_table
,
2462 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2465 int size
= XVECTOR (range
)->size
;
2466 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2467 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2468 size
<= 1 ? Qnil
: val
[1],
2469 size
<= 2 ? Qnil
: val
[2]);
2470 return Faref (char_table
, ch
);
2474 error ("Invalid RANGE argument to `char-table-range'");
2478 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2480 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2481 RANGE should be t (for all characters), nil (for the default value)
2482 a vector which identifies a character set or a row of a character set,
2483 a coding system, or a character code. */)
2484 (char_table
, range
, value
)
2485 Lisp_Object char_table
, range
, value
;
2489 CHECK_CHAR_TABLE (char_table
);
2492 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2493 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2494 else if (EQ (range
, Qnil
))
2495 XCHAR_TABLE (char_table
)->defalt
= value
;
2496 else if (SYMBOLP (range
))
2498 Lisp_Object charset_info
;
2500 charset_info
= Fget (range
, Qcharset
);
2501 CHECK_VECTOR (charset_info
);
2503 return Faset (char_table
,
2504 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2508 else if (INTEGERP (range
))
2509 Faset (char_table
, range
, value
);
2510 else if (VECTORP (range
))
2512 if (XVECTOR (range
)->size
== 1)
2513 return Faset (char_table
,
2514 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2518 int size
= XVECTOR (range
)->size
;
2519 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2520 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2521 size
<= 1 ? Qnil
: val
[1],
2522 size
<= 2 ? Qnil
: val
[2]);
2523 return Faset (char_table
, ch
, value
);
2527 error ("Invalid RANGE argument to `set-char-table-range'");
2532 DEFUN ("set-char-table-default", Fset_char_table_default
,
2533 Sset_char_table_default
, 3, 3, 0,
2534 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2535 The generic character specifies the group of characters.
2536 See also the documentation of `make-char'. */)
2537 (char_table
, ch
, value
)
2538 Lisp_Object char_table
, ch
, value
;
2540 int c
, charset
, code1
, code2
;
2543 CHECK_CHAR_TABLE (char_table
);
2547 SPLIT_CHAR (c
, charset
, code1
, code2
);
2549 /* Since we may want to set the default value for a character set
2550 not yet defined, we check only if the character set is in the
2551 valid range or not, instead of it is already defined or not. */
2552 if (! CHARSET_VALID_P (charset
))
2553 invalid_character (c
);
2555 if (charset
== CHARSET_ASCII
)
2556 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2558 /* Even if C is not a generic char, we had better behave as if a
2559 generic char is specified. */
2560 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2562 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2565 if (SUB_CHAR_TABLE_P (temp
))
2566 XCHAR_TABLE (temp
)->defalt
= value
;
2568 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2571 if (SUB_CHAR_TABLE_P (temp
))
2574 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2575 = make_sub_char_table (temp
));
2576 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2577 if (SUB_CHAR_TABLE_P (temp
))
2578 XCHAR_TABLE (temp
)->defalt
= value
;
2580 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2584 /* Look up the element in TABLE at index CH,
2585 and return it as an integer.
2586 If the element is nil, return CH itself.
2587 (Actually we do that for any non-integer.) */
2590 char_table_translate (table
, ch
)
2595 value
= Faref (table
, make_number (ch
));
2596 if (! INTEGERP (value
))
2598 return XINT (value
);
2602 optimize_sub_char_table (table
, chars
)
2610 from
= 33, to
= 127;
2612 from
= 32, to
= 128;
2614 if (!SUB_CHAR_TABLE_P (*table
))
2616 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2617 for (; from
< to
; from
++)
2618 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2623 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2624 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2632 CHECK_CHAR_TABLE (table
);
2634 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2636 elt
= XCHAR_TABLE (table
)->contents
[i
];
2637 if (!SUB_CHAR_TABLE_P (elt
))
2639 dim
= CHARSET_DIMENSION (i
- 128);
2641 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2642 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2643 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2649 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2650 character or group of characters that share a value.
2651 DEPTH is the current depth in the originally specified
2652 chartable, and INDICES contains the vector indices
2653 for the levels our callers have descended.
2655 ARG is passed to C_FUNCTION when that is called. */
2658 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2659 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2660 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2667 /* At first, handle ASCII and 8-bit European characters. */
2668 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2670 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2672 elt
= XCHAR_TABLE (subtable
)->defalt
;
2674 elt
= Faref (subtable
, make_number (i
));
2676 (*c_function
) (arg
, make_number (i
), elt
);
2678 call2 (function
, make_number (i
), elt
);
2680 #if 0 /* If the char table has entries for higher characters,
2681 we should report them. */
2682 if (NILP (current_buffer
->enable_multibyte_characters
))
2685 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2689 int charset
= XFASTINT (indices
[0]) - 128;
2692 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2693 if (CHARSET_CHARS (charset
) == 94)
2702 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2703 XSETFASTINT (indices
[depth
], i
);
2704 charset
= XFASTINT (indices
[0]) - 128;
2706 && (!CHARSET_DEFINED_P (charset
)
2707 || charset
== CHARSET_8_BIT_CONTROL
2708 || charset
== CHARSET_8_BIT_GRAPHIC
))
2711 if (SUB_CHAR_TABLE_P (elt
))
2714 error ("Too deep char table");
2715 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2721 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2722 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2723 c
= MAKE_CHAR (charset
, c1
, c2
);
2726 elt
= XCHAR_TABLE (subtable
)->defalt
;
2728 elt
= Faref (table
, make_number (c
));
2731 (*c_function
) (arg
, make_number (c
), elt
);
2733 call2 (function
, make_number (c
), elt
);
2738 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2740 void_call2 (a
, b
, c
)
2741 Lisp_Object a
, b
, c
;
2746 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2748 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2749 FUNCTION is called with two arguments--a key and a value.
2750 The key is always a possible IDX argument to `aref'. */)
2751 (function
, char_table
)
2752 Lisp_Object function
, char_table
;
2754 /* The depth of char table is at most 3. */
2755 Lisp_Object indices
[3];
2757 CHECK_CHAR_TABLE (char_table
);
2759 /* When Lisp_Object is represented as a union, `call2' cannot directly
2760 be passed to map_char_table because it returns a Lisp_Object rather
2761 than returning nothing.
2762 Casting leads to crashes on some architectures. -stef */
2763 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2767 /* Return a value for character C in char-table TABLE. Store the
2768 actual index for that value in *IDX. Ignore the default value of
2772 char_table_ref_and_index (table
, c
, idx
)
2776 int charset
, c1
, c2
;
2779 if (SINGLE_BYTE_CHAR_P (c
))
2782 return XCHAR_TABLE (table
)->contents
[c
];
2784 SPLIT_CHAR (c
, charset
, c1
, c2
);
2785 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2786 *idx
= MAKE_CHAR (charset
, 0, 0);
2787 if (!SUB_CHAR_TABLE_P (elt
))
2789 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2790 return XCHAR_TABLE (elt
)->defalt
;
2791 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2792 *idx
= MAKE_CHAR (charset
, c1
, 0);
2793 if (!SUB_CHAR_TABLE_P (elt
))
2795 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2796 return XCHAR_TABLE (elt
)->defalt
;
2798 return XCHAR_TABLE (elt
)->contents
[c2
];
2808 Lisp_Object args
[2];
2811 return Fnconc (2, args
);
2813 return Fnconc (2, &s1
);
2814 #endif /* NO_ARG_ARRAY */
2817 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2818 doc
: /* Concatenate any number of lists by altering them.
2819 Only the last argument is not altered, and need not be a list.
2820 usage: (nconc &rest LISTS) */)
2825 register int argnum
;
2826 register Lisp_Object tail
, tem
, val
;
2830 for (argnum
= 0; argnum
< nargs
; argnum
++)
2833 if (NILP (tem
)) continue;
2838 if (argnum
+ 1 == nargs
) break;
2841 tem
= wrong_type_argument (Qlistp
, tem
);
2850 tem
= args
[argnum
+ 1];
2851 Fsetcdr (tail
, tem
);
2853 args
[argnum
+ 1] = tail
;
2859 /* This is the guts of all mapping functions.
2860 Apply FN to each element of SEQ, one by one,
2861 storing the results into elements of VALS, a C vector of Lisp_Objects.
2862 LENI is the length of VALS, which should also be the length of SEQ. */
2865 mapcar1 (leni
, vals
, fn
, seq
)
2868 Lisp_Object fn
, seq
;
2870 register Lisp_Object tail
;
2873 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2877 /* Don't let vals contain any garbage when GC happens. */
2878 for (i
= 0; i
< leni
; i
++)
2881 GCPRO3 (dummy
, fn
, seq
);
2883 gcpro1
.nvars
= leni
;
2887 /* We need not explicitly protect `tail' because it is used only on lists, and
2888 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2892 for (i
= 0; i
< leni
; i
++)
2894 dummy
= XVECTOR (seq
)->contents
[i
];
2895 dummy
= call1 (fn
, dummy
);
2900 else if (BOOL_VECTOR_P (seq
))
2902 for (i
= 0; i
< leni
; i
++)
2905 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2906 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2911 dummy
= call1 (fn
, dummy
);
2916 else if (STRINGP (seq
))
2920 for (i
= 0, i_byte
= 0; i
< leni
;)
2925 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2926 XSETFASTINT (dummy
, c
);
2927 dummy
= call1 (fn
, dummy
);
2929 vals
[i_before
] = dummy
;
2932 else /* Must be a list, since Flength did not get an error */
2935 for (i
= 0; i
< leni
; i
++)
2937 dummy
= call1 (fn
, Fcar (tail
));
2947 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2948 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2949 In between each pair of results, stick in SEPARATOR. Thus, " " as
2950 SEPARATOR results in spaces between the values returned by FUNCTION.
2951 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2952 (function
, sequence
, separator
)
2953 Lisp_Object function
, sequence
, separator
;
2958 register Lisp_Object
*args
;
2960 struct gcpro gcpro1
;
2962 len
= Flength (sequence
);
2964 nargs
= leni
+ leni
- 1;
2965 if (nargs
< 0) return build_string ("");
2967 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2970 mapcar1 (leni
, args
, function
, sequence
);
2973 for (i
= leni
- 1; i
>= 0; i
--)
2974 args
[i
+ i
] = args
[i
];
2976 for (i
= 1; i
< nargs
; i
+= 2)
2977 args
[i
] = separator
;
2979 return Fconcat (nargs
, args
);
2982 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2983 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2984 The result is a list just as long as SEQUENCE.
2985 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2986 (function
, sequence
)
2987 Lisp_Object function
, sequence
;
2989 register Lisp_Object len
;
2991 register Lisp_Object
*args
;
2993 len
= Flength (sequence
);
2994 leni
= XFASTINT (len
);
2995 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2997 mapcar1 (leni
, args
, function
, sequence
);
2999 return Flist (leni
, args
);
3002 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3003 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3004 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3005 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3006 (function
, sequence
)
3007 Lisp_Object function
, sequence
;
3011 leni
= XFASTINT (Flength (sequence
));
3012 mapcar1 (leni
, 0, function
, sequence
);
3017 /* Anything that calls this function must protect from GC! */
3019 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3020 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3021 Takes one argument, which is the string to display to ask the question.
3022 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3023 No confirmation of the answer is requested; a single character is enough.
3024 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3025 the bindings in `query-replace-map'; see the documentation of that variable
3026 for more information. In this case, the useful bindings are `act', `skip',
3027 `recenter', and `quit'.\)
3029 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3030 is nil and `use-dialog-box' is non-nil. */)
3034 register Lisp_Object obj
, key
, def
, map
;
3035 register int answer
;
3036 Lisp_Object xprompt
;
3037 Lisp_Object args
[2];
3038 struct gcpro gcpro1
, gcpro2
;
3039 int count
= SPECPDL_INDEX ();
3041 specbind (Qcursor_in_echo_area
, Qt
);
3043 map
= Fsymbol_value (intern ("query-replace-map"));
3045 CHECK_STRING (prompt
);
3047 GCPRO2 (prompt
, xprompt
);
3049 #ifdef HAVE_X_WINDOWS
3050 if (display_hourglass_p
)
3051 cancel_hourglass ();
3058 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3062 Lisp_Object pane
, menu
;
3063 redisplay_preserve_echo_area (3);
3064 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3065 Fcons (Fcons (build_string ("No"), Qnil
),
3067 menu
= Fcons (prompt
, pane
);
3068 obj
= Fx_popup_dialog (Qt
, menu
);
3069 answer
= !NILP (obj
);
3072 #endif /* HAVE_MENUS */
3073 cursor_in_echo_area
= 1;
3074 choose_minibuf_frame ();
3077 Lisp_Object pargs
[3];
3079 /* Colorize prompt according to `minibuffer-prompt' face. */
3080 pargs
[0] = build_string ("%s(y or n) ");
3081 pargs
[1] = intern ("face");
3082 pargs
[2] = intern ("minibuffer-prompt");
3083 args
[0] = Fpropertize (3, pargs
);
3088 if (minibuffer_auto_raise
)
3090 Lisp_Object mini_frame
;
3092 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3094 Fraise_frame (mini_frame
);
3097 obj
= read_filtered_event (1, 0, 0, 0);
3098 cursor_in_echo_area
= 0;
3099 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3102 key
= Fmake_vector (make_number (1), obj
);
3103 def
= Flookup_key (map
, key
, Qt
);
3105 if (EQ (def
, intern ("skip")))
3110 else if (EQ (def
, intern ("act")))
3115 else if (EQ (def
, intern ("recenter")))
3121 else if (EQ (def
, intern ("quit")))
3123 /* We want to exit this command for exit-prefix,
3124 and this is the only way to do it. */
3125 else if (EQ (def
, intern ("exit-prefix")))
3130 /* If we don't clear this, then the next call to read_char will
3131 return quit_char again, and we'll enter an infinite loop. */
3136 if (EQ (xprompt
, prompt
))
3138 args
[0] = build_string ("Please answer y or n. ");
3140 xprompt
= Fconcat (2, args
);
3145 if (! noninteractive
)
3147 cursor_in_echo_area
= -1;
3148 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3152 unbind_to (count
, Qnil
);
3153 return answer
? Qt
: Qnil
;
3156 /* This is how C code calls `yes-or-no-p' and allows the user
3159 Anything that calls this function must protect from GC! */
3162 do_yes_or_no_p (prompt
)
3165 return call1 (intern ("yes-or-no-p"), prompt
);
3168 /* Anything that calls this function must protect from GC! */
3170 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3171 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3172 Takes one argument, which is the string to display to ask the question.
3173 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3174 The user must confirm the answer with RET,
3175 and can edit it until it has been confirmed.
3177 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3178 is nil, and `use-dialog-box' is non-nil. */)
3182 register Lisp_Object ans
;
3183 Lisp_Object args
[2];
3184 struct gcpro gcpro1
;
3186 CHECK_STRING (prompt
);
3189 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3193 Lisp_Object pane
, menu
, obj
;
3194 redisplay_preserve_echo_area (4);
3195 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3196 Fcons (Fcons (build_string ("No"), Qnil
),
3199 menu
= Fcons (prompt
, pane
);
3200 obj
= Fx_popup_dialog (Qt
, menu
);
3204 #endif /* HAVE_MENUS */
3207 args
[1] = build_string ("(yes or no) ");
3208 prompt
= Fconcat (2, args
);
3214 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3215 Qyes_or_no_p_history
, Qnil
,
3217 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3222 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3230 message ("Please answer yes or no.");
3231 Fsleep_for (make_number (2), Qnil
);
3235 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3236 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3238 Each of the three load averages is multiplied by 100, then converted
3241 When USE-FLOATS is non-nil, floats will be used instead of integers.
3242 These floats are not multiplied by 100.
3244 If the 5-minute or 15-minute load averages are not available, return a
3245 shortened list, containing only those averages which are available.
3247 An error is thrown if the load average can't be obtained. In some
3248 cases making it work would require Emacs being installed setuid or
3249 setgid so that it can read kernel information, and that usually isn't
3252 Lisp_Object use_floats
;
3255 int loads
= getloadavg (load_ave
, 3);
3256 Lisp_Object ret
= Qnil
;
3259 error ("load-average not implemented for this operating system");
3263 Lisp_Object load
= (NILP (use_floats
) ?
3264 make_number ((int) (100.0 * load_ave
[loads
]))
3265 : make_float (load_ave
[loads
]));
3266 ret
= Fcons (load
, ret
);
3272 Lisp_Object Vfeatures
, Qsubfeatures
;
3273 extern Lisp_Object Vafter_load_alist
;
3275 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3276 doc
: /* Returns t if FEATURE is present in this Emacs.
3278 Use this to conditionalize execution of lisp code based on the
3279 presence or absence of emacs or environment extensions.
3280 Use `provide' to declare that a feature is available. This function
3281 looks at the value of the variable `features'. The optional argument
3282 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3283 (feature
, subfeature
)
3284 Lisp_Object feature
, subfeature
;
3286 register Lisp_Object tem
;
3287 CHECK_SYMBOL (feature
);
3288 tem
= Fmemq (feature
, Vfeatures
);
3289 if (!NILP (tem
) && !NILP (subfeature
))
3290 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3291 return (NILP (tem
)) ? Qnil
: Qt
;
3294 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3295 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3296 The optional argument SUBFEATURES should be a list of symbols listing
3297 particular subfeatures supported in this version of FEATURE. */)
3298 (feature
, subfeatures
)
3299 Lisp_Object feature
, subfeatures
;
3301 register Lisp_Object tem
;
3302 CHECK_SYMBOL (feature
);
3303 CHECK_LIST (subfeatures
);
3304 if (!NILP (Vautoload_queue
))
3305 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3306 tem
= Fmemq (feature
, Vfeatures
);
3308 Vfeatures
= Fcons (feature
, Vfeatures
);
3309 if (!NILP (subfeatures
))
3310 Fput (feature
, Qsubfeatures
, subfeatures
);
3311 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3313 /* Run any load-hooks for this file. */
3314 tem
= Fassq (feature
, Vafter_load_alist
);
3316 Fprogn (XCDR (tem
));
3321 /* `require' and its subroutines. */
3323 /* List of features currently being require'd, innermost first. */
3325 Lisp_Object require_nesting_list
;
3328 require_unwind (old_value
)
3329 Lisp_Object old_value
;
3331 return require_nesting_list
= old_value
;
3334 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3335 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3336 If FEATURE is not a member of the list `features', then the feature
3337 is not loaded; so load the file FILENAME.
3338 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3339 and `load' will try to load this name appended with the suffix `.elc' or
3340 `.el', in that order. The name without appended suffix will not be used.
3341 If the optional third argument NOERROR is non-nil,
3342 then return nil if the file is not found instead of signaling an error.
3343 Normally the return value is FEATURE.
3344 The normal messages at start and end of loading FILENAME are suppressed. */)
3345 (feature
, filename
, noerror
)
3346 Lisp_Object feature
, filename
, noerror
;
3348 register Lisp_Object tem
;
3349 struct gcpro gcpro1
, gcpro2
;
3351 CHECK_SYMBOL (feature
);
3353 tem
= Fmemq (feature
, Vfeatures
);
3357 int count
= SPECPDL_INDEX ();
3360 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3362 /* This is to make sure that loadup.el gives a clear picture
3363 of what files are preloaded and when. */
3364 if (! NILP (Vpurify_flag
))
3365 error ("(require %s) while preparing to dump",
3366 SDATA (SYMBOL_NAME (feature
)));
3368 /* A certain amount of recursive `require' is legitimate,
3369 but if we require the same feature recursively 3 times,
3371 tem
= require_nesting_list
;
3372 while (! NILP (tem
))
3374 if (! NILP (Fequal (feature
, XCAR (tem
))))
3379 error ("Recursive `require' for feature `%s'",
3380 SDATA (SYMBOL_NAME (feature
)));
3382 /* Update the list for any nested `require's that occur. */
3383 record_unwind_protect (require_unwind
, require_nesting_list
);
3384 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3386 /* Value saved here is to be restored into Vautoload_queue */
3387 record_unwind_protect (un_autoload
, Vautoload_queue
);
3388 Vautoload_queue
= Qt
;
3390 /* Load the file. */
3391 GCPRO2 (feature
, filename
);
3392 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3393 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3396 /* If load failed entirely, return nil. */
3398 return unbind_to (count
, Qnil
);
3400 tem
= Fmemq (feature
, Vfeatures
);
3402 error ("Required feature `%s' was not provided",
3403 SDATA (SYMBOL_NAME (feature
)));
3405 /* Once loading finishes, don't undo it. */
3406 Vautoload_queue
= Qt
;
3407 feature
= unbind_to (count
, feature
);
3413 /* Primitives for work of the "widget" library.
3414 In an ideal world, this section would not have been necessary.
3415 However, lisp function calls being as slow as they are, it turns
3416 out that some functions in the widget library (wid-edit.el) are the
3417 bottleneck of Widget operation. Here is their translation to C,
3418 for the sole reason of efficiency. */
3420 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3421 doc
: /* Return non-nil if PLIST has the property PROP.
3422 PLIST is a property list, which is a list of the form
3423 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3424 Unlike `plist-get', this allows you to distinguish between a missing
3425 property and a property with the value nil.
3426 The value is actually the tail of PLIST whose car is PROP. */)
3428 Lisp_Object plist
, prop
;
3430 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3433 plist
= XCDR (plist
);
3434 plist
= CDR (plist
);
3439 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3440 doc
: /* In WIDGET, set PROPERTY to VALUE.
3441 The value can later be retrieved with `widget-get'. */)
3442 (widget
, property
, value
)
3443 Lisp_Object widget
, property
, value
;
3445 CHECK_CONS (widget
);
3446 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3450 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3451 doc
: /* In WIDGET, get the value of PROPERTY.
3452 The value could either be specified when the widget was created, or
3453 later with `widget-put'. */)
3455 Lisp_Object widget
, property
;
3463 CHECK_CONS (widget
);
3464 tmp
= Fplist_member (XCDR (widget
), property
);
3470 tmp
= XCAR (widget
);
3473 widget
= Fget (tmp
, Qwidget_type
);
3477 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3478 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3479 ARGS are passed as extra arguments to the function.
3480 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3485 /* This function can GC. */
3486 Lisp_Object newargs
[3];
3487 struct gcpro gcpro1
, gcpro2
;
3490 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3491 newargs
[1] = args
[0];
3492 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3493 GCPRO2 (newargs
[0], newargs
[2]);
3494 result
= Fapply (3, newargs
);
3499 #ifdef HAVE_LANGINFO_CODESET
3500 #include <langinfo.h>
3503 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3504 doc
: /* Access locale data ITEM for the current C locale, if available.
3505 ITEM should be one of the following:
3507 `codeset', returning the character set as a string (locale item CODESET);
3509 `days', returning a 7-element vector of day names (locale items DAY_n);
3511 `months', returning a 12-element vector of month names (locale items MON_n);
3513 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3514 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3516 If the system can't provide such information through a call to
3517 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3519 See also Info node `(libc)Locales'.
3521 The data read from the system are decoded using `locale-coding-system'. */)
3526 #ifdef HAVE_LANGINFO_CODESET
3528 if (EQ (item
, Qcodeset
))
3530 str
= nl_langinfo (CODESET
);
3531 return build_string (str
);
3534 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3536 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3537 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3539 synchronize_system_time_locale ();
3540 for (i
= 0; i
< 7; i
++)
3542 str
= nl_langinfo (days
[i
]);
3543 val
= make_unibyte_string (str
, strlen (str
));
3544 /* Fixme: Is this coding system necessarily right, even if
3545 it is consistent with CODESET? If not, what to do? */
3546 Faset (v
, make_number (i
),
3547 code_convert_string_norecord (val
, Vlocale_coding_system
,
3554 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3556 struct Lisp_Vector
*p
= allocate_vector (12);
3557 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3558 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3560 synchronize_system_time_locale ();
3561 for (i
= 0; i
< 12; i
++)
3563 str
= nl_langinfo (months
[i
]);
3564 val
= make_unibyte_string (str
, strlen (str
));
3566 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3568 XSETVECTOR (val
, p
);
3572 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3573 but is in the locale files. This could be used by ps-print. */
3575 else if (EQ (item
, Qpaper
))
3577 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3578 make_number (nl_langinfo (PAPER_HEIGHT
)));
3580 #endif /* PAPER_WIDTH */
3581 #endif /* HAVE_LANGINFO_CODESET*/
3585 /* base64 encode/decode functions (RFC 2045).
3586 Based on code from GNU recode. */
3588 #define MIME_LINE_LENGTH 76
3590 #define IS_ASCII(Character) \
3592 #define IS_BASE64(Character) \
3593 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3594 #define IS_BASE64_IGNORABLE(Character) \
3595 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3596 || (Character) == '\f' || (Character) == '\r')
3598 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3599 character or return retval if there are no characters left to
3601 #define READ_QUADRUPLET_BYTE(retval) \
3606 if (nchars_return) \
3607 *nchars_return = nchars; \
3612 while (IS_BASE64_IGNORABLE (c))
3614 /* Don't use alloca for regions larger than this, lest we overflow
3616 #define MAX_ALLOCA 16*1024
3618 /* Table of characters coding the 64 values. */
3619 static char base64_value_to_char
[64] =
3621 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3622 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3623 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3624 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3625 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3626 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3627 '8', '9', '+', '/' /* 60-63 */
3630 /* Table of base64 values for first 128 characters. */
3631 static short base64_char_to_value
[128] =
3633 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3634 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3635 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3636 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3637 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3638 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3639 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3640 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3641 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3642 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3643 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3644 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3645 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3648 /* The following diagram shows the logical steps by which three octets
3649 get transformed into four base64 characters.
3651 .--------. .--------. .--------.
3652 |aaaaaabb| |bbbbcccc| |ccdddddd|
3653 `--------' `--------' `--------'
3655 .--------+--------+--------+--------.
3656 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3657 `--------+--------+--------+--------'
3659 .--------+--------+--------+--------.
3660 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3661 `--------+--------+--------+--------'
3663 The octets are divided into 6 bit chunks, which are then encoded into
3664 base64 characters. */
3667 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3668 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3670 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3672 doc
: /* Base64-encode the region between BEG and END.
3673 Return the length of the encoded text.
3674 Optional third argument NO-LINE-BREAK means do not break long lines
3675 into shorter lines. */)
3676 (beg
, end
, no_line_break
)
3677 Lisp_Object beg
, end
, no_line_break
;
3680 int allength
, length
;
3681 int ibeg
, iend
, encoded_length
;
3684 validate_region (&beg
, &end
);
3686 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3687 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3688 move_gap_both (XFASTINT (beg
), ibeg
);
3690 /* We need to allocate enough room for encoding the text.
3691 We need 33 1/3% more space, plus a newline every 76
3692 characters, and then we round up. */
3693 length
= iend
- ibeg
;
3694 allength
= length
+ length
/3 + 1;
3695 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3697 if (allength
<= MAX_ALLOCA
)
3698 encoded
= (char *) alloca (allength
);
3700 encoded
= (char *) xmalloc (allength
);
3701 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3702 NILP (no_line_break
),
3703 !NILP (current_buffer
->enable_multibyte_characters
));
3704 if (encoded_length
> allength
)
3707 if (encoded_length
< 0)
3709 /* The encoding wasn't possible. */
3710 if (length
> MAX_ALLOCA
)
3712 error ("Multibyte character in data for base64 encoding");
3715 /* Now we have encoded the region, so we insert the new contents
3716 and delete the old. (Insert first in order to preserve markers.) */
3717 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3718 insert (encoded
, encoded_length
);
3719 if (allength
> MAX_ALLOCA
)
3721 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3723 /* If point was outside of the region, restore it exactly; else just
3724 move to the beginning of the region. */
3725 if (old_pos
>= XFASTINT (end
))
3726 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3727 else if (old_pos
> XFASTINT (beg
))
3728 old_pos
= XFASTINT (beg
);
3731 /* We return the length of the encoded text. */
3732 return make_number (encoded_length
);
3735 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3737 doc
: /* Base64-encode STRING and return the result.
3738 Optional second argument NO-LINE-BREAK means do not break long lines
3739 into shorter lines. */)
3740 (string
, no_line_break
)
3741 Lisp_Object string
, no_line_break
;
3743 int allength
, length
, encoded_length
;
3745 Lisp_Object encoded_string
;
3747 CHECK_STRING (string
);
3749 /* We need to allocate enough room for encoding the text.
3750 We need 33 1/3% more space, plus a newline every 76
3751 characters, and then we round up. */
3752 length
= SBYTES (string
);
3753 allength
= length
+ length
/3 + 1;
3754 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3756 /* We need to allocate enough room for decoding the text. */
3757 if (allength
<= MAX_ALLOCA
)
3758 encoded
= (char *) alloca (allength
);
3760 encoded
= (char *) xmalloc (allength
);
3762 encoded_length
= base64_encode_1 (SDATA (string
),
3763 encoded
, length
, NILP (no_line_break
),
3764 STRING_MULTIBYTE (string
));
3765 if (encoded_length
> allength
)
3768 if (encoded_length
< 0)
3770 /* The encoding wasn't possible. */
3771 if (length
> MAX_ALLOCA
)
3773 error ("Multibyte character in data for base64 encoding");
3776 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3777 if (allength
> MAX_ALLOCA
)
3780 return encoded_string
;
3784 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3791 int counter
= 0, i
= 0;
3801 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3809 /* Wrap line every 76 characters. */
3813 if (counter
< MIME_LINE_LENGTH
/ 4)
3822 /* Process first byte of a triplet. */
3824 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3825 value
= (0x03 & c
) << 4;
3827 /* Process second byte of a triplet. */
3831 *e
++ = base64_value_to_char
[value
];
3839 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3847 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3848 value
= (0x0f & c
) << 2;
3850 /* Process third byte of a triplet. */
3854 *e
++ = base64_value_to_char
[value
];
3861 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3869 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3870 *e
++ = base64_value_to_char
[0x3f & c
];
3877 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3879 doc
: /* Base64-decode the region between BEG and END.
3880 Return the length of the decoded text.
3881 If the region can't be decoded, signal an error and don't modify the buffer. */)
3883 Lisp_Object beg
, end
;
3885 int ibeg
, iend
, length
, allength
;
3890 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3892 validate_region (&beg
, &end
);
3894 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3895 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3897 length
= iend
- ibeg
;
3899 /* We need to allocate enough room for decoding the text. If we are
3900 working on a multibyte buffer, each decoded code may occupy at
3902 allength
= multibyte
? length
* 2 : length
;
3903 if (allength
<= MAX_ALLOCA
)
3904 decoded
= (char *) alloca (allength
);
3906 decoded
= (char *) xmalloc (allength
);
3908 move_gap_both (XFASTINT (beg
), ibeg
);
3909 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3910 multibyte
, &inserted_chars
);
3911 if (decoded_length
> allength
)
3914 if (decoded_length
< 0)
3916 /* The decoding wasn't possible. */
3917 if (allength
> MAX_ALLOCA
)
3919 error ("Invalid base64 data");
3922 /* Now we have decoded the region, so we insert the new contents
3923 and delete the old. (Insert first in order to preserve markers.) */
3924 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3925 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3926 if (allength
> MAX_ALLOCA
)
3928 /* Delete the original text. */
3929 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3930 iend
+ decoded_length
, 1);
3932 /* If point was outside of the region, restore it exactly; else just
3933 move to the beginning of the region. */
3934 if (old_pos
>= XFASTINT (end
))
3935 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3936 else if (old_pos
> XFASTINT (beg
))
3937 old_pos
= XFASTINT (beg
);
3938 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3940 return make_number (inserted_chars
);
3943 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3945 doc
: /* Base64-decode STRING and return the result. */)
3950 int length
, decoded_length
;
3951 Lisp_Object decoded_string
;
3953 CHECK_STRING (string
);
3955 length
= SBYTES (string
);
3956 /* We need to allocate enough room for decoding the text. */
3957 if (length
<= MAX_ALLOCA
)
3958 decoded
= (char *) alloca (length
);
3960 decoded
= (char *) xmalloc (length
);
3962 /* The decoded result should be unibyte. */
3963 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3965 if (decoded_length
> length
)
3967 else if (decoded_length
>= 0)
3968 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3970 decoded_string
= Qnil
;
3972 if (length
> MAX_ALLOCA
)
3974 if (!STRINGP (decoded_string
))
3975 error ("Invalid base64 data");
3977 return decoded_string
;
3980 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3981 MULTIBYTE is nonzero, the decoded result should be in multibyte
3982 form. If NCHARS_RETRUN is not NULL, store the number of produced
3983 characters in *NCHARS_RETURN. */
3986 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3996 unsigned long value
;
4001 /* Process first byte of a quadruplet. */
4003 READ_QUADRUPLET_BYTE (e
-to
);
4007 value
= base64_char_to_value
[c
] << 18;
4009 /* Process second byte of a quadruplet. */
4011 READ_QUADRUPLET_BYTE (-1);
4015 value
|= base64_char_to_value
[c
] << 12;
4017 c
= (unsigned char) (value
>> 16);
4019 e
+= CHAR_STRING (c
, e
);
4024 /* Process third byte of a quadruplet. */
4026 READ_QUADRUPLET_BYTE (-1);
4030 READ_QUADRUPLET_BYTE (-1);
4039 value
|= base64_char_to_value
[c
] << 6;
4041 c
= (unsigned char) (0xff & value
>> 8);
4043 e
+= CHAR_STRING (c
, e
);
4048 /* Process fourth byte of a quadruplet. */
4050 READ_QUADRUPLET_BYTE (-1);
4057 value
|= base64_char_to_value
[c
];
4059 c
= (unsigned char) (0xff & value
);
4061 e
+= CHAR_STRING (c
, e
);
4070 /***********************************************************************
4072 ***** Hash Tables *****
4074 ***********************************************************************/
4076 /* Implemented by gerd@gnu.org. This hash table implementation was
4077 inspired by CMUCL hash tables. */
4081 1. For small tables, association lists are probably faster than
4082 hash tables because they have lower overhead.
4084 For uses of hash tables where the O(1) behavior of table
4085 operations is not a requirement, it might therefore be a good idea
4086 not to hash. Instead, we could just do a linear search in the
4087 key_and_value vector of the hash table. This could be done
4088 if a `:linear-search t' argument is given to make-hash-table. */
4091 /* The list of all weak hash tables. Don't staticpro this one. */
4093 Lisp_Object Vweak_hash_tables
;
4095 /* Various symbols. */
4097 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4098 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4099 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4101 /* Function prototypes. */
4103 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4104 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4105 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4106 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4107 Lisp_Object
, unsigned));
4108 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4109 Lisp_Object
, unsigned));
4110 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4111 unsigned, Lisp_Object
, unsigned));
4112 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4113 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4114 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4115 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4117 static unsigned sxhash_string
P_ ((unsigned char *, int));
4118 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4119 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4120 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4121 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4125 /***********************************************************************
4127 ***********************************************************************/
4129 /* If OBJ is a Lisp hash table, return a pointer to its struct
4130 Lisp_Hash_Table. Otherwise, signal an error. */
4132 static struct Lisp_Hash_Table
*
4133 check_hash_table (obj
)
4136 CHECK_HASH_TABLE (obj
);
4137 return XHASH_TABLE (obj
);
4141 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4145 next_almost_prime (n
)
4158 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4159 which USED[I] is non-zero. If found at index I in ARGS, set
4160 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4161 -1. This function is used to extract a keyword/argument pair from
4162 a DEFUN parameter list. */
4165 get_key_arg (key
, nargs
, args
, used
)
4173 for (i
= 0; i
< nargs
- 1; ++i
)
4174 if (!used
[i
] && EQ (args
[i
], key
))
4189 /* Return a Lisp vector which has the same contents as VEC but has
4190 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4191 vector that are not copied from VEC are set to INIT. */
4194 larger_vector (vec
, new_size
, init
)
4199 struct Lisp_Vector
*v
;
4202 xassert (VECTORP (vec
));
4203 old_size
= XVECTOR (vec
)->size
;
4204 xassert (new_size
>= old_size
);
4206 v
= allocate_vector (new_size
);
4207 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4208 old_size
* sizeof *v
->contents
);
4209 for (i
= old_size
; i
< new_size
; ++i
)
4210 v
->contents
[i
] = init
;
4211 XSETVECTOR (vec
, v
);
4216 /***********************************************************************
4218 ***********************************************************************/
4220 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4221 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4222 KEY2 are the same. */
4225 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4226 struct Lisp_Hash_Table
*h
;
4227 Lisp_Object key1
, key2
;
4228 unsigned hash1
, hash2
;
4230 return (FLOATP (key1
)
4232 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4236 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4237 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4238 KEY2 are the same. */
4241 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4242 struct Lisp_Hash_Table
*h
;
4243 Lisp_Object key1
, key2
;
4244 unsigned hash1
, hash2
;
4246 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4250 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4251 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4252 if KEY1 and KEY2 are the same. */
4255 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4256 struct Lisp_Hash_Table
*h
;
4257 Lisp_Object key1
, key2
;
4258 unsigned hash1
, hash2
;
4262 Lisp_Object args
[3];
4264 args
[0] = h
->user_cmp_function
;
4267 return !NILP (Ffuncall (3, args
));
4274 /* Value is a hash code for KEY for use in hash table H which uses
4275 `eq' to compare keys. The hash code returned is guaranteed to fit
4276 in a Lisp integer. */
4280 struct Lisp_Hash_Table
*h
;
4283 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4284 xassert ((hash
& ~INTMASK
) == 0);
4289 /* Value is a hash code for KEY for use in hash table H which uses
4290 `eql' to compare keys. The hash code returned is guaranteed to fit
4291 in a Lisp integer. */
4295 struct Lisp_Hash_Table
*h
;
4300 hash
= sxhash (key
, 0);
4302 hash
= XUINT (key
) ^ XGCTYPE (key
);
4303 xassert ((hash
& ~INTMASK
) == 0);
4308 /* Value is a hash code for KEY for use in hash table H which uses
4309 `equal' to compare keys. The hash code returned is guaranteed to fit
4310 in a Lisp integer. */
4313 hashfn_equal (h
, key
)
4314 struct Lisp_Hash_Table
*h
;
4317 unsigned hash
= sxhash (key
, 0);
4318 xassert ((hash
& ~INTMASK
) == 0);
4323 /* Value is a hash code for KEY for use in hash table H which uses as
4324 user-defined function to compare keys. The hash code returned is
4325 guaranteed to fit in a Lisp integer. */
4328 hashfn_user_defined (h
, key
)
4329 struct Lisp_Hash_Table
*h
;
4332 Lisp_Object args
[2], hash
;
4334 args
[0] = h
->user_hash_function
;
4336 hash
= Ffuncall (2, args
);
4337 if (!INTEGERP (hash
))
4339 list2 (build_string ("Invalid hash code returned from \
4340 user-supplied hash function"),
4342 return XUINT (hash
);
4346 /* Create and initialize a new hash table.
4348 TEST specifies the test the hash table will use to compare keys.
4349 It must be either one of the predefined tests `eq', `eql' or
4350 `equal' or a symbol denoting a user-defined test named TEST with
4351 test and hash functions USER_TEST and USER_HASH.
4353 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4355 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4356 new size when it becomes full is computed by adding REHASH_SIZE to
4357 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4358 table's new size is computed by multiplying its old size with
4361 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4362 be resized when the ratio of (number of entries in the table) /
4363 (table size) is >= REHASH_THRESHOLD.
4365 WEAK specifies the weakness of the table. If non-nil, it must be
4366 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4369 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4370 user_test
, user_hash
)
4371 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4372 Lisp_Object user_test
, user_hash
;
4374 struct Lisp_Hash_Table
*h
;
4376 int index_size
, i
, sz
;
4378 /* Preconditions. */
4379 xassert (SYMBOLP (test
));
4380 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4381 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4382 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4383 xassert (FLOATP (rehash_threshold
)
4384 && XFLOATINT (rehash_threshold
) > 0
4385 && XFLOATINT (rehash_threshold
) <= 1.0);
4387 if (XFASTINT (size
) == 0)
4388 size
= make_number (1);
4390 /* Allocate a table and initialize it. */
4391 h
= allocate_hash_table ();
4393 /* Initialize hash table slots. */
4394 sz
= XFASTINT (size
);
4397 if (EQ (test
, Qeql
))
4399 h
->cmpfn
= cmpfn_eql
;
4400 h
->hashfn
= hashfn_eql
;
4402 else if (EQ (test
, Qeq
))
4405 h
->hashfn
= hashfn_eq
;
4407 else if (EQ (test
, Qequal
))
4409 h
->cmpfn
= cmpfn_equal
;
4410 h
->hashfn
= hashfn_equal
;
4414 h
->user_cmp_function
= user_test
;
4415 h
->user_hash_function
= user_hash
;
4416 h
->cmpfn
= cmpfn_user_defined
;
4417 h
->hashfn
= hashfn_user_defined
;
4421 h
->rehash_threshold
= rehash_threshold
;
4422 h
->rehash_size
= rehash_size
;
4423 h
->count
= make_number (0);
4424 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4425 h
->hash
= Fmake_vector (size
, Qnil
);
4426 h
->next
= Fmake_vector (size
, Qnil
);
4427 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4428 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4429 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4431 /* Set up the free list. */
4432 for (i
= 0; i
< sz
- 1; ++i
)
4433 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4434 h
->next_free
= make_number (0);
4436 XSET_HASH_TABLE (table
, h
);
4437 xassert (HASH_TABLE_P (table
));
4438 xassert (XHASH_TABLE (table
) == h
);
4440 /* Maybe add this hash table to the list of all weak hash tables. */
4442 h
->next_weak
= Qnil
;
4445 h
->next_weak
= Vweak_hash_tables
;
4446 Vweak_hash_tables
= table
;
4453 /* Return a copy of hash table H1. Keys and values are not copied,
4454 only the table itself is. */
4457 copy_hash_table (h1
)
4458 struct Lisp_Hash_Table
*h1
;
4461 struct Lisp_Hash_Table
*h2
;
4462 struct Lisp_Vector
*next
;
4464 h2
= allocate_hash_table ();
4465 next
= h2
->vec_next
;
4466 bcopy (h1
, h2
, sizeof *h2
);
4467 h2
->vec_next
= next
;
4468 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4469 h2
->hash
= Fcopy_sequence (h1
->hash
);
4470 h2
->next
= Fcopy_sequence (h1
->next
);
4471 h2
->index
= Fcopy_sequence (h1
->index
);
4472 XSET_HASH_TABLE (table
, h2
);
4474 /* Maybe add this hash table to the list of all weak hash tables. */
4475 if (!NILP (h2
->weak
))
4477 h2
->next_weak
= Vweak_hash_tables
;
4478 Vweak_hash_tables
= table
;
4485 /* Resize hash table H if it's too full. If H cannot be resized
4486 because it's already too large, throw an error. */
4489 maybe_resize_hash_table (h
)
4490 struct Lisp_Hash_Table
*h
;
4492 if (NILP (h
->next_free
))
4494 int old_size
= HASH_TABLE_SIZE (h
);
4495 int i
, new_size
, index_size
;
4497 if (INTEGERP (h
->rehash_size
))
4498 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4500 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4501 new_size
= max (old_size
+ 1, new_size
);
4502 index_size
= next_almost_prime ((int)
4504 / XFLOATINT (h
->rehash_threshold
)));
4505 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4506 error ("Hash table too large to resize");
4508 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4509 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4510 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4511 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4513 /* Update the free list. Do it so that new entries are added at
4514 the end of the free list. This makes some operations like
4516 for (i
= old_size
; i
< new_size
- 1; ++i
)
4517 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4519 if (!NILP (h
->next_free
))
4521 Lisp_Object last
, next
;
4523 last
= h
->next_free
;
4524 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4528 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4531 XSETFASTINT (h
->next_free
, old_size
);
4534 for (i
= 0; i
< old_size
; ++i
)
4535 if (!NILP (HASH_HASH (h
, i
)))
4537 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4538 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4539 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4540 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4546 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4547 the hash code of KEY. Value is the index of the entry in H
4548 matching KEY, or -1 if not found. */
4551 hash_lookup (h
, key
, hash
)
4552 struct Lisp_Hash_Table
*h
;
4557 int start_of_bucket
;
4560 hash_code
= h
->hashfn (h
, key
);
4564 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4565 idx
= HASH_INDEX (h
, start_of_bucket
);
4567 /* We need not gcpro idx since it's either an integer or nil. */
4570 int i
= XFASTINT (idx
);
4571 if (EQ (key
, HASH_KEY (h
, i
))
4573 && h
->cmpfn (h
, key
, hash_code
,
4574 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4576 idx
= HASH_NEXT (h
, i
);
4579 return NILP (idx
) ? -1 : XFASTINT (idx
);
4583 /* Put an entry into hash table H that associates KEY with VALUE.
4584 HASH is a previously computed hash code of KEY.
4585 Value is the index of the entry in H matching KEY. */
4588 hash_put (h
, key
, value
, hash
)
4589 struct Lisp_Hash_Table
*h
;
4590 Lisp_Object key
, value
;
4593 int start_of_bucket
, i
;
4595 xassert ((hash
& ~INTMASK
) == 0);
4597 /* Increment count after resizing because resizing may fail. */
4598 maybe_resize_hash_table (h
);
4599 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4601 /* Store key/value in the key_and_value vector. */
4602 i
= XFASTINT (h
->next_free
);
4603 h
->next_free
= HASH_NEXT (h
, i
);
4604 HASH_KEY (h
, i
) = key
;
4605 HASH_VALUE (h
, i
) = value
;
4607 /* Remember its hash code. */
4608 HASH_HASH (h
, i
) = make_number (hash
);
4610 /* Add new entry to its collision chain. */
4611 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4612 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4613 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4618 /* Remove the entry matching KEY from hash table H, if there is one. */
4621 hash_remove (h
, key
)
4622 struct Lisp_Hash_Table
*h
;
4626 int start_of_bucket
;
4627 Lisp_Object idx
, prev
;
4629 hash_code
= h
->hashfn (h
, key
);
4630 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4631 idx
= HASH_INDEX (h
, start_of_bucket
);
4634 /* We need not gcpro idx, prev since they're either integers or nil. */
4637 int i
= XFASTINT (idx
);
4639 if (EQ (key
, HASH_KEY (h
, i
))
4641 && h
->cmpfn (h
, key
, hash_code
,
4642 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4644 /* Take entry out of collision chain. */
4646 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4648 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4650 /* Clear slots in key_and_value and add the slots to
4652 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4653 HASH_NEXT (h
, i
) = h
->next_free
;
4654 h
->next_free
= make_number (i
);
4655 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4656 xassert (XINT (h
->count
) >= 0);
4662 idx
= HASH_NEXT (h
, i
);
4668 /* Clear hash table H. */
4672 struct Lisp_Hash_Table
*h
;
4674 if (XFASTINT (h
->count
) > 0)
4676 int i
, size
= HASH_TABLE_SIZE (h
);
4678 for (i
= 0; i
< size
; ++i
)
4680 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4681 HASH_KEY (h
, i
) = Qnil
;
4682 HASH_VALUE (h
, i
) = Qnil
;
4683 HASH_HASH (h
, i
) = Qnil
;
4686 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4687 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4689 h
->next_free
= make_number (0);
4690 h
->count
= make_number (0);
4696 /************************************************************************
4698 ************************************************************************/
4700 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4701 entries from the table that don't survive the current GC.
4702 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4703 non-zero if anything was marked. */
4706 sweep_weak_table (h
, remove_entries_p
)
4707 struct Lisp_Hash_Table
*h
;
4708 int remove_entries_p
;
4710 int bucket
, n
, marked
;
4712 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4715 for (bucket
= 0; bucket
< n
; ++bucket
)
4717 Lisp_Object idx
, next
, prev
;
4719 /* Follow collision chain, removing entries that
4720 don't survive this garbage collection. */
4722 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4724 int i
= XFASTINT (idx
);
4725 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4726 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4729 if (EQ (h
->weak
, Qkey
))
4730 remove_p
= !key_known_to_survive_p
;
4731 else if (EQ (h
->weak
, Qvalue
))
4732 remove_p
= !value_known_to_survive_p
;
4733 else if (EQ (h
->weak
, Qkey_or_value
))
4734 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4735 else if (EQ (h
->weak
, Qkey_and_value
))
4736 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4740 next
= HASH_NEXT (h
, i
);
4742 if (remove_entries_p
)
4746 /* Take out of collision chain. */
4748 HASH_INDEX (h
, bucket
) = next
;
4750 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4752 /* Add to free list. */
4753 HASH_NEXT (h
, i
) = h
->next_free
;
4756 /* Clear key, value, and hash. */
4757 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4758 HASH_HASH (h
, i
) = Qnil
;
4760 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4767 /* Make sure key and value survive. */
4768 if (!key_known_to_survive_p
)
4770 mark_object (HASH_KEY (h
, i
));
4774 if (!value_known_to_survive_p
)
4776 mark_object (HASH_VALUE (h
, i
));
4787 /* Remove elements from weak hash tables that don't survive the
4788 current garbage collection. Remove weak tables that don't survive
4789 from Vweak_hash_tables. Called from gc_sweep. */
4792 sweep_weak_hash_tables ()
4794 Lisp_Object table
, used
, next
;
4795 struct Lisp_Hash_Table
*h
;
4798 /* Mark all keys and values that are in use. Keep on marking until
4799 there is no more change. This is necessary for cases like
4800 value-weak table A containing an entry X -> Y, where Y is used in a
4801 key-weak table B, Z -> Y. If B comes after A in the list of weak
4802 tables, X -> Y might be removed from A, although when looking at B
4803 one finds that it shouldn't. */
4807 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4809 h
= XHASH_TABLE (table
);
4810 if (h
->size
& ARRAY_MARK_FLAG
)
4811 marked
|= sweep_weak_table (h
, 0);
4816 /* Remove tables and entries that aren't used. */
4817 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4819 h
= XHASH_TABLE (table
);
4820 next
= h
->next_weak
;
4822 if (h
->size
& ARRAY_MARK_FLAG
)
4824 /* TABLE is marked as used. Sweep its contents. */
4825 if (XFASTINT (h
->count
) > 0)
4826 sweep_weak_table (h
, 1);
4828 /* Add table to the list of used weak hash tables. */
4829 h
->next_weak
= used
;
4834 Vweak_hash_tables
= used
;
4839 /***********************************************************************
4840 Hash Code Computation
4841 ***********************************************************************/
4843 /* Maximum depth up to which to dive into Lisp structures. */
4845 #define SXHASH_MAX_DEPTH 3
4847 /* Maximum length up to which to take list and vector elements into
4850 #define SXHASH_MAX_LEN 7
4852 /* Combine two integers X and Y for hashing. */
4854 #define SXHASH_COMBINE(X, Y) \
4855 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4859 /* Return a hash for string PTR which has length LEN. The hash
4860 code returned is guaranteed to fit in a Lisp integer. */
4863 sxhash_string (ptr
, len
)
4867 unsigned char *p
= ptr
;
4868 unsigned char *end
= p
+ len
;
4877 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4880 return hash
& INTMASK
;
4884 /* Return a hash for list LIST. DEPTH is the current depth in the
4885 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4888 sxhash_list (list
, depth
)
4895 if (depth
< SXHASH_MAX_DEPTH
)
4897 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4898 list
= XCDR (list
), ++i
)
4900 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4901 hash
= SXHASH_COMBINE (hash
, hash2
);
4908 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4909 the Lisp structure. */
4912 sxhash_vector (vec
, depth
)
4916 unsigned hash
= XVECTOR (vec
)->size
;
4919 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4920 for (i
= 0; i
< n
; ++i
)
4922 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4923 hash
= SXHASH_COMBINE (hash
, hash2
);
4930 /* Return a hash for bool-vector VECTOR. */
4933 sxhash_bool_vector (vec
)
4936 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4939 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4940 for (i
= 0; i
< n
; ++i
)
4941 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4947 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4948 structure. Value is an unsigned integer clipped to INTMASK. */
4957 if (depth
> SXHASH_MAX_DEPTH
)
4960 switch (XTYPE (obj
))
4967 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4968 SCHARS (SYMBOL_NAME (obj
)));
4976 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4979 /* This can be everything from a vector to an overlay. */
4980 case Lisp_Vectorlike
:
4982 /* According to the CL HyperSpec, two arrays are equal only if
4983 they are `eq', except for strings and bit-vectors. In
4984 Emacs, this works differently. We have to compare element
4986 hash
= sxhash_vector (obj
, depth
);
4987 else if (BOOL_VECTOR_P (obj
))
4988 hash
= sxhash_bool_vector (obj
);
4990 /* Others are `equal' if they are `eq', so let's take their
4996 hash
= sxhash_list (obj
, depth
);
5001 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5002 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5003 for (hash
= 0; p
< e
; ++p
)
5004 hash
= SXHASH_COMBINE (hash
, *p
);
5012 return hash
& INTMASK
;
5017 /***********************************************************************
5019 ***********************************************************************/
5022 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5023 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5027 unsigned hash
= sxhash (obj
, 0);;
5028 return make_number (hash
);
5032 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5033 doc
: /* Create and return a new hash table.
5035 Arguments are specified as keyword/argument pairs. The following
5036 arguments are defined:
5038 :test TEST -- TEST must be a symbol that specifies how to compare
5039 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5040 `equal'. User-supplied test and hash functions can be specified via
5041 `define-hash-table-test'.
5043 :size SIZE -- A hint as to how many elements will be put in the table.
5046 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5047 fills up. If REHASH-SIZE is an integer, add that many space. If it
5048 is a float, it must be > 1.0, and the new size is computed by
5049 multiplying the old size with that factor. Default is 1.5.
5051 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5052 Resize the hash table when ratio of the number of entries in the
5053 table. Default is 0.8.
5055 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5056 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5057 returned is a weak table. Key/value pairs are removed from a weak
5058 hash table when there are no non-weak references pointing to their
5059 key, value, one of key or value, or both key and value, depending on
5060 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5063 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5068 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5069 Lisp_Object user_test
, user_hash
;
5073 /* The vector `used' is used to keep track of arguments that
5074 have been consumed. */
5075 used
= (char *) alloca (nargs
* sizeof *used
);
5076 bzero (used
, nargs
* sizeof *used
);
5078 /* See if there's a `:test TEST' among the arguments. */
5079 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5080 test
= i
< 0 ? Qeql
: args
[i
];
5081 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5083 /* See if it is a user-defined test. */
5086 prop
= Fget (test
, Qhash_table_test
);
5087 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5088 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5090 user_test
= XCAR (prop
);
5091 user_hash
= XCAR (XCDR (prop
));
5094 user_test
= user_hash
= Qnil
;
5096 /* See if there's a `:size SIZE' argument. */
5097 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5098 size
= i
< 0 ? Qnil
: args
[i
];
5100 size
= make_number (DEFAULT_HASH_SIZE
);
5101 else if (!INTEGERP (size
) || XINT (size
) < 0)
5103 list2 (build_string ("Invalid hash table size"),
5106 /* Look for `:rehash-size SIZE'. */
5107 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5108 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5109 if (!NUMBERP (rehash_size
)
5110 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5111 || XFLOATINT (rehash_size
) <= 1.0)
5113 list2 (build_string ("Invalid hash table rehash size"),
5116 /* Look for `:rehash-threshold THRESHOLD'. */
5117 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5118 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5119 if (!FLOATP (rehash_threshold
)
5120 || XFLOATINT (rehash_threshold
) <= 0.0
5121 || XFLOATINT (rehash_threshold
) > 1.0)
5123 list2 (build_string ("Invalid hash table rehash threshold"),
5126 /* Look for `:weakness WEAK'. */
5127 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5128 weak
= i
< 0 ? Qnil
: args
[i
];
5130 weak
= Qkey_and_value
;
5133 && !EQ (weak
, Qvalue
)
5134 && !EQ (weak
, Qkey_or_value
)
5135 && !EQ (weak
, Qkey_and_value
))
5136 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5139 /* Now, all args should have been used up, or there's a problem. */
5140 for (i
= 0; i
< nargs
; ++i
)
5143 list2 (build_string ("Invalid argument list"), args
[i
]));
5145 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5146 user_test
, user_hash
);
5150 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5151 doc
: /* Return a copy of hash table TABLE. */)
5155 return copy_hash_table (check_hash_table (table
));
5159 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5160 doc
: /* Return the number of elements in TABLE. */)
5164 return check_hash_table (table
)->count
;
5168 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5169 Shash_table_rehash_size
, 1, 1, 0,
5170 doc
: /* Return the current rehash size of TABLE. */)
5174 return check_hash_table (table
)->rehash_size
;
5178 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5179 Shash_table_rehash_threshold
, 1, 1, 0,
5180 doc
: /* Return the current rehash threshold of TABLE. */)
5184 return check_hash_table (table
)->rehash_threshold
;
5188 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5189 doc
: /* Return the size of TABLE.
5190 The size can be used as an argument to `make-hash-table' to create
5191 a hash table than can hold as many elements of TABLE holds
5192 without need for resizing. */)
5196 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5197 return make_number (HASH_TABLE_SIZE (h
));
5201 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5202 doc
: /* Return the test TABLE uses. */)
5206 return check_hash_table (table
)->test
;
5210 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5212 doc
: /* Return the weakness of TABLE. */)
5216 return check_hash_table (table
)->weak
;
5220 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5221 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5225 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5229 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5230 doc
: /* Clear hash table TABLE. */)
5234 hash_clear (check_hash_table (table
));
5239 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5240 doc
: /* Look up KEY in TABLE and return its associated value.
5241 If KEY is not found, return DFLT which defaults to nil. */)
5243 Lisp_Object key
, table
, dflt
;
5245 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5246 int i
= hash_lookup (h
, key
, NULL
);
5247 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5251 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5252 doc
: /* Associate KEY with VALUE in hash table TABLE.
5253 If KEY is already present in table, replace its current value with
5256 Lisp_Object key
, value
, table
;
5258 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5262 i
= hash_lookup (h
, key
, &hash
);
5264 HASH_VALUE (h
, i
) = value
;
5266 hash_put (h
, key
, value
, hash
);
5272 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5273 doc
: /* Remove KEY from TABLE. */)
5275 Lisp_Object key
, table
;
5277 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5278 hash_remove (h
, key
);
5283 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5284 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5285 FUNCTION is called with 2 arguments KEY and VALUE. */)
5287 Lisp_Object function
, table
;
5289 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5290 Lisp_Object args
[3];
5293 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5294 if (!NILP (HASH_HASH (h
, i
)))
5297 args
[1] = HASH_KEY (h
, i
);
5298 args
[2] = HASH_VALUE (h
, i
);
5306 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5307 Sdefine_hash_table_test
, 3, 3, 0,
5308 doc
: /* Define a new hash table test with name NAME, a symbol.
5310 In hash tables created with NAME specified as test, use TEST to
5311 compare keys, and HASH for computing hash codes of keys.
5313 TEST must be a function taking two arguments and returning non-nil if
5314 both arguments are the same. HASH must be a function taking one
5315 argument and return an integer that is the hash code of the argument.
5316 Hash code computation should use the whole value range of integers,
5317 including negative integers. */)
5319 Lisp_Object name
, test
, hash
;
5321 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5326 /************************************************************************
5328 ************************************************************************/
5333 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5334 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5336 A message digest is a cryptographic checksum of a document, and the
5337 algorithm to calculate it is defined in RFC 1321.
5339 The two optional arguments START and END are character positions
5340 specifying for which part of OBJECT the message digest should be
5341 computed. If nil or omitted, the digest is computed for the whole
5344 The MD5 message digest is computed from the result of encoding the
5345 text in a coding system, not directly from the internal Emacs form of
5346 the text. The optional fourth argument CODING-SYSTEM specifies which
5347 coding system to encode the text with. It should be the same coding
5348 system that you used or will use when actually writing the text into a
5351 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5352 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5353 system would be chosen by default for writing this text into a file.
5355 If OBJECT is a string, the most preferred coding system (see the
5356 command `prefer-coding-system') is used.
5358 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5359 guesswork fails. Normally, an error is signaled in such case. */)
5360 (object
, start
, end
, coding_system
, noerror
)
5361 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5363 unsigned char digest
[16];
5364 unsigned char value
[33];
5368 int start_char
= 0, end_char
= 0;
5369 int start_byte
= 0, end_byte
= 0;
5371 register struct buffer
*bp
;
5374 if (STRINGP (object
))
5376 if (NILP (coding_system
))
5378 /* Decide the coding-system to encode the data with. */
5380 if (STRING_MULTIBYTE (object
))
5381 /* use default, we can't guess correct value */
5382 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5384 coding_system
= Qraw_text
;
5387 if (NILP (Fcoding_system_p (coding_system
)))
5389 /* Invalid coding system. */
5391 if (!NILP (noerror
))
5392 coding_system
= Qraw_text
;
5395 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5398 if (STRING_MULTIBYTE (object
))
5399 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5401 size
= SCHARS (object
);
5402 size_byte
= SBYTES (object
);
5406 CHECK_NUMBER (start
);
5408 start_char
= XINT (start
);
5413 start_byte
= string_char_to_byte (object
, start_char
);
5419 end_byte
= size_byte
;
5425 end_char
= XINT (end
);
5430 end_byte
= string_char_to_byte (object
, end_char
);
5433 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5434 args_out_of_range_3 (object
, make_number (start_char
),
5435 make_number (end_char
));
5439 CHECK_BUFFER (object
);
5441 bp
= XBUFFER (object
);
5447 CHECK_NUMBER_COERCE_MARKER (start
);
5455 CHECK_NUMBER_COERCE_MARKER (end
);
5460 temp
= b
, b
= e
, e
= temp
;
5462 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5463 args_out_of_range (start
, end
);
5465 if (NILP (coding_system
))
5467 /* Decide the coding-system to encode the data with.
5468 See fileio.c:Fwrite-region */
5470 if (!NILP (Vcoding_system_for_write
))
5471 coding_system
= Vcoding_system_for_write
;
5474 int force_raw_text
= 0;
5476 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5477 if (NILP (coding_system
)
5478 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5480 coding_system
= Qnil
;
5481 if (NILP (current_buffer
->enable_multibyte_characters
))
5485 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5487 /* Check file-coding-system-alist. */
5488 Lisp_Object args
[4], val
;
5490 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5491 args
[3] = Fbuffer_file_name(object
);
5492 val
= Ffind_operation_coding_system (4, args
);
5493 if (CONSP (val
) && !NILP (XCDR (val
)))
5494 coding_system
= XCDR (val
);
5497 if (NILP (coding_system
)
5498 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5500 /* If we still have not decided a coding system, use the
5501 default value of buffer-file-coding-system. */
5502 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5506 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5507 /* Confirm that VAL can surely encode the current region. */
5508 coding_system
= call4 (Vselect_safe_coding_system_function
,
5509 make_number (b
), make_number (e
),
5510 coding_system
, Qnil
);
5513 coding_system
= Qraw_text
;
5516 if (NILP (Fcoding_system_p (coding_system
)))
5518 /* Invalid coding system. */
5520 if (!NILP (noerror
))
5521 coding_system
= Qraw_text
;
5524 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5528 object
= make_buffer_string (b
, e
, 0);
5530 if (STRING_MULTIBYTE (object
))
5531 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5534 md5_buffer (SDATA (object
) + start_byte
,
5535 SBYTES (object
) - (size_byte
- end_byte
),
5538 for (i
= 0; i
< 16; i
++)
5539 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5542 return make_string (value
, 32);
5549 /* Hash table stuff. */
5550 Qhash_table_p
= intern ("hash-table-p");
5551 staticpro (&Qhash_table_p
);
5552 Qeq
= intern ("eq");
5554 Qeql
= intern ("eql");
5556 Qequal
= intern ("equal");
5557 staticpro (&Qequal
);
5558 QCtest
= intern (":test");
5559 staticpro (&QCtest
);
5560 QCsize
= intern (":size");
5561 staticpro (&QCsize
);
5562 QCrehash_size
= intern (":rehash-size");
5563 staticpro (&QCrehash_size
);
5564 QCrehash_threshold
= intern (":rehash-threshold");
5565 staticpro (&QCrehash_threshold
);
5566 QCweakness
= intern (":weakness");
5567 staticpro (&QCweakness
);
5568 Qkey
= intern ("key");
5570 Qvalue
= intern ("value");
5571 staticpro (&Qvalue
);
5572 Qhash_table_test
= intern ("hash-table-test");
5573 staticpro (&Qhash_table_test
);
5574 Qkey_or_value
= intern ("key-or-value");
5575 staticpro (&Qkey_or_value
);
5576 Qkey_and_value
= intern ("key-and-value");
5577 staticpro (&Qkey_and_value
);
5580 defsubr (&Smake_hash_table
);
5581 defsubr (&Scopy_hash_table
);
5582 defsubr (&Shash_table_count
);
5583 defsubr (&Shash_table_rehash_size
);
5584 defsubr (&Shash_table_rehash_threshold
);
5585 defsubr (&Shash_table_size
);
5586 defsubr (&Shash_table_test
);
5587 defsubr (&Shash_table_weakness
);
5588 defsubr (&Shash_table_p
);
5589 defsubr (&Sclrhash
);
5590 defsubr (&Sgethash
);
5591 defsubr (&Sputhash
);
5592 defsubr (&Sremhash
);
5593 defsubr (&Smaphash
);
5594 defsubr (&Sdefine_hash_table_test
);
5596 Qstring_lessp
= intern ("string-lessp");
5597 staticpro (&Qstring_lessp
);
5598 Qprovide
= intern ("provide");
5599 staticpro (&Qprovide
);
5600 Qrequire
= intern ("require");
5601 staticpro (&Qrequire
);
5602 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5603 staticpro (&Qyes_or_no_p_history
);
5604 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5605 staticpro (&Qcursor_in_echo_area
);
5606 Qwidget_type
= intern ("widget-type");
5607 staticpro (&Qwidget_type
);
5609 staticpro (&string_char_byte_cache_string
);
5610 string_char_byte_cache_string
= Qnil
;
5612 require_nesting_list
= Qnil
;
5613 staticpro (&require_nesting_list
);
5615 Fset (Qyes_or_no_p_history
, Qnil
);
5617 DEFVAR_LISP ("features", &Vfeatures
,
5618 doc
: /* A list of symbols which are the features of the executing emacs.
5619 Used by `featurep' and `require', and altered by `provide'. */);
5621 Qsubfeatures
= intern ("subfeatures");
5622 staticpro (&Qsubfeatures
);
5624 #ifdef HAVE_LANGINFO_CODESET
5625 Qcodeset
= intern ("codeset");
5626 staticpro (&Qcodeset
);
5627 Qdays
= intern ("days");
5629 Qmonths
= intern ("months");
5630 staticpro (&Qmonths
);
5631 Qpaper
= intern ("paper");
5632 staticpro (&Qpaper
);
5633 #endif /* HAVE_LANGINFO_CODESET */
5635 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5636 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5637 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5638 invoked by mouse clicks and mouse menu items. */);
5641 defsubr (&Sidentity
);
5644 defsubr (&Ssafe_length
);
5645 defsubr (&Sstring_bytes
);
5646 defsubr (&Sstring_equal
);
5647 defsubr (&Scompare_strings
);
5648 defsubr (&Sstring_lessp
);
5651 defsubr (&Svconcat
);
5652 defsubr (&Scopy_sequence
);
5653 defsubr (&Sstring_make_multibyte
);
5654 defsubr (&Sstring_make_unibyte
);
5655 defsubr (&Sstring_as_multibyte
);
5656 defsubr (&Sstring_as_unibyte
);
5657 defsubr (&Sstring_to_multibyte
);
5658 defsubr (&Scopy_alist
);
5659 defsubr (&Ssubstring
);
5660 defsubr (&Ssubstring_no_properties
);
5672 defsubr (&Snreverse
);
5673 defsubr (&Sreverse
);
5675 defsubr (&Splist_get
);
5677 defsubr (&Splist_put
);
5679 defsubr (&Slax_plist_get
);
5680 defsubr (&Slax_plist_put
);
5682 defsubr (&Sfillarray
);
5683 defsubr (&Sclear_string
);
5684 defsubr (&Schar_table_subtype
);
5685 defsubr (&Schar_table_parent
);
5686 defsubr (&Sset_char_table_parent
);
5687 defsubr (&Schar_table_extra_slot
);
5688 defsubr (&Sset_char_table_extra_slot
);
5689 defsubr (&Schar_table_range
);
5690 defsubr (&Sset_char_table_range
);
5691 defsubr (&Sset_char_table_default
);
5692 defsubr (&Soptimize_char_table
);
5693 defsubr (&Smap_char_table
);
5697 defsubr (&Smapconcat
);
5698 defsubr (&Sy_or_n_p
);
5699 defsubr (&Syes_or_no_p
);
5700 defsubr (&Sload_average
);
5701 defsubr (&Sfeaturep
);
5702 defsubr (&Srequire
);
5703 defsubr (&Sprovide
);
5704 defsubr (&Splist_member
);
5705 defsubr (&Swidget_put
);
5706 defsubr (&Swidget_get
);
5707 defsubr (&Swidget_apply
);
5708 defsubr (&Sbase64_encode_region
);
5709 defsubr (&Sbase64_decode_region
);
5710 defsubr (&Sbase64_encode_string
);
5711 defsubr (&Sbase64_decode_string
);
5713 defsubr (&Slocale_info
);
5720 Vweak_hash_tables
= Qnil
;
5723 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5724 (do not change this comment) */