1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
31 /* On Mac OS, defining this conflicts with precompiled headers. */
33 /* Note on some machines this defines `vector' as a typedef,
34 so make sure we don't use that name in this file. */
38 #endif /* ! MAC_OSX */
47 #include "intervals.h"
50 #include "blockinput.h"
52 #if defined (HAVE_X_WINDOWS)
54 #elif defined (MAC_OS)
60 #define NULL ((POINTER_TYPE *)0)
63 /* Nonzero enables use of dialog boxes for questions
64 asked by mouse commands. */
67 /* Nonzero enables use of a file dialog for file name
68 questions asked by mouse commands. */
71 extern int minibuffer_auto_raise
;
72 extern Lisp_Object minibuf_window
;
73 extern Lisp_Object Vlocale_coding_system
;
74 extern int load_in_progress
;
76 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
77 Lisp_Object Qyes_or_no_p_history
;
78 Lisp_Object Qcursor_in_echo_area
;
79 Lisp_Object Qwidget_type
;
80 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
82 extern Lisp_Object Qinput_method_function
;
84 static int internal_equal
P_ ((Lisp_Object
, Lisp_Object
, int, int));
86 extern long get_random ();
87 extern void seed_random
P_ ((long));
93 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
94 doc
: /* Return the argument unchanged. */)
101 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
102 doc
: /* Return a pseudo-random number.
103 All integers representable in Lisp are equally likely.
104 On most systems, this is 29 bits' worth.
105 With positive integer argument N, return random number in interval [0,N).
106 With argument t, set the random number seed from the current time and pid. */)
111 Lisp_Object lispy_val
;
112 unsigned long denominator
;
115 seed_random (getpid () + time (NULL
));
116 if (NATNUMP (n
) && XFASTINT (n
) != 0)
118 /* Try to take our random number from the higher bits of VAL,
119 not the lower, since (says Gentzel) the low bits of `random'
120 are less random than the higher ones. We do this by using the
121 quotient rather than the remainder. At the high end of the RNG
122 it's possible to get a quotient larger than n; discarding
123 these values eliminates the bias that would otherwise appear
124 when using a large n. */
125 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
127 val
= get_random () / denominator
;
128 while (val
>= XFASTINT (n
));
132 XSETINT (lispy_val
, val
);
136 /* Random data-structure functions */
138 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
139 doc
: /* Return the length of vector, list or string SEQUENCE.
140 A byte-code function object is also allowed.
141 If the string contains multibyte characters, this is not necessarily
142 the number of bytes in the string; it is the number of characters.
143 To get the number of bytes, use `string-bytes'. */)
145 register Lisp_Object sequence
;
147 register Lisp_Object val
;
150 if (STRINGP (sequence
))
151 XSETFASTINT (val
, SCHARS (sequence
));
152 else if (VECTORP (sequence
))
153 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
154 else if (SUB_CHAR_TABLE_P (sequence
))
155 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
156 else if (CHAR_TABLE_P (sequence
))
157 XSETFASTINT (val
, MAX_CHAR
);
158 else if (BOOL_VECTOR_P (sequence
))
159 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
160 else if (COMPILEDP (sequence
))
161 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
162 else if (CONSP (sequence
))
165 while (CONSP (sequence
))
167 sequence
= XCDR (sequence
);
170 if (!CONSP (sequence
))
173 sequence
= XCDR (sequence
);
178 CHECK_LIST_END (sequence
, sequence
);
180 val
= make_number (i
);
182 else if (NILP (sequence
))
183 XSETFASTINT (val
, 0);
185 wrong_type_argument (Qsequencep
, sequence
);
190 /* This does not check for quits. That is safe since it must terminate. */
192 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
193 doc
: /* Return the length of a list, but avoid error or infinite loop.
194 This function never gets an error. If LIST is not really a list,
195 it returns 0. If LIST is circular, it returns a finite value
196 which is at least the number of distinct elements. */)
200 Lisp_Object tail
, halftail
, length
;
203 /* halftail is used to detect circular lists. */
205 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
207 if (EQ (tail
, halftail
) && len
!= 0)
211 halftail
= XCDR (halftail
);
214 XSETINT (length
, len
);
218 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
219 doc
: /* Return the number of bytes in STRING.
220 If STRING is a multibyte string, this is greater than the length of STRING. */)
224 CHECK_STRING (string
);
225 return make_number (SBYTES (string
));
228 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
229 doc
: /* Return t if two strings have identical contents.
230 Case is significant, but text properties are ignored.
231 Symbols are also allowed; their print names are used instead. */)
233 register Lisp_Object s1
, s2
;
236 s1
= SYMBOL_NAME (s1
);
238 s2
= SYMBOL_NAME (s2
);
242 if (SCHARS (s1
) != SCHARS (s2
)
243 || SBYTES (s1
) != SBYTES (s2
)
244 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
249 DEFUN ("compare-strings", Fcompare_strings
,
250 Scompare_strings
, 6, 7, 0,
251 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
252 In string STR1, skip the first START1 characters and stop at END1.
253 In string STR2, skip the first START2 characters and stop at END2.
254 END1 and END2 default to the full lengths of the respective strings.
256 Case is significant in this comparison if IGNORE-CASE is nil.
257 Unibyte strings are converted to multibyte for comparison.
259 The value is t if the strings (or specified portions) match.
260 If string STR1 is less, the value is a negative number N;
261 - 1 - N is the number of characters that match at the beginning.
262 If string STR1 is greater, the value is a positive number N;
263 N - 1 is the number of characters that match at the beginning. */)
264 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
265 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
267 register int end1_char
, end2_char
;
268 register int i1
, i1_byte
, i2
, i2_byte
;
273 start1
= make_number (0);
275 start2
= make_number (0);
276 CHECK_NATNUM (start1
);
277 CHECK_NATNUM (start2
);
286 i1_byte
= string_char_to_byte (str1
, i1
);
287 i2_byte
= string_char_to_byte (str2
, i2
);
289 end1_char
= SCHARS (str1
);
290 if (! NILP (end1
) && end1_char
> XINT (end1
))
291 end1_char
= XINT (end1
);
293 end2_char
= SCHARS (str2
);
294 if (! NILP (end2
) && end2_char
> XINT (end2
))
295 end2_char
= XINT (end2
);
297 while (i1
< end1_char
&& i2
< end2_char
)
299 /* When we find a mismatch, we must compare the
300 characters, not just the bytes. */
303 if (STRING_MULTIBYTE (str1
))
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
307 c1
= SREF (str1
, i1
++);
308 c1
= unibyte_char_to_multibyte (c1
);
311 if (STRING_MULTIBYTE (str2
))
312 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
315 c2
= SREF (str2
, i2
++);
316 c2
= unibyte_char_to_multibyte (c2
);
322 if (! NILP (ignore_case
))
326 tem
= Fupcase (make_number (c1
));
328 tem
= Fupcase (make_number (c2
));
335 /* Note that I1 has already been incremented
336 past the character that we are comparing;
337 hence we don't add or subtract 1 here. */
339 return make_number (- i1
+ XINT (start1
));
341 return make_number (i1
- XINT (start1
));
345 return make_number (i1
- XINT (start1
) + 1);
347 return make_number (- i1
+ XINT (start1
) - 1);
352 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
353 doc
: /* Return t if first arg string is less than second in lexicographic order.
355 Symbols are also allowed; their print names are used instead. */)
357 register Lisp_Object s1
, s2
;
360 register int i1
, i1_byte
, i2
, i2_byte
;
363 s1
= SYMBOL_NAME (s1
);
365 s2
= SYMBOL_NAME (s2
);
369 i1
= i1_byte
= i2
= i2_byte
= 0;
372 if (end
> SCHARS (s2
))
377 /* When we find a mismatch, we must compare the
378 characters, not just the bytes. */
381 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
382 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
385 return c1
< c2
? Qt
: Qnil
;
387 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
391 /* "gcc -O3" enables automatic function inlining, which optimizes out
392 the arguments for the invocations of this function, whereas it
393 expects these values on the stack. */
394 static Lisp_Object
concat () __attribute__((noinline
));
406 return concat (2, args
, Lisp_String
, 0);
408 return concat (2, &s1
, Lisp_String
, 0);
409 #endif /* NO_ARG_ARRAY */
415 Lisp_Object s1
, s2
, s3
;
422 return concat (3, args
, Lisp_String
, 0);
424 return concat (3, &s1
, Lisp_String
, 0);
425 #endif /* NO_ARG_ARRAY */
428 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
429 doc
: /* Concatenate all the arguments and make the result a list.
430 The result is a list whose elements are the elements of all the arguments.
431 Each argument may be a list, vector or string.
432 The last argument is not copied, just used as the tail of the new list.
433 usage: (append &rest SEQUENCES) */)
438 return concat (nargs
, args
, Lisp_Cons
, 1);
441 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
442 doc
: /* Concatenate all the arguments and make the result a string.
443 The result is a string whose elements are the elements of all the arguments.
444 Each argument may be a string or a list or vector of characters (integers).
445 usage: (concat &rest SEQUENCES) */)
450 return concat (nargs
, args
, Lisp_String
, 0);
453 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
454 doc
: /* Concatenate all the arguments and make the result a vector.
455 The result is a vector whose elements are the elements of all the arguments.
456 Each argument may be a list, vector or string.
457 usage: (vconcat &rest SEQUENCES) */)
462 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
465 /* Return a copy of a sub char table ARG. The elements except for a
466 nested sub char table are not copied. */
468 copy_sub_char_table (arg
)
471 Lisp_Object copy
= make_sub_char_table (Qnil
);
474 XCHAR_TABLE (copy
)->defalt
= XCHAR_TABLE (arg
)->defalt
;
475 /* Copy all the contents. */
476 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
477 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
478 /* Recursively copy any sub char-tables in the ordinary slots. */
479 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
480 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
481 XCHAR_TABLE (copy
)->contents
[i
]
482 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
488 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
489 doc
: /* Return a copy of a list, vector, string or char-table.
490 The elements of a list or vector are not copied; they are shared
491 with the original. */)
495 if (NILP (arg
)) return arg
;
497 if (CHAR_TABLE_P (arg
))
502 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
503 /* Copy all the slots, including the extra ones. */
504 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
505 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
506 * sizeof (Lisp_Object
)));
508 /* Recursively copy any sub char tables in the ordinary slots
509 for multibyte characters. */
510 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
511 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
512 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
513 XCHAR_TABLE (copy
)->contents
[i
]
514 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
519 if (BOOL_VECTOR_P (arg
))
523 = ((XBOOL_VECTOR (arg
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
524 / BOOL_VECTOR_BITS_PER_CHAR
);
526 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
527 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
532 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
533 wrong_type_argument (Qsequencep
, arg
);
535 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
538 /* This structure holds information of an argument of `concat' that is
539 a string and has text properties to be copied. */
542 int argnum
; /* refer to ARGS (arguments of `concat') */
543 int from
; /* refer to ARGS[argnum] (argument string) */
544 int to
; /* refer to VAL (the target string) */
548 concat (nargs
, args
, target_type
, last_special
)
551 enum Lisp_Type target_type
;
555 register Lisp_Object tail
;
556 register Lisp_Object
this;
558 int toindex_byte
= 0;
559 register int result_len
;
560 register int result_len_byte
;
562 Lisp_Object last_tail
;
565 /* When we make a multibyte string, we can't copy text properties
566 while concatinating each string because the length of resulting
567 string can't be decided until we finish the whole concatination.
568 So, we record strings that have text properties to be copied
569 here, and copy the text properties after the concatination. */
570 struct textprop_rec
*textprops
= NULL
;
571 /* Number of elments in textprops. */
572 int num_textprops
= 0;
577 /* In append, the last arg isn't treated like the others */
578 if (last_special
&& nargs
> 0)
581 last_tail
= args
[nargs
];
586 /* Check each argument. */
587 for (argnum
= 0; argnum
< nargs
; argnum
++)
590 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
591 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
592 wrong_type_argument (Qsequencep
, this);
595 /* Compute total length in chars of arguments in RESULT_LEN.
596 If desired output is a string, also compute length in bytes
597 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
598 whether the result should be a multibyte string. */
602 for (argnum
= 0; argnum
< nargs
; argnum
++)
606 len
= XFASTINT (Flength (this));
607 if (target_type
== Lisp_String
)
609 /* We must count the number of bytes needed in the string
610 as well as the number of characters. */
616 for (i
= 0; i
< len
; i
++)
618 ch
= XVECTOR (this)->contents
[i
];
620 this_len_byte
= CHAR_BYTES (XINT (ch
));
621 result_len_byte
+= this_len_byte
;
622 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
625 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
626 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
627 else if (CONSP (this))
628 for (; CONSP (this); this = XCDR (this))
632 this_len_byte
= CHAR_BYTES (XINT (ch
));
633 result_len_byte
+= this_len_byte
;
634 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
637 else if (STRINGP (this))
639 if (STRING_MULTIBYTE (this))
642 result_len_byte
+= SBYTES (this);
645 result_len_byte
+= count_size_as_multibyte (SDATA (this),
653 if (! some_multibyte
)
654 result_len_byte
= result_len
;
656 /* Create the output object. */
657 if (target_type
== Lisp_Cons
)
658 val
= Fmake_list (make_number (result_len
), Qnil
);
659 else if (target_type
== Lisp_Vectorlike
)
660 val
= Fmake_vector (make_number (result_len
), Qnil
);
661 else if (some_multibyte
)
662 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
664 val
= make_uninit_string (result_len
);
666 /* In `append', if all but last arg are nil, return last arg. */
667 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
670 /* Copy the contents of the args into the result. */
672 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
674 toindex
= 0, toindex_byte
= 0;
678 SAFE_ALLOCA (textprops
, struct textprop_rec
*, sizeof (struct textprop_rec
) * nargs
);
680 for (argnum
= 0; argnum
< nargs
; argnum
++)
684 register unsigned int thisindex
= 0;
685 register unsigned int thisindex_byte
= 0;
689 thislen
= Flength (this), thisleni
= XINT (thislen
);
691 /* Between strings of the same kind, copy fast. */
692 if (STRINGP (this) && STRINGP (val
)
693 && STRING_MULTIBYTE (this) == some_multibyte
)
695 int thislen_byte
= SBYTES (this);
697 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
699 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
701 textprops
[num_textprops
].argnum
= argnum
;
702 textprops
[num_textprops
].from
= 0;
703 textprops
[num_textprops
++].to
= toindex
;
705 toindex_byte
+= thislen_byte
;
707 STRING_SET_CHARS (val
, SCHARS (val
));
709 /* Copy a single-byte string to a multibyte string. */
710 else if (STRINGP (this) && STRINGP (val
))
712 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
714 textprops
[num_textprops
].argnum
= argnum
;
715 textprops
[num_textprops
].from
= 0;
716 textprops
[num_textprops
++].to
= toindex
;
718 toindex_byte
+= copy_text (SDATA (this),
719 SDATA (val
) + toindex_byte
,
720 SCHARS (this), 0, 1);
724 /* Copy element by element. */
727 register Lisp_Object elt
;
729 /* Fetch next element of `this' arg into `elt', or break if
730 `this' is exhausted. */
731 if (NILP (this)) break;
733 elt
= XCAR (this), this = XCDR (this);
734 else if (thisindex
>= thisleni
)
736 else if (STRINGP (this))
739 if (STRING_MULTIBYTE (this))
741 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
744 XSETFASTINT (elt
, c
);
748 XSETFASTINT (elt
, SREF (this, thisindex
)); thisindex
++;
750 && (XINT (elt
) >= 0240
751 || (XINT (elt
) >= 0200
752 && ! NILP (Vnonascii_translation_table
)))
753 && XINT (elt
) < 0400)
755 c
= unibyte_char_to_multibyte (XINT (elt
));
760 else if (BOOL_VECTOR_P (this))
763 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BOOL_VECTOR_BITS_PER_CHAR
];
764 if (byte
& (1 << (thisindex
% BOOL_VECTOR_BITS_PER_CHAR
)))
771 elt
= XVECTOR (this)->contents
[thisindex
++];
773 /* Store this element into the result. */
780 else if (VECTORP (val
))
781 XVECTOR (val
)->contents
[toindex
++] = elt
;
785 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
789 += CHAR_STRING (XINT (elt
),
790 SDATA (val
) + toindex_byte
);
792 SSET (val
, toindex_byte
++, XINT (elt
));
796 /* If we have any multibyte characters,
797 we already decided to make a multibyte string. */
800 /* P exists as a variable
801 to avoid a bug on the Masscomp C compiler. */
802 unsigned char *p
= SDATA (val
) + toindex_byte
;
804 toindex_byte
+= CHAR_STRING (c
, p
);
811 XSETCDR (prev
, last_tail
);
813 if (num_textprops
> 0)
816 int last_to_end
= -1;
818 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
820 this = args
[textprops
[argnum
].argnum
];
821 props
= text_property_list (this,
823 make_number (SCHARS (this)),
825 /* If successive arguments have properites, be sure that the
826 value of `composition' property be the copy. */
827 if (last_to_end
== textprops
[argnum
].to
)
828 make_composition_value_copy (props
);
829 add_text_properties_from_list (val
, props
,
830 make_number (textprops
[argnum
].to
));
831 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
839 static Lisp_Object string_char_byte_cache_string
;
840 static int string_char_byte_cache_charpos
;
841 static int string_char_byte_cache_bytepos
;
844 clear_string_char_byte_cache ()
846 string_char_byte_cache_string
= Qnil
;
849 /* Return the character index corresponding to CHAR_INDEX in STRING. */
852 string_char_to_byte (string
, char_index
)
857 int best_below
, best_below_byte
;
858 int best_above
, best_above_byte
;
860 best_below
= best_below_byte
= 0;
861 best_above
= SCHARS (string
);
862 best_above_byte
= SBYTES (string
);
863 if (best_above
== best_above_byte
)
866 if (EQ (string
, string_char_byte_cache_string
))
868 if (string_char_byte_cache_charpos
< char_index
)
870 best_below
= string_char_byte_cache_charpos
;
871 best_below_byte
= string_char_byte_cache_bytepos
;
875 best_above
= string_char_byte_cache_charpos
;
876 best_above_byte
= string_char_byte_cache_bytepos
;
880 if (char_index
- best_below
< best_above
- char_index
)
882 while (best_below
< char_index
)
885 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
886 best_below
, best_below_byte
);
889 i_byte
= best_below_byte
;
893 while (best_above
> char_index
)
895 unsigned char *pend
= SDATA (string
) + best_above_byte
;
896 unsigned char *pbeg
= pend
- best_above_byte
;
897 unsigned char *p
= pend
- 1;
900 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
901 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
902 if (bytes
== pend
- p
)
903 best_above_byte
-= bytes
;
904 else if (bytes
> pend
- p
)
905 best_above_byte
-= (pend
- p
);
911 i_byte
= best_above_byte
;
914 string_char_byte_cache_bytepos
= i_byte
;
915 string_char_byte_cache_charpos
= i
;
916 string_char_byte_cache_string
= string
;
921 /* Return the character index corresponding to BYTE_INDEX in STRING. */
924 string_byte_to_char (string
, byte_index
)
929 int best_below
, best_below_byte
;
930 int best_above
, best_above_byte
;
932 best_below
= best_below_byte
= 0;
933 best_above
= SCHARS (string
);
934 best_above_byte
= SBYTES (string
);
935 if (best_above
== best_above_byte
)
938 if (EQ (string
, string_char_byte_cache_string
))
940 if (string_char_byte_cache_bytepos
< byte_index
)
942 best_below
= string_char_byte_cache_charpos
;
943 best_below_byte
= string_char_byte_cache_bytepos
;
947 best_above
= string_char_byte_cache_charpos
;
948 best_above_byte
= string_char_byte_cache_bytepos
;
952 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
954 while (best_below_byte
< byte_index
)
957 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
958 best_below
, best_below_byte
);
961 i_byte
= best_below_byte
;
965 while (best_above_byte
> byte_index
)
967 unsigned char *pend
= SDATA (string
) + best_above_byte
;
968 unsigned char *pbeg
= pend
- best_above_byte
;
969 unsigned char *p
= pend
- 1;
972 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
973 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
974 if (bytes
== pend
- p
)
975 best_above_byte
-= bytes
;
976 else if (bytes
> pend
- p
)
977 best_above_byte
-= (pend
- p
);
983 i_byte
= best_above_byte
;
986 string_char_byte_cache_bytepos
= i_byte
;
987 string_char_byte_cache_charpos
= i
;
988 string_char_byte_cache_string
= string
;
993 /* Convert STRING to a multibyte string.
994 Single-byte characters 0240 through 0377 are converted
995 by adding nonascii_insert_offset to each. */
998 string_make_multibyte (string
)
1006 if (STRING_MULTIBYTE (string
))
1009 nbytes
= count_size_as_multibyte (SDATA (string
),
1011 /* If all the chars are ASCII, they won't need any more bytes
1012 once converted. In that case, we can return STRING itself. */
1013 if (nbytes
== SBYTES (string
))
1016 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1017 copy_text (SDATA (string
), buf
, SBYTES (string
),
1020 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1027 /* Convert STRING to a multibyte string without changing each
1028 character codes. Thus, characters 0200 trough 0237 are converted
1029 to eight-bit-control characters, and characters 0240 through 0377
1030 are converted eight-bit-graphic characters. */
1033 string_to_multibyte (string
)
1041 if (STRING_MULTIBYTE (string
))
1044 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1045 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1046 any more bytes once converted. */
1047 if (nbytes
== SBYTES (string
))
1048 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1050 SAFE_ALLOCA (buf
, unsigned char *, nbytes
);
1051 bcopy (SDATA (string
), buf
, SBYTES (string
));
1052 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1054 ret
= make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1061 /* Convert STRING to a single-byte string. */
1064 string_make_unibyte (string
)
1072 if (! STRING_MULTIBYTE (string
))
1075 nchars
= SCHARS (string
);
1077 SAFE_ALLOCA (buf
, unsigned char *, nchars
);
1078 copy_text (SDATA (string
), buf
, SBYTES (string
),
1081 ret
= make_unibyte_string (buf
, nchars
);
1087 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1089 doc
: /* Return the multibyte equivalent of STRING.
1090 If STRING is unibyte and contains non-ASCII characters, the function
1091 `unibyte-char-to-multibyte' is used to convert each unibyte character
1092 to a multibyte character. In this case, the returned string is a
1093 newly created string with no text properties. If STRING is multibyte
1094 or entirely ASCII, it is returned unchanged. In particular, when
1095 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1096 \(When the characters are all ASCII, Emacs primitives will treat the
1097 string the same way whether it is unibyte or multibyte.) */)
1101 CHECK_STRING (string
);
1103 return string_make_multibyte (string
);
1106 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1108 doc
: /* Return the unibyte equivalent of STRING.
1109 Multibyte character codes are converted to unibyte according to
1110 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1111 If the lookup in the translation table fails, this function takes just
1112 the low 8 bits of each character. */)
1116 CHECK_STRING (string
);
1118 return string_make_unibyte (string
);
1121 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1123 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1124 If STRING is unibyte, the result is STRING itself.
1125 Otherwise it is a newly created string, with no text properties.
1126 If STRING is multibyte and contains a character of charset
1127 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1128 corresponding single byte. */)
1132 CHECK_STRING (string
);
1134 if (STRING_MULTIBYTE (string
))
1136 int bytes
= SBYTES (string
);
1137 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1139 bcopy (SDATA (string
), str
, bytes
);
1140 bytes
= str_as_unibyte (str
, bytes
);
1141 string
= make_unibyte_string (str
, bytes
);
1147 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1149 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1150 If STRING is multibyte, the result is STRING itself.
1151 Otherwise it is a newly created string, with no text properties.
1152 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1153 part of a multibyte form), it is converted to the corresponding
1154 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.
1155 Beware, this often doesn't really do what you think it does.
1156 It is similar to (decode-coding-string STRING 'emacs-mule-unix).
1157 If you're not sure, whether to use `string-as-multibyte' or
1158 `string-to-multibyte', use `string-to-multibyte'. Beware:
1159 (aref (string-as-multibyte "\\201") 0) -> 129 (aka ?\\201)
1160 (aref (string-as-multibyte "\\300") 0) -> 192 (aka ?\\300)
1161 (aref (string-as-multibyte "\\300\\201") 0) -> 192 (aka ?\\300)
1162 (aref (string-as-multibyte "\\300\\201") 1) -> 129 (aka ?\\201)
1164 (aref (string-as-multibyte "\\201\\300") 0) -> 2240
1165 (aref (string-as-multibyte "\\201\\300") 1) -> <error> */)
1169 CHECK_STRING (string
);
1171 if (! STRING_MULTIBYTE (string
))
1173 Lisp_Object new_string
;
1176 parse_str_as_multibyte (SDATA (string
),
1179 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1180 bcopy (SDATA (string
), SDATA (new_string
),
1182 if (nbytes
!= SBYTES (string
))
1183 str_as_multibyte (SDATA (new_string
), nbytes
,
1184 SBYTES (string
), NULL
);
1185 string
= new_string
;
1186 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1191 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1193 doc
: /* Return a multibyte string with the same individual chars as STRING.
1194 If STRING is multibyte, the result is STRING itself.
1195 Otherwise it is a newly created string, with no text properties.
1196 Characters 0200 through 0237 are converted to eight-bit-control
1197 characters of the same character code. Characters 0240 through 0377
1198 are converted to eight-bit-graphic characters of the same character
1200 This is similar to (decode-coding-string STRING 'binary) */)
1204 CHECK_STRING (string
);
1206 return string_to_multibyte (string
);
1210 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1211 doc
: /* Return a copy of ALIST.
1212 This is an alist which represents the same mapping from objects to objects,
1213 but does not share the alist structure with ALIST.
1214 The objects mapped (cars and cdrs of elements of the alist)
1215 are shared, however.
1216 Elements of ALIST that are not conses are also shared. */)
1220 register Lisp_Object tem
;
1225 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1226 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1228 register Lisp_Object car
;
1232 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1237 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1238 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1239 TO may be nil or omitted; then the substring runs to the end of STRING.
1240 FROM and TO start at 0. If either is negative, it counts from the end.
1242 This function allows vectors as well as strings. */)
1245 register Lisp_Object from
, to
;
1250 int from_char
, to_char
;
1251 int from_byte
= 0, to_byte
= 0;
1253 CHECK_VECTOR_OR_STRING (string
);
1254 CHECK_NUMBER (from
);
1256 if (STRINGP (string
))
1258 size
= SCHARS (string
);
1259 size_byte
= SBYTES (string
);
1262 size
= XVECTOR (string
)->size
;
1267 to_byte
= size_byte
;
1273 to_char
= XINT (to
);
1277 if (STRINGP (string
))
1278 to_byte
= string_char_to_byte (string
, to_char
);
1281 from_char
= XINT (from
);
1284 if (STRINGP (string
))
1285 from_byte
= string_char_to_byte (string
, from_char
);
1287 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1288 args_out_of_range_3 (string
, make_number (from_char
),
1289 make_number (to_char
));
1291 if (STRINGP (string
))
1293 res
= make_specified_string (SDATA (string
) + from_byte
,
1294 to_char
- from_char
, to_byte
- from_byte
,
1295 STRING_MULTIBYTE (string
));
1296 copy_text_properties (make_number (from_char
), make_number (to_char
),
1297 string
, make_number (0), res
, Qnil
);
1300 res
= Fvector (to_char
- from_char
,
1301 XVECTOR (string
)->contents
+ from_char
);
1307 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1308 doc
: /* Return a substring of STRING, without text properties.
1309 It starts at index FROM and ending before TO.
1310 TO may be nil or omitted; then the substring runs to the end of STRING.
1311 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1312 If FROM or TO is negative, it counts from the end.
1314 With one argument, just copy STRING without its properties. */)
1317 register Lisp_Object from
, to
;
1319 int size
, size_byte
;
1320 int from_char
, to_char
;
1321 int from_byte
, to_byte
;
1323 CHECK_STRING (string
);
1325 size
= SCHARS (string
);
1326 size_byte
= SBYTES (string
);
1329 from_char
= from_byte
= 0;
1332 CHECK_NUMBER (from
);
1333 from_char
= XINT (from
);
1337 from_byte
= string_char_to_byte (string
, from_char
);
1343 to_byte
= size_byte
;
1349 to_char
= XINT (to
);
1353 to_byte
= string_char_to_byte (string
, to_char
);
1356 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1357 args_out_of_range_3 (string
, make_number (from_char
),
1358 make_number (to_char
));
1360 return make_specified_string (SDATA (string
) + from_byte
,
1361 to_char
- from_char
, to_byte
- from_byte
,
1362 STRING_MULTIBYTE (string
));
1365 /* Extract a substring of STRING, giving start and end positions
1366 both in characters and in bytes. */
1369 substring_both (string
, from
, from_byte
, to
, to_byte
)
1371 int from
, from_byte
, to
, to_byte
;
1377 CHECK_VECTOR_OR_STRING (string
);
1379 if (STRINGP (string
))
1381 size
= SCHARS (string
);
1382 size_byte
= SBYTES (string
);
1385 size
= XVECTOR (string
)->size
;
1387 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1388 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1390 if (STRINGP (string
))
1392 res
= make_specified_string (SDATA (string
) + from_byte
,
1393 to
- from
, to_byte
- from_byte
,
1394 STRING_MULTIBYTE (string
));
1395 copy_text_properties (make_number (from
), make_number (to
),
1396 string
, make_number (0), res
, Qnil
);
1399 res
= Fvector (to
- from
,
1400 XVECTOR (string
)->contents
+ from
);
1405 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1406 doc
: /* Take cdr N times on LIST, returns the result. */)
1409 register Lisp_Object list
;
1411 register int i
, num
;
1414 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1417 CHECK_LIST_CONS (list
, list
);
1423 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1424 doc
: /* Return the Nth element of LIST.
1425 N counts from zero. If LIST is not that long, nil is returned. */)
1427 Lisp_Object n
, list
;
1429 return Fcar (Fnthcdr (n
, list
));
1432 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1433 doc
: /* Return element of SEQUENCE at index N. */)
1435 register Lisp_Object sequence
, n
;
1438 if (CONSP (sequence
) || NILP (sequence
))
1439 return Fcar (Fnthcdr (n
, sequence
));
1441 /* Faref signals a "not array" error, so check here. */
1442 CHECK_ARRAY (sequence
, Qsequencep
);
1443 return Faref (sequence
, n
);
1446 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1447 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1448 The value is actually the tail of LIST whose car is ELT. */)
1450 register Lisp_Object elt
;
1453 register Lisp_Object tail
;
1454 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1456 register Lisp_Object tem
;
1457 CHECK_LIST_CONS (tail
, list
);
1459 if (! NILP (Fequal (elt
, tem
)))
1466 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1467 doc
: /* Return non-nil if ELT is an element of LIST.
1468 Comparison done with `eq'. The value is actually the tail of LIST
1469 whose car is ELT. */)
1471 Lisp_Object elt
, list
;
1475 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1479 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1483 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1494 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1495 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1496 The value is actually the first element of LIST whose car is KEY.
1497 Elements of LIST that are not conses are ignored. */)
1499 Lisp_Object key
, list
;
1504 || (CONSP (XCAR (list
))
1505 && EQ (XCAR (XCAR (list
)), key
)))
1510 || (CONSP (XCAR (list
))
1511 && EQ (XCAR (XCAR (list
)), key
)))
1516 || (CONSP (XCAR (list
))
1517 && EQ (XCAR (XCAR (list
)), key
)))
1527 /* Like Fassq but never report an error and do not allow quits.
1528 Use only on lists known never to be circular. */
1531 assq_no_quit (key
, list
)
1532 Lisp_Object key
, list
;
1535 && (!CONSP (XCAR (list
))
1536 || !EQ (XCAR (XCAR (list
)), key
)))
1539 return CAR_SAFE (list
);
1542 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1543 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1544 The value is actually the first element of LIST whose car equals KEY. */)
1546 Lisp_Object key
, list
;
1553 || (CONSP (XCAR (list
))
1554 && (car
= XCAR (XCAR (list
)),
1555 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1560 || (CONSP (XCAR (list
))
1561 && (car
= XCAR (XCAR (list
)),
1562 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1567 || (CONSP (XCAR (list
))
1568 && (car
= XCAR (XCAR (list
)),
1569 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1579 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1580 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1581 The value is actually the first element of LIST whose cdr is KEY. */)
1583 register Lisp_Object key
;
1589 || (CONSP (XCAR (list
))
1590 && EQ (XCDR (XCAR (list
)), key
)))
1595 || (CONSP (XCAR (list
))
1596 && EQ (XCDR (XCAR (list
)), key
)))
1601 || (CONSP (XCAR (list
))
1602 && EQ (XCDR (XCAR (list
)), key
)))
1612 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1613 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1614 The value is actually the first element of LIST whose cdr equals KEY. */)
1616 Lisp_Object key
, list
;
1623 || (CONSP (XCAR (list
))
1624 && (cdr
= XCDR (XCAR (list
)),
1625 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1630 || (CONSP (XCAR (list
))
1631 && (cdr
= XCDR (XCAR (list
)),
1632 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1637 || (CONSP (XCAR (list
))
1638 && (cdr
= XCDR (XCAR (list
)),
1639 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1649 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1650 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1651 The modified LIST is returned. Comparison is done with `eq'.
1652 If the first member of LIST is ELT, there is no way to remove it by side effect;
1653 therefore, write `(setq foo (delq element foo))'
1654 to be sure of changing the value of `foo'. */)
1656 register Lisp_Object elt
;
1659 register Lisp_Object tail
, prev
;
1660 register Lisp_Object tem
;
1664 while (!NILP (tail
))
1666 CHECK_LIST_CONS (tail
, list
);
1673 Fsetcdr (prev
, XCDR (tail
));
1683 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1684 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1685 SEQ must be a list, a vector, or a string.
1686 The modified SEQ is returned. Comparison is done with `equal'.
1687 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1688 is not a side effect; it is simply using a different sequence.
1689 Therefore, write `(setq foo (delete element foo))'
1690 to be sure of changing the value of `foo'. */)
1692 Lisp_Object elt
, seq
;
1698 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1699 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1702 if (n
!= ASIZE (seq
))
1704 struct Lisp_Vector
*p
= allocate_vector (n
);
1706 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1707 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1708 p
->contents
[n
++] = AREF (seq
, i
);
1710 XSETVECTOR (seq
, p
);
1713 else if (STRINGP (seq
))
1715 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1718 for (i
= nchars
= nbytes
= ibyte
= 0;
1720 ++i
, ibyte
+= cbytes
)
1722 if (STRING_MULTIBYTE (seq
))
1724 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1725 SBYTES (seq
) - ibyte
);
1726 cbytes
= CHAR_BYTES (c
);
1734 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1741 if (nchars
!= SCHARS (seq
))
1745 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1746 if (!STRING_MULTIBYTE (seq
))
1747 STRING_SET_UNIBYTE (tem
);
1749 for (i
= nchars
= nbytes
= ibyte
= 0;
1751 ++i
, ibyte
+= cbytes
)
1753 if (STRING_MULTIBYTE (seq
))
1755 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1756 SBYTES (seq
) - ibyte
);
1757 cbytes
= CHAR_BYTES (c
);
1765 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1767 unsigned char *from
= SDATA (seq
) + ibyte
;
1768 unsigned char *to
= SDATA (tem
) + nbytes
;
1774 for (n
= cbytes
; n
--; )
1784 Lisp_Object tail
, prev
;
1786 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1788 CHECK_LIST_CONS (tail
, seq
);
1790 if (!NILP (Fequal (elt
, XCAR (tail
))))
1795 Fsetcdr (prev
, XCDR (tail
));
1806 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1807 doc
: /* Reverse LIST by modifying cdr pointers.
1808 Return the reversed list. */)
1812 register Lisp_Object prev
, tail
, next
;
1814 if (NILP (list
)) return list
;
1817 while (!NILP (tail
))
1820 CHECK_LIST_CONS (tail
, list
);
1822 Fsetcdr (tail
, prev
);
1829 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1830 doc
: /* Reverse LIST, copying. Return the reversed list.
1831 See also the function `nreverse', which is used more often. */)
1837 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1840 new = Fcons (XCAR (list
), new);
1842 CHECK_LIST_END (list
, list
);
1846 Lisp_Object
merge ();
1848 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1849 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1850 Returns the sorted list. LIST is modified by side effects.
1851 PREDICATE is called with two elements of LIST, and should return non-nil
1852 if the first element should sort before the second. */)
1854 Lisp_Object list
, predicate
;
1856 Lisp_Object front
, back
;
1857 register Lisp_Object len
, tem
;
1858 struct gcpro gcpro1
, gcpro2
;
1859 register int length
;
1862 len
= Flength (list
);
1863 length
= XINT (len
);
1867 XSETINT (len
, (length
/ 2) - 1);
1868 tem
= Fnthcdr (len
, list
);
1870 Fsetcdr (tem
, Qnil
);
1872 GCPRO2 (front
, back
);
1873 front
= Fsort (front
, predicate
);
1874 back
= Fsort (back
, predicate
);
1876 return merge (front
, back
, predicate
);
1880 merge (org_l1
, org_l2
, pred
)
1881 Lisp_Object org_l1
, org_l2
;
1885 register Lisp_Object tail
;
1887 register Lisp_Object l1
, l2
;
1888 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1895 /* It is sufficient to protect org_l1 and org_l2.
1896 When l1 and l2 are updated, we copy the new values
1897 back into the org_ vars. */
1898 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1918 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1934 Fsetcdr (tail
, tem
);
1940 #if 0 /* Unsafe version. */
1941 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1942 doc
: /* Extract a value from a property list.
1943 PLIST is a property list, which is a list of the form
1944 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1945 corresponding to the given PROP, or nil if PROP is not
1946 one of the properties on the list. */)
1954 CONSP (tail
) && CONSP (XCDR (tail
));
1955 tail
= XCDR (XCDR (tail
)))
1957 if (EQ (prop
, XCAR (tail
)))
1958 return XCAR (XCDR (tail
));
1960 /* This function can be called asynchronously
1961 (setup_coding_system). Don't QUIT in that case. */
1962 if (!interrupt_input_blocked
)
1966 CHECK_LIST_END (tail
, prop
);
1972 /* This does not check for quits. That is safe since it must terminate. */
1974 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1975 doc
: /* Extract a value from a property list.
1976 PLIST is a property list, which is a list of the form
1977 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1978 corresponding to the given PROP, or nil if PROP is not one of the
1979 properties on the list. This function never signals an error. */)
1984 Lisp_Object tail
, halftail
;
1986 /* halftail is used to detect circular lists. */
1987 tail
= halftail
= plist
;
1988 while (CONSP (tail
) && CONSP (XCDR (tail
)))
1990 if (EQ (prop
, XCAR (tail
)))
1991 return XCAR (XCDR (tail
));
1993 tail
= XCDR (XCDR (tail
));
1994 halftail
= XCDR (halftail
);
1995 if (EQ (tail
, halftail
))
2002 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2003 doc
: /* Return the value of SYMBOL's PROPNAME property.
2004 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2006 Lisp_Object symbol
, propname
;
2008 CHECK_SYMBOL (symbol
);
2009 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2012 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2013 doc
: /* Change value in PLIST of PROP to VAL.
2014 PLIST is a property list, which is a list of the form
2015 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2016 If PROP is already a property on the list, its value is set to VAL,
2017 otherwise the new PROP VAL pair is added. The new plist is returned;
2018 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2019 The PLIST is modified by side effects. */)
2022 register Lisp_Object prop
;
2025 register Lisp_Object tail
, prev
;
2026 Lisp_Object newcell
;
2028 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2029 tail
= XCDR (XCDR (tail
)))
2031 if (EQ (prop
, XCAR (tail
)))
2033 Fsetcar (XCDR (tail
), val
);
2040 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2044 Fsetcdr (XCDR (prev
), newcell
);
2048 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2049 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2050 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2051 (symbol
, propname
, value
)
2052 Lisp_Object symbol
, propname
, value
;
2054 CHECK_SYMBOL (symbol
);
2055 XSYMBOL (symbol
)->plist
2056 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2060 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2061 doc
: /* Extract a value from a property list, comparing with `equal'.
2062 PLIST is a property list, which is a list of the form
2063 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2064 corresponding to the given PROP, or nil if PROP is not
2065 one of the properties on the list. */)
2073 CONSP (tail
) && CONSP (XCDR (tail
));
2074 tail
= XCDR (XCDR (tail
)))
2076 if (! NILP (Fequal (prop
, XCAR (tail
))))
2077 return XCAR (XCDR (tail
));
2082 CHECK_LIST_END (tail
, prop
);
2087 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2088 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2089 PLIST is a property list, which is a list of the form
2090 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2091 If PROP is already a property on the list, its value is set to VAL,
2092 otherwise the new PROP VAL pair is added. The new plist is returned;
2093 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2094 The PLIST is modified by side effects. */)
2097 register Lisp_Object prop
;
2100 register Lisp_Object tail
, prev
;
2101 Lisp_Object newcell
;
2103 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2104 tail
= XCDR (XCDR (tail
)))
2106 if (! NILP (Fequal (prop
, XCAR (tail
))))
2108 Fsetcar (XCDR (tail
), val
);
2115 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2119 Fsetcdr (XCDR (prev
), newcell
);
2123 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2124 doc
: /* Return t if the two args are the same Lisp object.
2125 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2127 Lisp_Object obj1
, obj2
;
2130 return internal_equal (obj1
, obj2
, 0, 0) ? Qt
: Qnil
;
2132 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2135 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2136 doc
: /* Return t if two Lisp objects have similar structure and contents.
2137 They must have the same data type.
2138 Conses are compared by comparing the cars and the cdrs.
2139 Vectors and strings are compared element by element.
2140 Numbers are compared by value, but integers cannot equal floats.
2141 (Use `=' if you want integers and floats to be able to be equal.)
2142 Symbols must match exactly. */)
2144 register Lisp_Object o1
, o2
;
2146 return internal_equal (o1
, o2
, 0, 0) ? Qt
: Qnil
;
2149 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2150 doc
: /* Return t if two Lisp objects have similar structure and contents.
2151 This is like `equal' except that it compares the text properties
2152 of strings. (`equal' ignores text properties.) */)
2154 register Lisp_Object o1
, o2
;
2156 return internal_equal (o1
, o2
, 0, 1) ? Qt
: Qnil
;
2159 /* DEPTH is current depth of recursion. Signal an error if it
2161 PROPS, if non-nil, means compare string text properties too. */
2164 internal_equal (o1
, o2
, depth
, props
)
2165 register Lisp_Object o1
, o2
;
2169 error ("Stack overflow in equal");
2175 if (XTYPE (o1
) != XTYPE (o2
))
2184 d1
= extract_float (o1
);
2185 d2
= extract_float (o2
);
2186 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2187 though they are not =. */
2188 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2192 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
))
2199 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2203 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2205 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2208 o1
= XOVERLAY (o1
)->plist
;
2209 o2
= XOVERLAY (o2
)->plist
;
2214 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2215 && (XMARKER (o1
)->buffer
== 0
2216 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2220 case Lisp_Vectorlike
:
2223 EMACS_INT size
= XVECTOR (o1
)->size
;
2224 /* Pseudovectors have the type encoded in the size field, so this test
2225 actually checks that the objects have the same type as well as the
2227 if (XVECTOR (o2
)->size
!= size
)
2229 /* Boolvectors are compared much like strings. */
2230 if (BOOL_VECTOR_P (o1
))
2233 = ((XBOOL_VECTOR (o1
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2234 / BOOL_VECTOR_BITS_PER_CHAR
);
2236 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2238 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2243 if (WINDOW_CONFIGURATIONP (o1
))
2244 return compare_window_configurations (o1
, o2
, 0);
2246 /* Aside from them, only true vectors, char-tables, and compiled
2247 functions are sensible to compare, so eliminate the others now. */
2248 if (size
& PSEUDOVECTOR_FLAG
)
2250 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2252 size
&= PSEUDOVECTOR_SIZE_MASK
;
2254 for (i
= 0; i
< size
; i
++)
2257 v1
= XVECTOR (o1
)->contents
[i
];
2258 v2
= XVECTOR (o2
)->contents
[i
];
2259 if (!internal_equal (v1
, v2
, depth
+ 1, props
))
2267 if (SCHARS (o1
) != SCHARS (o2
))
2269 if (SBYTES (o1
) != SBYTES (o2
))
2271 if (bcmp (SDATA (o1
), SDATA (o2
),
2274 if (props
&& !compare_string_intervals (o1
, o2
))
2280 case Lisp_Type_Limit
:
2287 extern Lisp_Object
Fmake_char_internal ();
2289 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2290 doc
: /* Store each element of ARRAY with ITEM.
2291 ARRAY is a vector, string, char-table, or bool-vector. */)
2293 Lisp_Object array
, item
;
2295 register int size
, index
, charval
;
2296 if (VECTORP (array
))
2298 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2299 size
= XVECTOR (array
)->size
;
2300 for (index
= 0; index
< size
; index
++)
2303 else if (CHAR_TABLE_P (array
))
2305 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2306 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2307 for (index
= 0; index
< size
; index
++)
2309 XCHAR_TABLE (array
)->defalt
= Qnil
;
2311 else if (STRINGP (array
))
2313 register unsigned char *p
= SDATA (array
);
2314 CHECK_NUMBER (item
);
2315 charval
= XINT (item
);
2316 size
= SCHARS (array
);
2317 if (STRING_MULTIBYTE (array
))
2319 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2320 int len
= CHAR_STRING (charval
, str
);
2321 int size_byte
= SBYTES (array
);
2322 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2325 if (size
!= size_byte
)
2328 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2329 if (len
!= this_len
)
2330 error ("Attempt to change byte length of a string");
2333 for (i
= 0; i
< size_byte
; i
++)
2334 *p
++ = str
[i
% len
];
2337 for (index
= 0; index
< size
; index
++)
2340 else if (BOOL_VECTOR_P (array
))
2342 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2344 = ((XBOOL_VECTOR (array
)->size
+ BOOL_VECTOR_BITS_PER_CHAR
- 1)
2345 / BOOL_VECTOR_BITS_PER_CHAR
);
2347 charval
= (! NILP (item
) ? -1 : 0);
2348 for (index
= 0; index
< size_in_chars
- 1; index
++)
2350 if (index
< size_in_chars
)
2352 /* Mask out bits beyond the vector size. */
2353 if (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)
2354 charval
&= (1 << (XBOOL_VECTOR (array
)->size
% BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2359 wrong_type_argument (Qarrayp
, array
);
2363 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2365 doc
: /* Clear the contents of STRING.
2366 This makes STRING unibyte and may change its length. */)
2371 CHECK_STRING (string
);
2372 len
= SBYTES (string
);
2373 bzero (SDATA (string
), len
);
2374 STRING_SET_CHARS (string
, len
);
2375 STRING_SET_UNIBYTE (string
);
2379 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2381 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2383 Lisp_Object char_table
;
2385 CHECK_CHAR_TABLE (char_table
);
2387 return XCHAR_TABLE (char_table
)->purpose
;
2390 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2392 doc
: /* Return the parent char-table of CHAR-TABLE.
2393 The value is either nil or another char-table.
2394 If CHAR-TABLE holds nil for a given character,
2395 then the actual applicable value is inherited from the parent char-table
2396 \(or from its parents, if necessary). */)
2398 Lisp_Object char_table
;
2400 CHECK_CHAR_TABLE (char_table
);
2402 return XCHAR_TABLE (char_table
)->parent
;
2405 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2407 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2408 Return PARENT. PARENT must be either nil or another char-table. */)
2409 (char_table
, parent
)
2410 Lisp_Object char_table
, parent
;
2414 CHECK_CHAR_TABLE (char_table
);
2418 CHECK_CHAR_TABLE (parent
);
2420 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2421 if (EQ (temp
, char_table
))
2422 error ("Attempt to make a chartable be its own parent");
2425 XCHAR_TABLE (char_table
)->parent
= parent
;
2430 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2432 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2434 Lisp_Object char_table
, n
;
2436 CHECK_CHAR_TABLE (char_table
);
2439 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2440 args_out_of_range (char_table
, n
);
2442 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2445 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2446 Sset_char_table_extra_slot
,
2448 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2449 (char_table
, n
, value
)
2450 Lisp_Object char_table
, n
, value
;
2452 CHECK_CHAR_TABLE (char_table
);
2455 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2456 args_out_of_range (char_table
, n
);
2458 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2462 char_table_range (table
, from
, to
, defalt
)
2469 if (! NILP (XCHAR_TABLE (table
)->defalt
))
2470 defalt
= XCHAR_TABLE (table
)->defalt
;
2471 val
= XCHAR_TABLE (table
)->contents
[from
];
2472 if (SUB_CHAR_TABLE_P (val
))
2473 val
= char_table_range (val
, 32, 127, defalt
);
2474 else if (NILP (val
))
2476 for (from
++; from
<= to
; from
++)
2478 Lisp_Object this_val
;
2480 this_val
= XCHAR_TABLE (table
)->contents
[from
];
2481 if (SUB_CHAR_TABLE_P (this_val
))
2482 this_val
= char_table_range (this_val
, 32, 127, defalt
);
2483 else if (NILP (this_val
))
2485 if (! EQ (val
, this_val
))
2486 error ("Characters in the range have inconsistent values");
2492 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2494 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2495 RANGE should be nil (for the default value),
2496 a vector which identifies a character set or a row of a character set,
2497 a character set name, or a character code.
2498 If the characters in the specified range have different values,
2499 an error is signaled.
2501 Note that this function doesn't check the parent of CHAR-TABLE. */)
2503 Lisp_Object char_table
, range
;
2505 int charset_id
, c1
= 0, c2
= 0;
2507 Lisp_Object ch
, val
, current_default
;
2509 CHECK_CHAR_TABLE (char_table
);
2511 if (EQ (range
, Qnil
))
2512 return XCHAR_TABLE (char_table
)->defalt
;
2513 if (INTEGERP (range
))
2515 int c
= XINT (range
);
2516 if (! CHAR_VALID_P (c
, 0))
2517 error ("Invalid character code: %d", c
);
2519 SPLIT_CHAR (c
, charset_id
, c1
, c2
);
2521 else if (SYMBOLP (range
))
2523 Lisp_Object charset_info
;
2525 charset_info
= Fget (range
, Qcharset
);
2526 CHECK_VECTOR (charset_info
);
2527 charset_id
= XINT (XVECTOR (charset_info
)->contents
[0]);
2528 ch
= Fmake_char_internal (make_number (charset_id
),
2529 make_number (0), make_number (0));
2531 else if (VECTORP (range
))
2533 size
= ASIZE (range
);
2535 args_out_of_range (range
, make_number (0));
2536 CHECK_NUMBER (AREF (range
, 0));
2537 charset_id
= XINT (AREF (range
, 0));
2540 CHECK_NUMBER (AREF (range
, 1));
2541 c1
= XINT (AREF (range
, 1));
2544 CHECK_NUMBER (AREF (range
, 2));
2545 c2
= XINT (AREF (range
, 2));
2549 /* This checks if charset_id, c0, and c1 are all valid or not. */
2550 ch
= Fmake_char_internal (make_number (charset_id
),
2551 make_number (c1
), make_number (c2
));
2554 error ("Invalid RANGE argument to `char-table-range'");
2556 if (c1
> 0 && (CHARSET_DIMENSION (charset_id
) == 1 || c2
> 0))
2558 /* Fully specified character. */
2559 Lisp_Object parent
= XCHAR_TABLE (char_table
)->parent
;
2561 XCHAR_TABLE (char_table
)->parent
= Qnil
;
2562 val
= Faref (char_table
, ch
);
2563 XCHAR_TABLE (char_table
)->parent
= parent
;
2567 current_default
= XCHAR_TABLE (char_table
)->defalt
;
2568 if (charset_id
== CHARSET_ASCII
2569 || charset_id
== CHARSET_8_BIT_CONTROL
2570 || charset_id
== CHARSET_8_BIT_GRAPHIC
)
2572 int from
, to
, defalt
;
2574 if (charset_id
== CHARSET_ASCII
)
2575 from
= 0, to
= 127, defalt
= CHAR_TABLE_DEFAULT_SLOT_ASCII
;
2576 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2577 from
= 128, to
= 159, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
;
2579 from
= 160, to
= 255, defalt
= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
;
2580 if (! NILP (XCHAR_TABLE (char_table
)->contents
[defalt
]))
2581 current_default
= XCHAR_TABLE (char_table
)->contents
[defalt
];
2582 return char_table_range (char_table
, from
, to
, current_default
);
2585 val
= XCHAR_TABLE (char_table
)->contents
[128 + charset_id
];
2586 if (! SUB_CHAR_TABLE_P (val
))
2587 return (NILP (val
) ? current_default
: val
);
2588 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2589 current_default
= XCHAR_TABLE (val
)->defalt
;
2591 return char_table_range (val
, 32, 127, current_default
);
2592 val
= XCHAR_TABLE (val
)->contents
[c1
];
2593 if (! SUB_CHAR_TABLE_P (val
))
2594 return (NILP (val
) ? current_default
: val
);
2595 if (! NILP (XCHAR_TABLE (val
)->defalt
))
2596 current_default
= XCHAR_TABLE (val
)->defalt
;
2597 return char_table_range (val
, 32, 127, current_default
);
2600 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2602 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2603 RANGE should be t (for all characters), nil (for the default value),
2604 a character set, a vector which identifies a character set, a row of a
2605 character set, or a character code. Return VALUE. */)
2606 (char_table
, range
, value
)
2607 Lisp_Object char_table
, range
, value
;
2611 CHECK_CHAR_TABLE (char_table
);
2614 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2616 /* Don't set these special slots used for default values of
2617 ascii, eight-bit-control, and eight-bit-graphic. */
2618 if (i
!= CHAR_TABLE_DEFAULT_SLOT_ASCII
2619 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2620 && i
!= CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
)
2621 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2623 else if (EQ (range
, Qnil
))
2624 XCHAR_TABLE (char_table
)->defalt
= value
;
2625 else if (SYMBOLP (range
))
2627 Lisp_Object charset_info
;
2630 charset_info
= Fget (range
, Qcharset
);
2631 if (! VECTORP (charset_info
)
2632 || ! NATNUMP (AREF (charset_info
, 0))
2633 || (charset_id
= XINT (AREF (charset_info
, 0)),
2634 ! CHARSET_DEFINED_P (charset_id
)))
2635 error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range
)));
2637 if (charset_id
== CHARSET_ASCII
)
2638 for (i
= 0; i
< 128; i
++)
2639 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2640 else if (charset_id
== CHARSET_8_BIT_CONTROL
)
2641 for (i
= 128; i
< 160; i
++)
2642 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2643 else if (charset_id
== CHARSET_8_BIT_GRAPHIC
)
2644 for (i
= 160; i
< 256; i
++)
2645 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2647 XCHAR_TABLE (char_table
)->contents
[charset_id
+ 128] = value
;
2649 else if (INTEGERP (range
))
2650 Faset (char_table
, range
, value
);
2651 else if (VECTORP (range
))
2653 int size
= XVECTOR (range
)->size
;
2654 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2655 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2656 size
<= 1 ? Qnil
: val
[1],
2657 size
<= 2 ? Qnil
: val
[2]);
2658 Faset (char_table
, ch
, value
);
2661 error ("Invalid RANGE argument to `set-char-table-range'");
2666 DEFUN ("set-char-table-default", Fset_char_table_default
,
2667 Sset_char_table_default
, 3, 3, 0,
2668 doc
: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
2669 The generic character specifies the group of characters.
2670 If CH is a normal character, set the default value for a group of
2671 characters to which CH belongs.
2672 See also the documentation of `make-char'. */)
2673 (char_table
, ch
, value
)
2674 Lisp_Object char_table
, ch
, value
;
2676 int c
, charset
, code1
, code2
;
2679 CHECK_CHAR_TABLE (char_table
);
2683 SPLIT_CHAR (c
, charset
, code1
, code2
);
2685 /* Since we may want to set the default value for a character set
2686 not yet defined, we check only if the character set is in the
2687 valid range or not, instead of it is already defined or not. */
2688 if (! CHARSET_VALID_P (charset
))
2689 invalid_character (c
);
2691 if (SINGLE_BYTE_CHAR_P (c
))
2693 /* We use special slots for the default values of single byte
2696 = (c
< 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
2697 : c
< 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
2698 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC
);
2700 return (XCHAR_TABLE (char_table
)->contents
[default_slot
] = value
);
2703 /* Even if C is not a generic char, we had better behave as if a
2704 generic char is specified. */
2705 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2707 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2708 if (! SUB_CHAR_TABLE_P (temp
))
2710 temp
= make_sub_char_table (temp
);
2711 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = temp
;
2715 XCHAR_TABLE (temp
)->defalt
= value
;
2719 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2720 if (SUB_CHAR_TABLE_P (temp
))
2721 XCHAR_TABLE (temp
)->defalt
= value
;
2723 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2727 /* Look up the element in TABLE at index CH,
2728 and return it as an integer.
2729 If the element is nil, return CH itself.
2730 (Actually we do that for any non-integer.) */
2733 char_table_translate (table
, ch
)
2738 value
= Faref (table
, make_number (ch
));
2739 if (! INTEGERP (value
))
2741 return XINT (value
);
2745 optimize_sub_char_table (table
, chars
)
2753 from
= 33, to
= 127;
2755 from
= 32, to
= 128;
2757 if (!SUB_CHAR_TABLE_P (*table
))
2759 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2760 for (; from
< to
; from
++)
2761 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2766 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2767 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2775 CHECK_CHAR_TABLE (table
);
2777 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2779 elt
= XCHAR_TABLE (table
)->contents
[i
];
2780 if (!SUB_CHAR_TABLE_P (elt
))
2782 dim
= CHARSET_DIMENSION (i
- 128);
2784 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2785 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2786 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2792 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2793 character or group of characters that share a value.
2794 DEPTH is the current depth in the originally specified
2795 chartable, and INDICES contains the vector indices
2796 for the levels our callers have descended.
2798 ARG is passed to C_FUNCTION when that is called. */
2801 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2802 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2803 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2807 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2809 GCPRO4 (arg
, table
, subtable
, function
);
2813 /* At first, handle ASCII and 8-bit European characters. */
2814 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2816 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2818 elt
= XCHAR_TABLE (subtable
)->defalt
;
2820 elt
= Faref (subtable
, make_number (i
));
2822 (*c_function
) (arg
, make_number (i
), elt
);
2824 call2 (function
, make_number (i
), elt
);
2826 #if 0 /* If the char table has entries for higher characters,
2827 we should report them. */
2828 if (NILP (current_buffer
->enable_multibyte_characters
))
2834 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2838 int charset
= XFASTINT (indices
[0]) - 128;
2841 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2842 if (CHARSET_CHARS (charset
) == 94)
2851 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2852 XSETFASTINT (indices
[depth
], i
);
2853 charset
= XFASTINT (indices
[0]) - 128;
2855 && (!CHARSET_DEFINED_P (charset
)
2856 || charset
== CHARSET_8_BIT_CONTROL
2857 || charset
== CHARSET_8_BIT_GRAPHIC
))
2860 if (SUB_CHAR_TABLE_P (elt
))
2863 error ("Too deep char table");
2864 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2870 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2871 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2872 c
= MAKE_CHAR (charset
, c1
, c2
);
2875 elt
= XCHAR_TABLE (subtable
)->defalt
;
2877 elt
= Faref (table
, make_number (c
));
2880 (*c_function
) (arg
, make_number (c
), elt
);
2882 call2 (function
, make_number (c
), elt
);
2888 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2890 void_call2 (a
, b
, c
)
2891 Lisp_Object a
, b
, c
;
2896 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2898 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2899 FUNCTION is called with two arguments--a key and a value.
2900 The key is always a possible IDX argument to `aref'. */)
2901 (function
, char_table
)
2902 Lisp_Object function
, char_table
;
2904 /* The depth of char table is at most 3. */
2905 Lisp_Object indices
[3];
2907 CHECK_CHAR_TABLE (char_table
);
2909 /* When Lisp_Object is represented as a union, `call2' cannot directly
2910 be passed to map_char_table because it returns a Lisp_Object rather
2911 than returning nothing.
2912 Casting leads to crashes on some architectures. -stef */
2913 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2917 /* Return a value for character C in char-table TABLE. Store the
2918 actual index for that value in *IDX. Ignore the default value of
2922 char_table_ref_and_index (table
, c
, idx
)
2926 int charset
, c1
, c2
;
2929 if (SINGLE_BYTE_CHAR_P (c
))
2932 return XCHAR_TABLE (table
)->contents
[c
];
2934 SPLIT_CHAR (c
, charset
, c1
, c2
);
2935 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2936 *idx
= MAKE_CHAR (charset
, 0, 0);
2937 if (!SUB_CHAR_TABLE_P (elt
))
2939 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2940 return XCHAR_TABLE (elt
)->defalt
;
2941 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2942 *idx
= MAKE_CHAR (charset
, c1
, 0);
2943 if (!SUB_CHAR_TABLE_P (elt
))
2945 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2946 return XCHAR_TABLE (elt
)->defalt
;
2948 return XCHAR_TABLE (elt
)->contents
[c2
];
2958 Lisp_Object args
[2];
2961 return Fnconc (2, args
);
2963 return Fnconc (2, &s1
);
2964 #endif /* NO_ARG_ARRAY */
2967 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2968 doc
: /* Concatenate any number of lists by altering them.
2969 Only the last argument is not altered, and need not be a list.
2970 usage: (nconc &rest LISTS) */)
2975 register int argnum
;
2976 register Lisp_Object tail
, tem
, val
;
2980 for (argnum
= 0; argnum
< nargs
; argnum
++)
2983 if (NILP (tem
)) continue;
2988 if (argnum
+ 1 == nargs
) break;
2990 CHECK_LIST_CONS (tem
, tem
);
2999 tem
= args
[argnum
+ 1];
3000 Fsetcdr (tail
, tem
);
3002 args
[argnum
+ 1] = tail
;
3008 /* This is the guts of all mapping functions.
3009 Apply FN to each element of SEQ, one by one,
3010 storing the results into elements of VALS, a C vector of Lisp_Objects.
3011 LENI is the length of VALS, which should also be the length of SEQ. */
3014 mapcar1 (leni
, vals
, fn
, seq
)
3017 Lisp_Object fn
, seq
;
3019 register Lisp_Object tail
;
3022 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3026 /* Don't let vals contain any garbage when GC happens. */
3027 for (i
= 0; i
< leni
; i
++)
3030 GCPRO3 (dummy
, fn
, seq
);
3032 gcpro1
.nvars
= leni
;
3036 /* We need not explicitly protect `tail' because it is used only on lists, and
3037 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
3041 for (i
= 0; i
< leni
; i
++)
3043 dummy
= XVECTOR (seq
)->contents
[i
];
3044 dummy
= call1 (fn
, dummy
);
3049 else if (BOOL_VECTOR_P (seq
))
3051 for (i
= 0; i
< leni
; i
++)
3054 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BOOL_VECTOR_BITS_PER_CHAR
];
3055 if (byte
& (1 << (i
% BOOL_VECTOR_BITS_PER_CHAR
)))
3060 dummy
= call1 (fn
, dummy
);
3065 else if (STRINGP (seq
))
3069 for (i
= 0, i_byte
= 0; i
< leni
;)
3074 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
3075 XSETFASTINT (dummy
, c
);
3076 dummy
= call1 (fn
, dummy
);
3078 vals
[i_before
] = dummy
;
3081 else /* Must be a list, since Flength did not get an error */
3084 for (i
= 0; i
< leni
&& CONSP (tail
); i
++)
3086 dummy
= call1 (fn
, XCAR (tail
));
3096 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
3097 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3098 In between each pair of results, stick in SEPARATOR. Thus, " " as
3099 SEPARATOR results in spaces between the values returned by FUNCTION.
3100 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3101 (function
, sequence
, separator
)
3102 Lisp_Object function
, sequence
, separator
;
3107 register Lisp_Object
*args
;
3109 struct gcpro gcpro1
;
3113 len
= Flength (sequence
);
3115 nargs
= leni
+ leni
- 1;
3116 if (nargs
< 0) return build_string ("");
3118 SAFE_ALLOCA_LISP (args
, nargs
);
3121 mapcar1 (leni
, args
, function
, sequence
);
3124 for (i
= leni
- 1; i
> 0; i
--)
3125 args
[i
+ i
] = args
[i
];
3127 for (i
= 1; i
< nargs
; i
+= 2)
3128 args
[i
] = separator
;
3130 ret
= Fconcat (nargs
, args
);
3136 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
3137 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3138 The result is a list just as long as SEQUENCE.
3139 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3140 (function
, sequence
)
3141 Lisp_Object function
, sequence
;
3143 register Lisp_Object len
;
3145 register Lisp_Object
*args
;
3149 len
= Flength (sequence
);
3150 leni
= XFASTINT (len
);
3152 SAFE_ALLOCA_LISP (args
, leni
);
3154 mapcar1 (leni
, args
, function
, sequence
);
3156 ret
= Flist (leni
, args
);
3162 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
3163 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
3164 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
3165 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
3166 (function
, sequence
)
3167 Lisp_Object function
, sequence
;
3171 leni
= XFASTINT (Flength (sequence
));
3172 mapcar1 (leni
, 0, function
, sequence
);
3177 /* Anything that calls this function must protect from GC! */
3179 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
3180 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3181 Takes one argument, which is the string to display to ask the question.
3182 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3183 No confirmation of the answer is requested; a single character is enough.
3184 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3185 the bindings in `query-replace-map'; see the documentation of that variable
3186 for more information. In this case, the useful bindings are `act', `skip',
3187 `recenter', and `quit'.\)
3189 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3190 is nil and `use-dialog-box' is non-nil. */)
3194 register Lisp_Object obj
, key
, def
, map
;
3195 register int answer
;
3196 Lisp_Object xprompt
;
3197 Lisp_Object args
[2];
3198 struct gcpro gcpro1
, gcpro2
;
3199 int count
= SPECPDL_INDEX ();
3201 specbind (Qcursor_in_echo_area
, Qt
);
3203 map
= Fsymbol_value (intern ("query-replace-map"));
3205 CHECK_STRING (prompt
);
3207 GCPRO2 (prompt
, xprompt
);
3209 #ifdef HAVE_X_WINDOWS
3210 if (display_hourglass_p
)
3211 cancel_hourglass ();
3218 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3222 Lisp_Object pane
, menu
;
3223 redisplay_preserve_echo_area (3);
3224 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3225 Fcons (Fcons (build_string ("No"), Qnil
),
3227 menu
= Fcons (prompt
, pane
);
3228 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3229 answer
= !NILP (obj
);
3232 #endif /* HAVE_MENUS */
3233 cursor_in_echo_area
= 1;
3234 choose_minibuf_frame ();
3237 Lisp_Object pargs
[3];
3239 /* Colorize prompt according to `minibuffer-prompt' face. */
3240 pargs
[0] = build_string ("%s(y or n) ");
3241 pargs
[1] = intern ("face");
3242 pargs
[2] = intern ("minibuffer-prompt");
3243 args
[0] = Fpropertize (3, pargs
);
3248 if (minibuffer_auto_raise
)
3250 Lisp_Object mini_frame
;
3252 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3254 Fraise_frame (mini_frame
);
3257 obj
= read_filtered_event (1, 0, 0, 0, Qnil
);
3258 cursor_in_echo_area
= 0;
3259 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3262 key
= Fmake_vector (make_number (1), obj
);
3263 def
= Flookup_key (map
, key
, Qt
);
3265 if (EQ (def
, intern ("skip")))
3270 else if (EQ (def
, intern ("act")))
3275 else if (EQ (def
, intern ("recenter")))
3281 else if (EQ (def
, intern ("quit")))
3283 /* We want to exit this command for exit-prefix,
3284 and this is the only way to do it. */
3285 else if (EQ (def
, intern ("exit-prefix")))
3290 /* If we don't clear this, then the next call to read_char will
3291 return quit_char again, and we'll enter an infinite loop. */
3296 if (EQ (xprompt
, prompt
))
3298 args
[0] = build_string ("Please answer y or n. ");
3300 xprompt
= Fconcat (2, args
);
3305 if (! noninteractive
)
3307 cursor_in_echo_area
= -1;
3308 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3312 unbind_to (count
, Qnil
);
3313 return answer
? Qt
: Qnil
;
3316 /* This is how C code calls `yes-or-no-p' and allows the user
3319 Anything that calls this function must protect from GC! */
3322 do_yes_or_no_p (prompt
)
3325 return call1 (intern ("yes-or-no-p"), prompt
);
3328 /* Anything that calls this function must protect from GC! */
3330 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3331 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3332 Takes one argument, which is the string to display to ask the question.
3333 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3334 The user must confirm the answer with RET,
3335 and can edit it until it has been confirmed.
3337 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3338 is nil, and `use-dialog-box' is non-nil. */)
3342 register Lisp_Object ans
;
3343 Lisp_Object args
[2];
3344 struct gcpro gcpro1
;
3346 CHECK_STRING (prompt
);
3349 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3353 Lisp_Object pane
, menu
, obj
;
3354 redisplay_preserve_echo_area (4);
3355 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3356 Fcons (Fcons (build_string ("No"), Qnil
),
3359 menu
= Fcons (prompt
, pane
);
3360 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
3364 #endif /* HAVE_MENUS */
3367 args
[1] = build_string ("(yes or no) ");
3368 prompt
= Fconcat (2, args
);
3374 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3375 Qyes_or_no_p_history
, Qnil
,
3377 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3382 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3390 message ("Please answer yes or no.");
3391 Fsleep_for (make_number (2), Qnil
);
3395 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3396 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3398 Each of the three load averages is multiplied by 100, then converted
3401 When USE-FLOATS is non-nil, floats will be used instead of integers.
3402 These floats are not multiplied by 100.
3404 If the 5-minute or 15-minute load averages are not available, return a
3405 shortened list, containing only those averages which are available.
3407 An error is thrown if the load average can't be obtained. In some
3408 cases making it work would require Emacs being installed setuid or
3409 setgid so that it can read kernel information, and that usually isn't
3412 Lisp_Object use_floats
;
3415 int loads
= getloadavg (load_ave
, 3);
3416 Lisp_Object ret
= Qnil
;
3419 error ("load-average not implemented for this operating system");
3423 Lisp_Object load
= (NILP (use_floats
) ?
3424 make_number ((int) (100.0 * load_ave
[loads
]))
3425 : make_float (load_ave
[loads
]));
3426 ret
= Fcons (load
, ret
);
3432 Lisp_Object Vfeatures
, Qsubfeatures
;
3433 extern Lisp_Object Vafter_load_alist
;
3435 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3436 doc
: /* Returns t if FEATURE is present in this Emacs.
3438 Use this to conditionalize execution of lisp code based on the
3439 presence or absence of emacs or environment extensions.
3440 Use `provide' to declare that a feature is available. This function
3441 looks at the value of the variable `features'. The optional argument
3442 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3443 (feature
, subfeature
)
3444 Lisp_Object feature
, subfeature
;
3446 register Lisp_Object tem
;
3447 CHECK_SYMBOL (feature
);
3448 tem
= Fmemq (feature
, Vfeatures
);
3449 if (!NILP (tem
) && !NILP (subfeature
))
3450 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3451 return (NILP (tem
)) ? Qnil
: Qt
;
3454 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3455 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3456 The optional argument SUBFEATURES should be a list of symbols listing
3457 particular subfeatures supported in this version of FEATURE. */)
3458 (feature
, subfeatures
)
3459 Lisp_Object feature
, subfeatures
;
3461 register Lisp_Object tem
;
3462 CHECK_SYMBOL (feature
);
3463 CHECK_LIST (subfeatures
);
3464 if (!NILP (Vautoload_queue
))
3465 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
3467 tem
= Fmemq (feature
, Vfeatures
);
3469 Vfeatures
= Fcons (feature
, Vfeatures
);
3470 if (!NILP (subfeatures
))
3471 Fput (feature
, Qsubfeatures
, subfeatures
);
3472 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3474 /* Run any load-hooks for this file. */
3475 tem
= Fassq (feature
, Vafter_load_alist
);
3477 Fprogn (XCDR (tem
));
3482 /* `require' and its subroutines. */
3484 /* List of features currently being require'd, innermost first. */
3486 Lisp_Object require_nesting_list
;
3489 require_unwind (old_value
)
3490 Lisp_Object old_value
;
3492 return require_nesting_list
= old_value
;
3495 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3496 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3497 If FEATURE is not a member of the list `features', then the feature
3498 is not loaded; so load the file FILENAME.
3499 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3500 and `load' will try to load this name appended with the suffix `.elc' or
3501 `.el', in that order. The name without appended suffix will not be used.
3502 If the optional third argument NOERROR is non-nil,
3503 then return nil if the file is not found instead of signaling an error.
3504 Normally the return value is FEATURE.
3505 The normal messages at start and end of loading FILENAME are suppressed. */)
3506 (feature
, filename
, noerror
)
3507 Lisp_Object feature
, filename
, noerror
;
3509 register Lisp_Object tem
;
3510 struct gcpro gcpro1
, gcpro2
;
3511 int from_file
= load_in_progress
;
3513 CHECK_SYMBOL (feature
);
3515 /* Record the presence of `require' in this file
3516 even if the feature specified is already loaded.
3517 But not more than once in any file,
3518 and not when we aren't loading or reading from a file. */
3520 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
3521 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
3526 tem
= Fcons (Qrequire
, feature
);
3527 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
3528 LOADHIST_ATTACH (tem
);
3530 tem
= Fmemq (feature
, Vfeatures
);
3534 int count
= SPECPDL_INDEX ();
3537 /* This is to make sure that loadup.el gives a clear picture
3538 of what files are preloaded and when. */
3539 if (! NILP (Vpurify_flag
))
3540 error ("(require %s) while preparing to dump",
3541 SDATA (SYMBOL_NAME (feature
)));
3543 /* A certain amount of recursive `require' is legitimate,
3544 but if we require the same feature recursively 3 times,
3546 tem
= require_nesting_list
;
3547 while (! NILP (tem
))
3549 if (! NILP (Fequal (feature
, XCAR (tem
))))
3554 error ("Recursive `require' for feature `%s'",
3555 SDATA (SYMBOL_NAME (feature
)));
3557 /* Update the list for any nested `require's that occur. */
3558 record_unwind_protect (require_unwind
, require_nesting_list
);
3559 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3561 /* Value saved here is to be restored into Vautoload_queue */
3562 record_unwind_protect (un_autoload
, Vautoload_queue
);
3563 Vautoload_queue
= Qt
;
3565 /* Load the file. */
3566 GCPRO2 (feature
, filename
);
3567 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3568 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3571 /* If load failed entirely, return nil. */
3573 return unbind_to (count
, Qnil
);
3575 tem
= Fmemq (feature
, Vfeatures
);
3577 error ("Required feature `%s' was not provided",
3578 SDATA (SYMBOL_NAME (feature
)));
3580 /* Once loading finishes, don't undo it. */
3581 Vautoload_queue
= Qt
;
3582 feature
= unbind_to (count
, feature
);
3588 /* Primitives for work of the "widget" library.
3589 In an ideal world, this section would not have been necessary.
3590 However, lisp function calls being as slow as they are, it turns
3591 out that some functions in the widget library (wid-edit.el) are the
3592 bottleneck of Widget operation. Here is their translation to C,
3593 for the sole reason of efficiency. */
3595 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3596 doc
: /* Return non-nil if PLIST has the property PROP.
3597 PLIST is a property list, which is a list of the form
3598 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3599 Unlike `plist-get', this allows you to distinguish between a missing
3600 property and a property with the value nil.
3601 The value is actually the tail of PLIST whose car is PROP. */)
3603 Lisp_Object plist
, prop
;
3605 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3608 plist
= XCDR (plist
);
3609 plist
= CDR (plist
);
3614 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3615 doc
: /* In WIDGET, set PROPERTY to VALUE.
3616 The value can later be retrieved with `widget-get'. */)
3617 (widget
, property
, value
)
3618 Lisp_Object widget
, property
, value
;
3620 CHECK_CONS (widget
);
3621 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3625 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3626 doc
: /* In WIDGET, get the value of PROPERTY.
3627 The value could either be specified when the widget was created, or
3628 later with `widget-put'. */)
3630 Lisp_Object widget
, property
;
3638 CHECK_CONS (widget
);
3639 tmp
= Fplist_member (XCDR (widget
), property
);
3645 tmp
= XCAR (widget
);
3648 widget
= Fget (tmp
, Qwidget_type
);
3652 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3653 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3654 ARGS are passed as extra arguments to the function.
3655 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3660 /* This function can GC. */
3661 Lisp_Object newargs
[3];
3662 struct gcpro gcpro1
, gcpro2
;
3665 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3666 newargs
[1] = args
[0];
3667 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3668 GCPRO2 (newargs
[0], newargs
[2]);
3669 result
= Fapply (3, newargs
);
3674 #ifdef HAVE_LANGINFO_CODESET
3675 #include <langinfo.h>
3678 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3679 doc
: /* Access locale data ITEM for the current C locale, if available.
3680 ITEM should be one of the following:
3682 `codeset', returning the character set as a string (locale item CODESET);
3684 `days', returning a 7-element vector of day names (locale items DAY_n);
3686 `months', returning a 12-element vector of month names (locale items MON_n);
3688 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3689 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3691 If the system can't provide such information through a call to
3692 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3694 See also Info node `(libc)Locales'.
3696 The data read from the system are decoded using `locale-coding-system'. */)
3701 #ifdef HAVE_LANGINFO_CODESET
3703 if (EQ (item
, Qcodeset
))
3705 str
= nl_langinfo (CODESET
);
3706 return build_string (str
);
3709 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3711 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3712 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3714 synchronize_system_time_locale ();
3715 for (i
= 0; i
< 7; i
++)
3717 str
= nl_langinfo (days
[i
]);
3718 val
= make_unibyte_string (str
, strlen (str
));
3719 /* Fixme: Is this coding system necessarily right, even if
3720 it is consistent with CODESET? If not, what to do? */
3721 Faset (v
, make_number (i
),
3722 code_convert_string_norecord (val
, Vlocale_coding_system
,
3729 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3731 struct Lisp_Vector
*p
= allocate_vector (12);
3732 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3733 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3735 synchronize_system_time_locale ();
3736 for (i
= 0; i
< 12; i
++)
3738 str
= nl_langinfo (months
[i
]);
3739 val
= make_unibyte_string (str
, strlen (str
));
3741 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3743 XSETVECTOR (val
, p
);
3747 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3748 but is in the locale files. This could be used by ps-print. */
3750 else if (EQ (item
, Qpaper
))
3752 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3753 make_number (nl_langinfo (PAPER_HEIGHT
)));
3755 #endif /* PAPER_WIDTH */
3756 #endif /* HAVE_LANGINFO_CODESET*/
3760 /* base64 encode/decode functions (RFC 2045).
3761 Based on code from GNU recode. */
3763 #define MIME_LINE_LENGTH 76
3765 #define IS_ASCII(Character) \
3767 #define IS_BASE64(Character) \
3768 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3769 #define IS_BASE64_IGNORABLE(Character) \
3770 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3771 || (Character) == '\f' || (Character) == '\r')
3773 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3774 character or return retval if there are no characters left to
3776 #define READ_QUADRUPLET_BYTE(retval) \
3781 if (nchars_return) \
3782 *nchars_return = nchars; \
3787 while (IS_BASE64_IGNORABLE (c))
3789 /* Table of characters coding the 64 values. */
3790 static char base64_value_to_char
[64] =
3792 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3793 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3794 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3795 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3796 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3797 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3798 '8', '9', '+', '/' /* 60-63 */
3801 /* Table of base64 values for first 128 characters. */
3802 static short base64_char_to_value
[128] =
3804 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3805 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3806 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3807 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3808 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3809 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3810 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3811 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3812 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3813 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3814 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3815 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3816 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3819 /* The following diagram shows the logical steps by which three octets
3820 get transformed into four base64 characters.
3822 .--------. .--------. .--------.
3823 |aaaaaabb| |bbbbcccc| |ccdddddd|
3824 `--------' `--------' `--------'
3826 .--------+--------+--------+--------.
3827 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3828 `--------+--------+--------+--------'
3830 .--------+--------+--------+--------.
3831 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3832 `--------+--------+--------+--------'
3834 The octets are divided into 6 bit chunks, which are then encoded into
3835 base64 characters. */
3838 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3839 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3841 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3843 doc
: /* Base64-encode the region between BEG and END.
3844 Return the length of the encoded text.
3845 Optional third argument NO-LINE-BREAK means do not break long lines
3846 into shorter lines. */)
3847 (beg
, end
, no_line_break
)
3848 Lisp_Object beg
, end
, no_line_break
;
3851 int allength
, length
;
3852 int ibeg
, iend
, encoded_length
;
3856 validate_region (&beg
, &end
);
3858 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3859 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3860 move_gap_both (XFASTINT (beg
), ibeg
);
3862 /* We need to allocate enough room for encoding the text.
3863 We need 33 1/3% more space, plus a newline every 76
3864 characters, and then we round up. */
3865 length
= iend
- ibeg
;
3866 allength
= length
+ length
/3 + 1;
3867 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3869 SAFE_ALLOCA (encoded
, char *, allength
);
3870 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3871 NILP (no_line_break
),
3872 !NILP (current_buffer
->enable_multibyte_characters
));
3873 if (encoded_length
> allength
)
3876 if (encoded_length
< 0)
3878 /* The encoding wasn't possible. */
3880 error ("Multibyte character in data for base64 encoding");
3883 /* Now we have encoded the region, so we insert the new contents
3884 and delete the old. (Insert first in order to preserve markers.) */
3885 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3886 insert (encoded
, encoded_length
);
3888 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3890 /* If point was outside of the region, restore it exactly; else just
3891 move to the beginning of the region. */
3892 if (old_pos
>= XFASTINT (end
))
3893 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3894 else if (old_pos
> XFASTINT (beg
))
3895 old_pos
= XFASTINT (beg
);
3898 /* We return the length of the encoded text. */
3899 return make_number (encoded_length
);
3902 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3904 doc
: /* Base64-encode STRING and return the result.
3905 Optional second argument NO-LINE-BREAK means do not break long lines
3906 into shorter lines. */)
3907 (string
, no_line_break
)
3908 Lisp_Object string
, no_line_break
;
3910 int allength
, length
, encoded_length
;
3912 Lisp_Object encoded_string
;
3915 CHECK_STRING (string
);
3917 /* We need to allocate enough room for encoding the text.
3918 We need 33 1/3% more space, plus a newline every 76
3919 characters, and then we round up. */
3920 length
= SBYTES (string
);
3921 allength
= length
+ length
/3 + 1;
3922 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3924 /* We need to allocate enough room for decoding the text. */
3925 SAFE_ALLOCA (encoded
, char *, allength
);
3927 encoded_length
= base64_encode_1 (SDATA (string
),
3928 encoded
, length
, NILP (no_line_break
),
3929 STRING_MULTIBYTE (string
));
3930 if (encoded_length
> allength
)
3933 if (encoded_length
< 0)
3935 /* The encoding wasn't possible. */
3937 error ("Multibyte character in data for base64 encoding");
3940 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3943 return encoded_string
;
3947 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3954 int counter
= 0, i
= 0;
3964 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3972 /* Wrap line every 76 characters. */
3976 if (counter
< MIME_LINE_LENGTH
/ 4)
3985 /* Process first byte of a triplet. */
3987 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3988 value
= (0x03 & c
) << 4;
3990 /* Process second byte of a triplet. */
3994 *e
++ = base64_value_to_char
[value
];
4002 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4010 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
4011 value
= (0x0f & c
) << 2;
4013 /* Process third byte of a triplet. */
4017 *e
++ = base64_value_to_char
[value
];
4024 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
4032 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
4033 *e
++ = base64_value_to_char
[0x3f & c
];
4040 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
4042 doc
: /* Base64-decode the region between BEG and END.
4043 Return the length of the decoded text.
4044 If the region can't be decoded, signal an error and don't modify the buffer. */)
4046 Lisp_Object beg
, end
;
4048 int ibeg
, iend
, length
, allength
;
4053 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
4056 validate_region (&beg
, &end
);
4058 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
4059 iend
= CHAR_TO_BYTE (XFASTINT (end
));
4061 length
= iend
- ibeg
;
4063 /* We need to allocate enough room for decoding the text. If we are
4064 working on a multibyte buffer, each decoded code may occupy at
4066 allength
= multibyte
? length
* 2 : length
;
4067 SAFE_ALLOCA (decoded
, char *, allength
);
4069 move_gap_both (XFASTINT (beg
), ibeg
);
4070 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
4071 multibyte
, &inserted_chars
);
4072 if (decoded_length
> allength
)
4075 if (decoded_length
< 0)
4077 /* The decoding wasn't possible. */
4079 error ("Invalid base64 data");
4082 /* Now we have decoded the region, so we insert the new contents
4083 and delete the old. (Insert first in order to preserve markers.) */
4084 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
4085 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
4088 /* Delete the original text. */
4089 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
4090 iend
+ decoded_length
, 1);
4092 /* If point was outside of the region, restore it exactly; else just
4093 move to the beginning of the region. */
4094 if (old_pos
>= XFASTINT (end
))
4095 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
4096 else if (old_pos
> XFASTINT (beg
))
4097 old_pos
= XFASTINT (beg
);
4098 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
4100 return make_number (inserted_chars
);
4103 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
4105 doc
: /* Base64-decode STRING and return the result. */)
4110 int length
, decoded_length
;
4111 Lisp_Object decoded_string
;
4114 CHECK_STRING (string
);
4116 length
= SBYTES (string
);
4117 /* We need to allocate enough room for decoding the text. */
4118 SAFE_ALLOCA (decoded
, char *, length
);
4120 /* The decoded result should be unibyte. */
4121 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
4123 if (decoded_length
> length
)
4125 else if (decoded_length
>= 0)
4126 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
4128 decoded_string
= Qnil
;
4131 if (!STRINGP (decoded_string
))
4132 error ("Invalid base64 data");
4134 return decoded_string
;
4137 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
4138 MULTIBYTE is nonzero, the decoded result should be in multibyte
4139 form. If NCHARS_RETRUN is not NULL, store the number of produced
4140 characters in *NCHARS_RETURN. */
4143 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
4153 unsigned long value
;
4158 /* Process first byte of a quadruplet. */
4160 READ_QUADRUPLET_BYTE (e
-to
);
4164 value
= base64_char_to_value
[c
] << 18;
4166 /* Process second byte of a quadruplet. */
4168 READ_QUADRUPLET_BYTE (-1);
4172 value
|= base64_char_to_value
[c
] << 12;
4174 c
= (unsigned char) (value
>> 16);
4176 e
+= CHAR_STRING (c
, e
);
4181 /* Process third byte of a quadruplet. */
4183 READ_QUADRUPLET_BYTE (-1);
4187 READ_QUADRUPLET_BYTE (-1);
4196 value
|= base64_char_to_value
[c
] << 6;
4198 c
= (unsigned char) (0xff & value
>> 8);
4200 e
+= CHAR_STRING (c
, e
);
4205 /* Process fourth byte of a quadruplet. */
4207 READ_QUADRUPLET_BYTE (-1);
4214 value
|= base64_char_to_value
[c
];
4216 c
= (unsigned char) (0xff & value
);
4218 e
+= CHAR_STRING (c
, e
);
4227 /***********************************************************************
4229 ***** Hash Tables *****
4231 ***********************************************************************/
4233 /* Implemented by gerd@gnu.org. This hash table implementation was
4234 inspired by CMUCL hash tables. */
4238 1. For small tables, association lists are probably faster than
4239 hash tables because they have lower overhead.
4241 For uses of hash tables where the O(1) behavior of table
4242 operations is not a requirement, it might therefore be a good idea
4243 not to hash. Instead, we could just do a linear search in the
4244 key_and_value vector of the hash table. This could be done
4245 if a `:linear-search t' argument is given to make-hash-table. */
4248 /* The list of all weak hash tables. Don't staticpro this one. */
4250 Lisp_Object Vweak_hash_tables
;
4252 /* Various symbols. */
4254 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4255 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4256 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4258 /* Function prototypes. */
4260 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4261 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4262 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4263 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4264 Lisp_Object
, unsigned));
4265 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4266 Lisp_Object
, unsigned));
4267 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4268 unsigned, Lisp_Object
, unsigned));
4269 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4270 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4271 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4272 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4274 static unsigned sxhash_string
P_ ((unsigned char *, int));
4275 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4276 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4277 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4278 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4282 /***********************************************************************
4284 ***********************************************************************/
4286 /* If OBJ is a Lisp hash table, return a pointer to its struct
4287 Lisp_Hash_Table. Otherwise, signal an error. */
4289 static struct Lisp_Hash_Table
*
4290 check_hash_table (obj
)
4293 CHECK_HASH_TABLE (obj
);
4294 return XHASH_TABLE (obj
);
4298 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4302 next_almost_prime (n
)
4315 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4316 which USED[I] is non-zero. If found at index I in ARGS, set
4317 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4318 -1. This function is used to extract a keyword/argument pair from
4319 a DEFUN parameter list. */
4322 get_key_arg (key
, nargs
, args
, used
)
4330 for (i
= 0; i
< nargs
- 1; ++i
)
4331 if (!used
[i
] && EQ (args
[i
], key
))
4346 /* Return a Lisp vector which has the same contents as VEC but has
4347 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4348 vector that are not copied from VEC are set to INIT. */
4351 larger_vector (vec
, new_size
, init
)
4356 struct Lisp_Vector
*v
;
4359 xassert (VECTORP (vec
));
4360 old_size
= XVECTOR (vec
)->size
;
4361 xassert (new_size
>= old_size
);
4363 v
= allocate_vector (new_size
);
4364 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4365 old_size
* sizeof *v
->contents
);
4366 for (i
= old_size
; i
< new_size
; ++i
)
4367 v
->contents
[i
] = init
;
4368 XSETVECTOR (vec
, v
);
4373 /***********************************************************************
4375 ***********************************************************************/
4377 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4378 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4379 KEY2 are the same. */
4382 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4383 struct Lisp_Hash_Table
*h
;
4384 Lisp_Object key1
, key2
;
4385 unsigned hash1
, hash2
;
4387 return (FLOATP (key1
)
4389 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4393 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4394 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4395 KEY2 are the same. */
4398 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4399 struct Lisp_Hash_Table
*h
;
4400 Lisp_Object key1
, key2
;
4401 unsigned hash1
, hash2
;
4403 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4407 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4408 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4409 if KEY1 and KEY2 are the same. */
4412 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4413 struct Lisp_Hash_Table
*h
;
4414 Lisp_Object key1
, key2
;
4415 unsigned hash1
, hash2
;
4419 Lisp_Object args
[3];
4421 args
[0] = h
->user_cmp_function
;
4424 return !NILP (Ffuncall (3, args
));
4431 /* Value is a hash code for KEY for use in hash table H which uses
4432 `eq' to compare keys. The hash code returned is guaranteed to fit
4433 in a Lisp integer. */
4437 struct Lisp_Hash_Table
*h
;
4440 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4441 xassert ((hash
& ~INTMASK
) == 0);
4446 /* Value is a hash code for KEY for use in hash table H which uses
4447 `eql' to compare keys. The hash code returned is guaranteed to fit
4448 in a Lisp integer. */
4452 struct Lisp_Hash_Table
*h
;
4457 hash
= sxhash (key
, 0);
4459 hash
= XUINT (key
) ^ XGCTYPE (key
);
4460 xassert ((hash
& ~INTMASK
) == 0);
4465 /* Value is a hash code for KEY for use in hash table H which uses
4466 `equal' to compare keys. The hash code returned is guaranteed to fit
4467 in a Lisp integer. */
4470 hashfn_equal (h
, key
)
4471 struct Lisp_Hash_Table
*h
;
4474 unsigned hash
= sxhash (key
, 0);
4475 xassert ((hash
& ~INTMASK
) == 0);
4480 /* Value is a hash code for KEY for use in hash table H which uses as
4481 user-defined function to compare keys. The hash code returned is
4482 guaranteed to fit in a Lisp integer. */
4485 hashfn_user_defined (h
, key
)
4486 struct Lisp_Hash_Table
*h
;
4489 Lisp_Object args
[2], hash
;
4491 args
[0] = h
->user_hash_function
;
4493 hash
= Ffuncall (2, args
);
4494 if (!INTEGERP (hash
))
4495 signal_error ("Invalid hash code returned from user-supplied hash function", hash
);
4496 return XUINT (hash
);
4500 /* Create and initialize a new hash table.
4502 TEST specifies the test the hash table will use to compare keys.
4503 It must be either one of the predefined tests `eq', `eql' or
4504 `equal' or a symbol denoting a user-defined test named TEST with
4505 test and hash functions USER_TEST and USER_HASH.
4507 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4509 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4510 new size when it becomes full is computed by adding REHASH_SIZE to
4511 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4512 table's new size is computed by multiplying its old size with
4515 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4516 be resized when the ratio of (number of entries in the table) /
4517 (table size) is >= REHASH_THRESHOLD.
4519 WEAK specifies the weakness of the table. If non-nil, it must be
4520 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4523 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4524 user_test
, user_hash
)
4525 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4526 Lisp_Object user_test
, user_hash
;
4528 struct Lisp_Hash_Table
*h
;
4530 int index_size
, i
, sz
;
4532 /* Preconditions. */
4533 xassert (SYMBOLP (test
));
4534 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4535 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4536 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4537 xassert (FLOATP (rehash_threshold
)
4538 && XFLOATINT (rehash_threshold
) > 0
4539 && XFLOATINT (rehash_threshold
) <= 1.0);
4541 if (XFASTINT (size
) == 0)
4542 size
= make_number (1);
4544 /* Allocate a table and initialize it. */
4545 h
= allocate_hash_table ();
4547 /* Initialize hash table slots. */
4548 sz
= XFASTINT (size
);
4551 if (EQ (test
, Qeql
))
4553 h
->cmpfn
= cmpfn_eql
;
4554 h
->hashfn
= hashfn_eql
;
4556 else if (EQ (test
, Qeq
))
4559 h
->hashfn
= hashfn_eq
;
4561 else if (EQ (test
, Qequal
))
4563 h
->cmpfn
= cmpfn_equal
;
4564 h
->hashfn
= hashfn_equal
;
4568 h
->user_cmp_function
= user_test
;
4569 h
->user_hash_function
= user_hash
;
4570 h
->cmpfn
= cmpfn_user_defined
;
4571 h
->hashfn
= hashfn_user_defined
;
4575 h
->rehash_threshold
= rehash_threshold
;
4576 h
->rehash_size
= rehash_size
;
4577 h
->count
= make_number (0);
4578 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4579 h
->hash
= Fmake_vector (size
, Qnil
);
4580 h
->next
= Fmake_vector (size
, Qnil
);
4581 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4582 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4583 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4585 /* Set up the free list. */
4586 for (i
= 0; i
< sz
- 1; ++i
)
4587 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4588 h
->next_free
= make_number (0);
4590 XSET_HASH_TABLE (table
, h
);
4591 xassert (HASH_TABLE_P (table
));
4592 xassert (XHASH_TABLE (table
) == h
);
4594 /* Maybe add this hash table to the list of all weak hash tables. */
4596 h
->next_weak
= Qnil
;
4599 h
->next_weak
= Vweak_hash_tables
;
4600 Vweak_hash_tables
= table
;
4607 /* Return a copy of hash table H1. Keys and values are not copied,
4608 only the table itself is. */
4611 copy_hash_table (h1
)
4612 struct Lisp_Hash_Table
*h1
;
4615 struct Lisp_Hash_Table
*h2
;
4616 struct Lisp_Vector
*next
;
4618 h2
= allocate_hash_table ();
4619 next
= h2
->vec_next
;
4620 bcopy (h1
, h2
, sizeof *h2
);
4621 h2
->vec_next
= next
;
4622 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4623 h2
->hash
= Fcopy_sequence (h1
->hash
);
4624 h2
->next
= Fcopy_sequence (h1
->next
);
4625 h2
->index
= Fcopy_sequence (h1
->index
);
4626 XSET_HASH_TABLE (table
, h2
);
4628 /* Maybe add this hash table to the list of all weak hash tables. */
4629 if (!NILP (h2
->weak
))
4631 h2
->next_weak
= Vweak_hash_tables
;
4632 Vweak_hash_tables
= table
;
4639 /* Resize hash table H if it's too full. If H cannot be resized
4640 because it's already too large, throw an error. */
4643 maybe_resize_hash_table (h
)
4644 struct Lisp_Hash_Table
*h
;
4646 if (NILP (h
->next_free
))
4648 int old_size
= HASH_TABLE_SIZE (h
);
4649 int i
, new_size
, index_size
;
4651 if (INTEGERP (h
->rehash_size
))
4652 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4654 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4655 new_size
= max (old_size
+ 1, new_size
);
4656 index_size
= next_almost_prime ((int)
4658 / XFLOATINT (h
->rehash_threshold
)));
4659 if (max (index_size
, 2 * new_size
) > MOST_POSITIVE_FIXNUM
)
4660 error ("Hash table too large to resize");
4662 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4663 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4664 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4665 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4667 /* Update the free list. Do it so that new entries are added at
4668 the end of the free list. This makes some operations like
4670 for (i
= old_size
; i
< new_size
- 1; ++i
)
4671 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4673 if (!NILP (h
->next_free
))
4675 Lisp_Object last
, next
;
4677 last
= h
->next_free
;
4678 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4682 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4685 XSETFASTINT (h
->next_free
, old_size
);
4688 for (i
= 0; i
< old_size
; ++i
)
4689 if (!NILP (HASH_HASH (h
, i
)))
4691 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4692 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4693 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4694 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4700 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4701 the hash code of KEY. Value is the index of the entry in H
4702 matching KEY, or -1 if not found. */
4705 hash_lookup (h
, key
, hash
)
4706 struct Lisp_Hash_Table
*h
;
4711 int start_of_bucket
;
4714 hash_code
= h
->hashfn (h
, key
);
4718 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4719 idx
= HASH_INDEX (h
, start_of_bucket
);
4721 /* We need not gcpro idx since it's either an integer or nil. */
4724 int i
= XFASTINT (idx
);
4725 if (EQ (key
, HASH_KEY (h
, i
))
4727 && h
->cmpfn (h
, key
, hash_code
,
4728 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4730 idx
= HASH_NEXT (h
, i
);
4733 return NILP (idx
) ? -1 : XFASTINT (idx
);
4737 /* Put an entry into hash table H that associates KEY with VALUE.
4738 HASH is a previously computed hash code of KEY.
4739 Value is the index of the entry in H matching KEY. */
4742 hash_put (h
, key
, value
, hash
)
4743 struct Lisp_Hash_Table
*h
;
4744 Lisp_Object key
, value
;
4747 int start_of_bucket
, i
;
4749 xassert ((hash
& ~INTMASK
) == 0);
4751 /* Increment count after resizing because resizing may fail. */
4752 maybe_resize_hash_table (h
);
4753 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4755 /* Store key/value in the key_and_value vector. */
4756 i
= XFASTINT (h
->next_free
);
4757 h
->next_free
= HASH_NEXT (h
, i
);
4758 HASH_KEY (h
, i
) = key
;
4759 HASH_VALUE (h
, i
) = value
;
4761 /* Remember its hash code. */
4762 HASH_HASH (h
, i
) = make_number (hash
);
4764 /* Add new entry to its collision chain. */
4765 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4766 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4767 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4772 /* Remove the entry matching KEY from hash table H, if there is one. */
4775 hash_remove (h
, key
)
4776 struct Lisp_Hash_Table
*h
;
4780 int start_of_bucket
;
4781 Lisp_Object idx
, prev
;
4783 hash_code
= h
->hashfn (h
, key
);
4784 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4785 idx
= HASH_INDEX (h
, start_of_bucket
);
4788 /* We need not gcpro idx, prev since they're either integers or nil. */
4791 int i
= XFASTINT (idx
);
4793 if (EQ (key
, HASH_KEY (h
, i
))
4795 && h
->cmpfn (h
, key
, hash_code
,
4796 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4798 /* Take entry out of collision chain. */
4800 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4802 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4804 /* Clear slots in key_and_value and add the slots to
4806 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4807 HASH_NEXT (h
, i
) = h
->next_free
;
4808 h
->next_free
= make_number (i
);
4809 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4810 xassert (XINT (h
->count
) >= 0);
4816 idx
= HASH_NEXT (h
, i
);
4822 /* Clear hash table H. */
4826 struct Lisp_Hash_Table
*h
;
4828 if (XFASTINT (h
->count
) > 0)
4830 int i
, size
= HASH_TABLE_SIZE (h
);
4832 for (i
= 0; i
< size
; ++i
)
4834 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4835 HASH_KEY (h
, i
) = Qnil
;
4836 HASH_VALUE (h
, i
) = Qnil
;
4837 HASH_HASH (h
, i
) = Qnil
;
4840 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4841 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4843 h
->next_free
= make_number (0);
4844 h
->count
= make_number (0);
4850 /************************************************************************
4852 ************************************************************************/
4854 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4855 entries from the table that don't survive the current GC.
4856 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4857 non-zero if anything was marked. */
4860 sweep_weak_table (h
, remove_entries_p
)
4861 struct Lisp_Hash_Table
*h
;
4862 int remove_entries_p
;
4864 int bucket
, n
, marked
;
4866 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4869 for (bucket
= 0; bucket
< n
; ++bucket
)
4871 Lisp_Object idx
, next
, prev
;
4873 /* Follow collision chain, removing entries that
4874 don't survive this garbage collection. */
4876 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4878 int i
= XFASTINT (idx
);
4879 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4880 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4883 if (EQ (h
->weak
, Qkey
))
4884 remove_p
= !key_known_to_survive_p
;
4885 else if (EQ (h
->weak
, Qvalue
))
4886 remove_p
= !value_known_to_survive_p
;
4887 else if (EQ (h
->weak
, Qkey_or_value
))
4888 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4889 else if (EQ (h
->weak
, Qkey_and_value
))
4890 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4894 next
= HASH_NEXT (h
, i
);
4896 if (remove_entries_p
)
4900 /* Take out of collision chain. */
4902 HASH_INDEX (h
, bucket
) = next
;
4904 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4906 /* Add to free list. */
4907 HASH_NEXT (h
, i
) = h
->next_free
;
4910 /* Clear key, value, and hash. */
4911 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4912 HASH_HASH (h
, i
) = Qnil
;
4914 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4925 /* Make sure key and value survive. */
4926 if (!key_known_to_survive_p
)
4928 mark_object (HASH_KEY (h
, i
));
4932 if (!value_known_to_survive_p
)
4934 mark_object (HASH_VALUE (h
, i
));
4945 /* Remove elements from weak hash tables that don't survive the
4946 current garbage collection. Remove weak tables that don't survive
4947 from Vweak_hash_tables. Called from gc_sweep. */
4950 sweep_weak_hash_tables ()
4952 Lisp_Object table
, used
, next
;
4953 struct Lisp_Hash_Table
*h
;
4956 /* Mark all keys and values that are in use. Keep on marking until
4957 there is no more change. This is necessary for cases like
4958 value-weak table A containing an entry X -> Y, where Y is used in a
4959 key-weak table B, Z -> Y. If B comes after A in the list of weak
4960 tables, X -> Y might be removed from A, although when looking at B
4961 one finds that it shouldn't. */
4965 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4967 h
= XHASH_TABLE (table
);
4968 if (h
->size
& ARRAY_MARK_FLAG
)
4969 marked
|= sweep_weak_table (h
, 0);
4974 /* Remove tables and entries that aren't used. */
4975 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4977 h
= XHASH_TABLE (table
);
4978 next
= h
->next_weak
;
4980 if (h
->size
& ARRAY_MARK_FLAG
)
4982 /* TABLE is marked as used. Sweep its contents. */
4983 if (XFASTINT (h
->count
) > 0)
4984 sweep_weak_table (h
, 1);
4986 /* Add table to the list of used weak hash tables. */
4987 h
->next_weak
= used
;
4992 Vweak_hash_tables
= used
;
4997 /***********************************************************************
4998 Hash Code Computation
4999 ***********************************************************************/
5001 /* Maximum depth up to which to dive into Lisp structures. */
5003 #define SXHASH_MAX_DEPTH 3
5005 /* Maximum length up to which to take list and vector elements into
5008 #define SXHASH_MAX_LEN 7
5010 /* Combine two integers X and Y for hashing. */
5012 #define SXHASH_COMBINE(X, Y) \
5013 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
5017 /* Return a hash for string PTR which has length LEN. The hash
5018 code returned is guaranteed to fit in a Lisp integer. */
5021 sxhash_string (ptr
, len
)
5025 unsigned char *p
= ptr
;
5026 unsigned char *end
= p
+ len
;
5035 hash
= ((hash
<< 4) + (hash
>> 28) + c
);
5038 return hash
& INTMASK
;
5042 /* Return a hash for list LIST. DEPTH is the current depth in the
5043 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
5046 sxhash_list (list
, depth
)
5053 if (depth
< SXHASH_MAX_DEPTH
)
5055 CONSP (list
) && i
< SXHASH_MAX_LEN
;
5056 list
= XCDR (list
), ++i
)
5058 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
5059 hash
= SXHASH_COMBINE (hash
, hash2
);
5064 unsigned hash2
= sxhash (list
, depth
+ 1);
5065 hash
= SXHASH_COMBINE (hash
, hash2
);
5072 /* Return a hash for vector VECTOR. DEPTH is the current depth in
5073 the Lisp structure. */
5076 sxhash_vector (vec
, depth
)
5080 unsigned hash
= XVECTOR (vec
)->size
;
5083 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
5084 for (i
= 0; i
< n
; ++i
)
5086 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
5087 hash
= SXHASH_COMBINE (hash
, hash2
);
5094 /* Return a hash for bool-vector VECTOR. */
5097 sxhash_bool_vector (vec
)
5100 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
5103 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
5104 for (i
= 0; i
< n
; ++i
)
5105 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
5111 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
5112 structure. Value is an unsigned integer clipped to INTMASK. */
5121 if (depth
> SXHASH_MAX_DEPTH
)
5124 switch (XTYPE (obj
))
5135 obj
= SYMBOL_NAME (obj
);
5139 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
5142 /* This can be everything from a vector to an overlay. */
5143 case Lisp_Vectorlike
:
5145 /* According to the CL HyperSpec, two arrays are equal only if
5146 they are `eq', except for strings and bit-vectors. In
5147 Emacs, this works differently. We have to compare element
5149 hash
= sxhash_vector (obj
, depth
);
5150 else if (BOOL_VECTOR_P (obj
))
5151 hash
= sxhash_bool_vector (obj
);
5153 /* Others are `equal' if they are `eq', so let's take their
5159 hash
= sxhash_list (obj
, depth
);
5164 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
5165 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
5166 for (hash
= 0; p
< e
; ++p
)
5167 hash
= SXHASH_COMBINE (hash
, *p
);
5175 return hash
& INTMASK
;
5180 /***********************************************************************
5182 ***********************************************************************/
5185 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
5186 doc
: /* Compute a hash code for OBJ and return it as integer. */)
5190 unsigned hash
= sxhash (obj
, 0);;
5191 return make_number (hash
);
5195 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5196 doc
: /* Create and return a new hash table.
5198 Arguments are specified as keyword/argument pairs. The following
5199 arguments are defined:
5201 :test TEST -- TEST must be a symbol that specifies how to compare
5202 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5203 `equal'. User-supplied test and hash functions can be specified via
5204 `define-hash-table-test'.
5206 :size SIZE -- A hint as to how many elements will be put in the table.
5209 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5210 fills up. If REHASH-SIZE is an integer, add that many space. If it
5211 is a float, it must be > 1.0, and the new size is computed by
5212 multiplying the old size with that factor. Default is 1.5.
5214 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5215 Resize the hash table when ratio of the number of entries in the
5216 table. Default is 0.8.
5218 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5219 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5220 returned is a weak table. Key/value pairs are removed from a weak
5221 hash table when there are no non-weak references pointing to their
5222 key, value, one of key or value, or both key and value, depending on
5223 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5226 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5231 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5232 Lisp_Object user_test
, user_hash
;
5236 /* The vector `used' is used to keep track of arguments that
5237 have been consumed. */
5238 used
= (char *) alloca (nargs
* sizeof *used
);
5239 bzero (used
, nargs
* sizeof *used
);
5241 /* See if there's a `:test TEST' among the arguments. */
5242 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5243 test
= i
< 0 ? Qeql
: args
[i
];
5244 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5246 /* See if it is a user-defined test. */
5249 prop
= Fget (test
, Qhash_table_test
);
5250 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5251 signal_error ("Invalid hash table test", test
);
5252 user_test
= XCAR (prop
);
5253 user_hash
= XCAR (XCDR (prop
));
5256 user_test
= user_hash
= Qnil
;
5258 /* See if there's a `:size SIZE' argument. */
5259 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5260 size
= i
< 0 ? Qnil
: args
[i
];
5262 size
= make_number (DEFAULT_HASH_SIZE
);
5263 else if (!INTEGERP (size
) || XINT (size
) < 0)
5264 signal_error ("Invalid hash table size", size
);
5266 /* Look for `:rehash-size SIZE'. */
5267 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5268 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5269 if (!NUMBERP (rehash_size
)
5270 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5271 || XFLOATINT (rehash_size
) <= 1.0)
5272 signal_error ("Invalid hash table rehash size", rehash_size
);
5274 /* Look for `:rehash-threshold THRESHOLD'. */
5275 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5276 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5277 if (!FLOATP (rehash_threshold
)
5278 || XFLOATINT (rehash_threshold
) <= 0.0
5279 || XFLOATINT (rehash_threshold
) > 1.0)
5280 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
5282 /* Look for `:weakness WEAK'. */
5283 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5284 weak
= i
< 0 ? Qnil
: args
[i
];
5286 weak
= Qkey_and_value
;
5289 && !EQ (weak
, Qvalue
)
5290 && !EQ (weak
, Qkey_or_value
)
5291 && !EQ (weak
, Qkey_and_value
))
5292 signal_error ("Invalid hash table weakness", weak
);
5294 /* Now, all args should have been used up, or there's a problem. */
5295 for (i
= 0; i
< nargs
; ++i
)
5297 signal_error ("Invalid argument list", args
[i
]);
5299 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5300 user_test
, user_hash
);
5304 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5305 doc
: /* Return a copy of hash table TABLE. */)
5309 return copy_hash_table (check_hash_table (table
));
5313 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5314 doc
: /* Return the number of elements in TABLE. */)
5318 return check_hash_table (table
)->count
;
5322 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5323 Shash_table_rehash_size
, 1, 1, 0,
5324 doc
: /* Return the current rehash size of TABLE. */)
5328 return check_hash_table (table
)->rehash_size
;
5332 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5333 Shash_table_rehash_threshold
, 1, 1, 0,
5334 doc
: /* Return the current rehash threshold of TABLE. */)
5338 return check_hash_table (table
)->rehash_threshold
;
5342 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5343 doc
: /* Return the size of TABLE.
5344 The size can be used as an argument to `make-hash-table' to create
5345 a hash table than can hold as many elements of TABLE holds
5346 without need for resizing. */)
5350 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5351 return make_number (HASH_TABLE_SIZE (h
));
5355 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5356 doc
: /* Return the test TABLE uses. */)
5360 return check_hash_table (table
)->test
;
5364 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5366 doc
: /* Return the weakness of TABLE. */)
5370 return check_hash_table (table
)->weak
;
5374 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5375 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5379 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5383 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5384 doc
: /* Clear hash table TABLE. */)
5388 hash_clear (check_hash_table (table
));
5393 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5394 doc
: /* Look up KEY in TABLE and return its associated value.
5395 If KEY is not found, return DFLT which defaults to nil. */)
5397 Lisp_Object key
, table
, dflt
;
5399 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5400 int i
= hash_lookup (h
, key
, NULL
);
5401 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5405 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5406 doc
: /* Associate KEY with VALUE in hash table TABLE.
5407 If KEY is already present in table, replace its current value with
5410 Lisp_Object key
, value
, table
;
5412 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5416 i
= hash_lookup (h
, key
, &hash
);
5418 HASH_VALUE (h
, i
) = value
;
5420 hash_put (h
, key
, value
, hash
);
5426 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5427 doc
: /* Remove KEY from TABLE. */)
5429 Lisp_Object key
, table
;
5431 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5432 hash_remove (h
, key
);
5437 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5438 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5439 FUNCTION is called with two arguments, KEY and VALUE. */)
5441 Lisp_Object function
, table
;
5443 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5444 Lisp_Object args
[3];
5447 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5448 if (!NILP (HASH_HASH (h
, i
)))
5451 args
[1] = HASH_KEY (h
, i
);
5452 args
[2] = HASH_VALUE (h
, i
);
5460 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5461 Sdefine_hash_table_test
, 3, 3, 0,
5462 doc
: /* Define a new hash table test with name NAME, a symbol.
5464 In hash tables created with NAME specified as test, use TEST to
5465 compare keys, and HASH for computing hash codes of keys.
5467 TEST must be a function taking two arguments and returning non-nil if
5468 both arguments are the same. HASH must be a function taking one
5469 argument and return an integer that is the hash code of the argument.
5470 Hash code computation should use the whole value range of integers,
5471 including negative integers. */)
5473 Lisp_Object name
, test
, hash
;
5475 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5480 /************************************************************************
5482 ************************************************************************/
5487 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5488 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5490 A message digest is a cryptographic checksum of a document, and the
5491 algorithm to calculate it is defined in RFC 1321.
5493 The two optional arguments START and END are character positions
5494 specifying for which part of OBJECT the message digest should be
5495 computed. If nil or omitted, the digest is computed for the whole
5498 The MD5 message digest is computed from the result of encoding the
5499 text in a coding system, not directly from the internal Emacs form of
5500 the text. The optional fourth argument CODING-SYSTEM specifies which
5501 coding system to encode the text with. It should be the same coding
5502 system that you used or will use when actually writing the text into a
5505 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5506 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5507 system would be chosen by default for writing this text into a file.
5509 If OBJECT is a string, the most preferred coding system (see the
5510 command `prefer-coding-system') is used.
5512 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5513 guesswork fails. Normally, an error is signaled in such case. */)
5514 (object
, start
, end
, coding_system
, noerror
)
5515 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5517 unsigned char digest
[16];
5518 unsigned char value
[33];
5522 int start_char
= 0, end_char
= 0;
5523 int start_byte
= 0, end_byte
= 0;
5525 register struct buffer
*bp
;
5528 if (STRINGP (object
))
5530 if (NILP (coding_system
))
5532 /* Decide the coding-system to encode the data with. */
5534 if (STRING_MULTIBYTE (object
))
5535 /* use default, we can't guess correct value */
5536 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5538 coding_system
= Qraw_text
;
5541 if (NILP (Fcoding_system_p (coding_system
)))
5543 /* Invalid coding system. */
5545 if (!NILP (noerror
))
5546 coding_system
= Qraw_text
;
5548 xsignal1 (Qcoding_system_error
, coding_system
);
5551 if (STRING_MULTIBYTE (object
))
5552 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5554 size
= SCHARS (object
);
5555 size_byte
= SBYTES (object
);
5559 CHECK_NUMBER (start
);
5561 start_char
= XINT (start
);
5566 start_byte
= string_char_to_byte (object
, start_char
);
5572 end_byte
= size_byte
;
5578 end_char
= XINT (end
);
5583 end_byte
= string_char_to_byte (object
, end_char
);
5586 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5587 args_out_of_range_3 (object
, make_number (start_char
),
5588 make_number (end_char
));
5592 struct buffer
*prev
= current_buffer
;
5594 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
5596 CHECK_BUFFER (object
);
5598 bp
= XBUFFER (object
);
5599 if (bp
!= current_buffer
)
5600 set_buffer_internal (bp
);
5606 CHECK_NUMBER_COERCE_MARKER (start
);
5614 CHECK_NUMBER_COERCE_MARKER (end
);
5619 temp
= b
, b
= e
, e
= temp
;
5621 if (!(BEGV
<= b
&& e
<= ZV
))
5622 args_out_of_range (start
, end
);
5624 if (NILP (coding_system
))
5626 /* Decide the coding-system to encode the data with.
5627 See fileio.c:Fwrite-region */
5629 if (!NILP (Vcoding_system_for_write
))
5630 coding_system
= Vcoding_system_for_write
;
5633 int force_raw_text
= 0;
5635 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5636 if (NILP (coding_system
)
5637 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5639 coding_system
= Qnil
;
5640 if (NILP (current_buffer
->enable_multibyte_characters
))
5644 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5646 /* Check file-coding-system-alist. */
5647 Lisp_Object args
[4], val
;
5649 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5650 args
[3] = Fbuffer_file_name(object
);
5651 val
= Ffind_operation_coding_system (4, args
);
5652 if (CONSP (val
) && !NILP (XCDR (val
)))
5653 coding_system
= XCDR (val
);
5656 if (NILP (coding_system
)
5657 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5659 /* If we still have not decided a coding system, use the
5660 default value of buffer-file-coding-system. */
5661 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5665 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5666 /* Confirm that VAL can surely encode the current region. */
5667 coding_system
= call4 (Vselect_safe_coding_system_function
,
5668 make_number (b
), make_number (e
),
5669 coding_system
, Qnil
);
5672 coding_system
= Qraw_text
;
5675 if (NILP (Fcoding_system_p (coding_system
)))
5677 /* Invalid coding system. */
5679 if (!NILP (noerror
))
5680 coding_system
= Qraw_text
;
5682 xsignal1 (Qcoding_system_error
, coding_system
);
5686 object
= make_buffer_string (b
, e
, 0);
5687 if (prev
!= current_buffer
)
5688 set_buffer_internal (prev
);
5689 /* Discard the unwind protect for recovering the current
5693 if (STRING_MULTIBYTE (object
))
5694 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5697 md5_buffer (SDATA (object
) + start_byte
,
5698 SBYTES (object
) - (size_byte
- end_byte
),
5701 for (i
= 0; i
< 16; i
++)
5702 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5705 return make_string (value
, 32);
5712 /* Hash table stuff. */
5713 Qhash_table_p
= intern ("hash-table-p");
5714 staticpro (&Qhash_table_p
);
5715 Qeq
= intern ("eq");
5717 Qeql
= intern ("eql");
5719 Qequal
= intern ("equal");
5720 staticpro (&Qequal
);
5721 QCtest
= intern (":test");
5722 staticpro (&QCtest
);
5723 QCsize
= intern (":size");
5724 staticpro (&QCsize
);
5725 QCrehash_size
= intern (":rehash-size");
5726 staticpro (&QCrehash_size
);
5727 QCrehash_threshold
= intern (":rehash-threshold");
5728 staticpro (&QCrehash_threshold
);
5729 QCweakness
= intern (":weakness");
5730 staticpro (&QCweakness
);
5731 Qkey
= intern ("key");
5733 Qvalue
= intern ("value");
5734 staticpro (&Qvalue
);
5735 Qhash_table_test
= intern ("hash-table-test");
5736 staticpro (&Qhash_table_test
);
5737 Qkey_or_value
= intern ("key-or-value");
5738 staticpro (&Qkey_or_value
);
5739 Qkey_and_value
= intern ("key-and-value");
5740 staticpro (&Qkey_and_value
);
5743 defsubr (&Smake_hash_table
);
5744 defsubr (&Scopy_hash_table
);
5745 defsubr (&Shash_table_count
);
5746 defsubr (&Shash_table_rehash_size
);
5747 defsubr (&Shash_table_rehash_threshold
);
5748 defsubr (&Shash_table_size
);
5749 defsubr (&Shash_table_test
);
5750 defsubr (&Shash_table_weakness
);
5751 defsubr (&Shash_table_p
);
5752 defsubr (&Sclrhash
);
5753 defsubr (&Sgethash
);
5754 defsubr (&Sputhash
);
5755 defsubr (&Sremhash
);
5756 defsubr (&Smaphash
);
5757 defsubr (&Sdefine_hash_table_test
);
5759 Qstring_lessp
= intern ("string-lessp");
5760 staticpro (&Qstring_lessp
);
5761 Qprovide
= intern ("provide");
5762 staticpro (&Qprovide
);
5763 Qrequire
= intern ("require");
5764 staticpro (&Qrequire
);
5765 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5766 staticpro (&Qyes_or_no_p_history
);
5767 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5768 staticpro (&Qcursor_in_echo_area
);
5769 Qwidget_type
= intern ("widget-type");
5770 staticpro (&Qwidget_type
);
5772 staticpro (&string_char_byte_cache_string
);
5773 string_char_byte_cache_string
= Qnil
;
5775 require_nesting_list
= Qnil
;
5776 staticpro (&require_nesting_list
);
5778 Fset (Qyes_or_no_p_history
, Qnil
);
5780 DEFVAR_LISP ("features", &Vfeatures
,
5781 doc
: /* A list of symbols which are the features of the executing emacs.
5782 Used by `featurep' and `require', and altered by `provide'. */);
5783 Vfeatures
= Fcons (intern ("emacs"), Qnil
);
5784 Qsubfeatures
= intern ("subfeatures");
5785 staticpro (&Qsubfeatures
);
5787 #ifdef HAVE_LANGINFO_CODESET
5788 Qcodeset
= intern ("codeset");
5789 staticpro (&Qcodeset
);
5790 Qdays
= intern ("days");
5792 Qmonths
= intern ("months");
5793 staticpro (&Qmonths
);
5794 Qpaper
= intern ("paper");
5795 staticpro (&Qpaper
);
5796 #endif /* HAVE_LANGINFO_CODESET */
5798 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5799 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5800 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5801 invoked by mouse clicks and mouse menu items. */);
5804 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog
,
5805 doc
: /* *Non-nil means mouse commands use a file dialog to ask for files.
5806 This applies to commands from menus and tool bar buttons. The value of
5807 `use-dialog-box' takes precedence over this variable, so a file dialog is only
5808 used if both `use-dialog-box' and this variable are non-nil. */);
5809 use_file_dialog
= 1;
5811 defsubr (&Sidentity
);
5814 defsubr (&Ssafe_length
);
5815 defsubr (&Sstring_bytes
);
5816 defsubr (&Sstring_equal
);
5817 defsubr (&Scompare_strings
);
5818 defsubr (&Sstring_lessp
);
5821 defsubr (&Svconcat
);
5822 defsubr (&Scopy_sequence
);
5823 defsubr (&Sstring_make_multibyte
);
5824 defsubr (&Sstring_make_unibyte
);
5825 defsubr (&Sstring_as_multibyte
);
5826 defsubr (&Sstring_as_unibyte
);
5827 defsubr (&Sstring_to_multibyte
);
5828 defsubr (&Scopy_alist
);
5829 defsubr (&Ssubstring
);
5830 defsubr (&Ssubstring_no_properties
);
5842 defsubr (&Snreverse
);
5843 defsubr (&Sreverse
);
5845 defsubr (&Splist_get
);
5847 defsubr (&Splist_put
);
5849 defsubr (&Slax_plist_get
);
5850 defsubr (&Slax_plist_put
);
5853 defsubr (&Sequal_including_properties
);
5854 defsubr (&Sfillarray
);
5855 defsubr (&Sclear_string
);
5856 defsubr (&Schar_table_subtype
);
5857 defsubr (&Schar_table_parent
);
5858 defsubr (&Sset_char_table_parent
);
5859 defsubr (&Schar_table_extra_slot
);
5860 defsubr (&Sset_char_table_extra_slot
);
5861 defsubr (&Schar_table_range
);
5862 defsubr (&Sset_char_table_range
);
5863 defsubr (&Sset_char_table_default
);
5864 defsubr (&Soptimize_char_table
);
5865 defsubr (&Smap_char_table
);
5869 defsubr (&Smapconcat
);
5870 defsubr (&Sy_or_n_p
);
5871 defsubr (&Syes_or_no_p
);
5872 defsubr (&Sload_average
);
5873 defsubr (&Sfeaturep
);
5874 defsubr (&Srequire
);
5875 defsubr (&Sprovide
);
5876 defsubr (&Splist_member
);
5877 defsubr (&Swidget_put
);
5878 defsubr (&Swidget_get
);
5879 defsubr (&Swidget_apply
);
5880 defsubr (&Sbase64_encode_region
);
5881 defsubr (&Sbase64_decode_region
);
5882 defsubr (&Sbase64_encode_string
);
5883 defsubr (&Sbase64_decode_string
);
5885 defsubr (&Slocale_info
);
5892 Vweak_hash_tables
= Qnil
;
5895 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5896 (do not change this comment) */