1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
40 #include "intervals.h"
43 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
48 #define NULL (void *)0
52 #define min(a, b) ((a) < (b) ? (a) : (b))
53 #define max(a, b) ((a) > (b) ? (a) : (b))
56 /* Nonzero enables use of dialog boxes for questions
57 asked by mouse commands. */
60 extern int minibuffer_auto_raise
;
61 extern Lisp_Object minibuf_window
;
63 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
64 Lisp_Object Qyes_or_no_p_history
;
65 Lisp_Object Qcursor_in_echo_area
;
66 Lisp_Object Qwidget_type
;
68 extern Lisp_Object Qinput_method_function
;
70 static int internal_equal ();
72 extern long get_random ();
73 extern void seed_random ();
79 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
80 "Return the argument unchanged.")
87 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
88 "Return a pseudo-random number.\n\
89 All integers representable in Lisp are equally likely.\n\
90 On most systems, this is 28 bits' worth.\n\
91 With positive integer argument N, return random number in interval [0,N).\n\
92 With argument t, set the random number seed from the current time and pid.")
97 Lisp_Object lispy_val
;
98 unsigned long denominator
;
101 seed_random (getpid () + time (NULL
));
102 if (NATNUMP (n
) && XFASTINT (n
) != 0)
104 /* Try to take our random number from the higher bits of VAL,
105 not the lower, since (says Gentzel) the low bits of `random'
106 are less random than the higher ones. We do this by using the
107 quotient rather than the remainder. At the high end of the RNG
108 it's possible to get a quotient larger than n; discarding
109 these values eliminates the bias that would otherwise appear
110 when using a large n. */
111 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
113 val
= get_random () / denominator
;
114 while (val
>= XFASTINT (n
));
118 XSETINT (lispy_val
, val
);
122 /* Random data-structure functions */
124 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
125 "Return the length of vector, list or string SEQUENCE.\n\
126 A byte-code function object is also allowed.\n\
127 If the string contains multibyte characters, this is not the necessarily\n\
128 the number of bytes in the string; it is the number of characters.\n\
129 To get the number of bytes, use `string-bytes'")
131 register Lisp_Object sequence
;
133 register Lisp_Object tail
, val
;
137 if (STRINGP (sequence
))
138 XSETFASTINT (val
, XSTRING (sequence
)->size
);
139 else if (VECTORP (sequence
))
140 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
141 else if (CHAR_TABLE_P (sequence
))
142 XSETFASTINT (val
, MAX_CHAR
);
143 else if (BOOL_VECTOR_P (sequence
))
144 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
145 else if (COMPILEDP (sequence
))
146 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
147 else if (CONSP (sequence
))
150 while (CONSP (sequence
))
152 sequence
= XCDR (sequence
);
155 if (!CONSP (sequence
))
158 sequence
= XCDR (sequence
);
163 if (!NILP (sequence
))
164 wrong_type_argument (Qlistp
, sequence
);
166 val
= make_number (i
);
168 else if (NILP (sequence
))
169 XSETFASTINT (val
, 0);
172 sequence
= wrong_type_argument (Qsequencep
, sequence
);
178 /* This does not check for quits. That is safe
179 since it must terminate. */
181 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
182 "Return the length of a list, but avoid error or infinite loop.\n\
183 This function never gets an error. If LIST is not really a list,\n\
184 it returns 0. If LIST is circular, it returns a finite value\n\
185 which is at least the number of distinct elements.")
189 Lisp_Object tail
, halftail
, length
;
192 /* halftail is used to detect circular lists. */
194 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
196 if (EQ (tail
, halftail
) && len
!= 0)
200 halftail
= XCDR (halftail
);
203 XSETINT (length
, len
);
207 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
208 "Return the number of bytes in STRING.\n\
209 If STRING is a multibyte string, this is greater than the length of STRING.")
213 CHECK_STRING (string
, 1);
214 return make_number (STRING_BYTES (XSTRING (string
)));
217 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
218 "Return t if two strings have identical contents.\n\
219 Case is significant, but text properties are ignored.\n\
220 Symbols are also allowed; their print names are used instead.")
222 register Lisp_Object s1
, s2
;
225 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
227 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
228 CHECK_STRING (s1
, 0);
229 CHECK_STRING (s2
, 1);
231 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
232 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
233 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
238 DEFUN ("compare-strings", Fcompare_strings
,
239 Scompare_strings
, 6, 7, 0,
240 "Compare the contents of two strings, converting to multibyte if needed.\n\
241 In string STR1, skip the first START1 characters and stop at END1.\n\
242 In string STR2, skip the first START2 characters and stop at END2.\n\
243 END1 and END2 default to the full lengths of the respective strings.\n\
245 Case is significant in this comparison if IGNORE-CASE is nil.\n\
246 Unibyte strings are converted to multibyte for comparison.\n\
248 The value is t if the strings (or specified portions) match.\n\
249 If string STR1 is less, the value is a negative number N;\n\
250 - 1 - N is the number of characters that match at the beginning.\n\
251 If string STR1 is greater, the value is a positive number N;\n\
252 N - 1 is the number of characters that match at the beginning.")
253 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
254 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
256 register int end1_char
, end2_char
;
257 register int i1
, i1_byte
, i2
, i2_byte
;
259 CHECK_STRING (str1
, 0);
260 CHECK_STRING (str2
, 1);
262 start1
= make_number (0);
264 start2
= make_number (0);
265 CHECK_NATNUM (start1
, 2);
266 CHECK_NATNUM (start2
, 3);
268 CHECK_NATNUM (end1
, 4);
270 CHECK_NATNUM (end2
, 4);
275 i1_byte
= string_char_to_byte (str1
, i1
);
276 i2_byte
= string_char_to_byte (str2
, i2
);
278 end1_char
= XSTRING (str1
)->size
;
279 if (! NILP (end1
) && end1_char
> XINT (end1
))
280 end1_char
= XINT (end1
);
282 end2_char
= XSTRING (str2
)->size
;
283 if (! NILP (end2
) && end2_char
> XINT (end2
))
284 end2_char
= XINT (end2
);
286 while (i1
< end1_char
&& i2
< end2_char
)
288 /* When we find a mismatch, we must compare the
289 characters, not just the bytes. */
292 if (STRING_MULTIBYTE (str1
))
293 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
296 c1
= XSTRING (str1
)->data
[i1
++];
297 c1
= unibyte_char_to_multibyte (c1
);
300 if (STRING_MULTIBYTE (str2
))
301 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
304 c2
= XSTRING (str2
)->data
[i2
++];
305 c2
= unibyte_char_to_multibyte (c2
);
311 if (! NILP (ignore_case
))
315 tem
= Fupcase (make_number (c1
));
317 tem
= Fupcase (make_number (c2
));
324 /* Note that I1 has already been incremented
325 past the character that we are comparing;
326 hence we don't add or subtract 1 here. */
328 return make_number (- i1
);
330 return make_number (i1
);
334 return make_number (i1
- XINT (start1
) + 1);
336 return make_number (- i1
+ XINT (start1
) - 1);
341 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
342 "Return t if first arg string is less than second in lexicographic order.\n\
343 Case is significant.\n\
344 Symbols are also allowed; their print names are used instead.")
346 register Lisp_Object s1
, s2
;
349 register int i1
, i1_byte
, i2
, i2_byte
;
352 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
354 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
355 CHECK_STRING (s1
, 0);
356 CHECK_STRING (s2
, 1);
358 i1
= i1_byte
= i2
= i2_byte
= 0;
360 end
= XSTRING (s1
)->size
;
361 if (end
> XSTRING (s2
)->size
)
362 end
= XSTRING (s2
)->size
;
366 /* When we find a mismatch, we must compare the
367 characters, not just the bytes. */
370 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
371 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
374 return c1
< c2
? Qt
: Qnil
;
376 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
379 static Lisp_Object
concat ();
390 return concat (2, args
, Lisp_String
, 0);
392 return concat (2, &s1
, Lisp_String
, 0);
393 #endif /* NO_ARG_ARRAY */
399 Lisp_Object s1
, s2
, s3
;
406 return concat (3, args
, Lisp_String
, 0);
408 return concat (3, &s1
, Lisp_String
, 0);
409 #endif /* NO_ARG_ARRAY */
412 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
413 "Concatenate all the arguments and make the result a list.\n\
414 The result is a list whose elements are the elements of all the arguments.\n\
415 Each argument may be a list, vector or string.\n\
416 The last argument is not copied, just used as the tail of the new list.")
421 return concat (nargs
, args
, Lisp_Cons
, 1);
424 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
425 "Concatenate all the arguments and make the result a string.\n\
426 The result is a string whose elements are the elements of all the arguments.\n\
427 Each argument may be a string or a list or vector of characters (integers).")
432 return concat (nargs
, args
, Lisp_String
, 0);
435 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
436 "Concatenate all the arguments and make the result a vector.\n\
437 The result is a vector whose elements are the elements of all the arguments.\n\
438 Each argument may be a list, vector or string.")
443 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
446 /* Retrun a copy of a sub char table ARG. The elements except for a
447 nested sub char table are not copied. */
449 copy_sub_char_table (arg
)
452 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
455 /* Copy all the contents. */
456 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
457 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
458 /* Recursively copy any sub char-tables in the ordinary slots. */
459 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
460 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
461 XCHAR_TABLE (copy
)->contents
[i
]
462 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
468 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
469 "Return a copy of a list, vector or string.\n\
470 The elements of a list or vector are not copied; they are shared\n\
475 if (NILP (arg
)) return arg
;
477 if (CHAR_TABLE_P (arg
))
482 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
483 /* Copy all the slots, including the extra ones. */
484 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
485 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
486 * sizeof (Lisp_Object
)));
488 /* Recursively copy any sub char tables in the ordinary slots
489 for multibyte characters. */
490 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
491 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
492 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
493 XCHAR_TABLE (copy
)->contents
[i
]
494 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
499 if (BOOL_VECTOR_P (arg
))
503 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
505 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
506 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
511 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
512 arg
= wrong_type_argument (Qsequencep
, arg
);
513 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
516 /* In string STR of length LEN, see if bytes before STR[I] combine
517 with bytes after STR[I] to form a single character. If so, return
518 the number of bytes after STR[I] which combine in this way.
519 Otherwize, return 0. */
522 count_combining (str
, len
, i
)
526 int j
= i
- 1, bytes
;
528 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
530 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
531 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
533 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
534 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
537 /* This structure holds information of an argument of `concat' that is
538 a string and has text properties to be copied. */
541 int argnum
; /* refer to ARGS (arguments of `concat') */
542 int from
; /* refer to ARGS[argnum] (argument string) */
543 int to
; /* refer to VAL (the target string) */
547 concat (nargs
, args
, target_type
, last_special
)
550 enum Lisp_Type target_type
;
554 register Lisp_Object tail
;
555 register Lisp_Object
this;
558 register int result_len
;
559 register int result_len_byte
;
561 Lisp_Object last_tail
;
564 /* When we make a multibyte string, we can't copy text properties
565 while concatinating each string because the length of resulting
566 string can't be decided until we finish the whole concatination.
567 So, we record strings that have text properties to be copied
568 here, and copy the text properties after the concatination. */
569 struct textprop_rec
*textprops
;
570 /* Number of elments in textprops. */
571 int num_textprops
= 0;
573 /* In append, the last arg isn't treated like the others */
574 if (last_special
&& nargs
> 0)
577 last_tail
= args
[nargs
];
582 /* Canonicalize each argument. */
583 for (argnum
= 0; argnum
< nargs
; argnum
++)
586 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
587 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
589 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
593 /* Compute total length in chars of arguments in RESULT_LEN.
594 If desired output is a string, also compute length in bytes
595 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
596 whether the result should be a multibyte string. */
600 for (argnum
= 0; argnum
< nargs
; argnum
++)
604 len
= XFASTINT (Flength (this));
605 if (target_type
== Lisp_String
)
607 /* We must count the number of bytes needed in the string
608 as well as the number of characters. */
614 for (i
= 0; i
< len
; i
++)
616 ch
= XVECTOR (this)->contents
[i
];
618 wrong_type_argument (Qintegerp
, ch
);
619 this_len_byte
= CHAR_BYTES (XINT (ch
));
620 result_len_byte
+= this_len_byte
;
621 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
624 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
625 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
626 else if (CONSP (this))
627 for (; CONSP (this); this = XCDR (this))
631 wrong_type_argument (Qintegerp
, ch
);
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
+= STRING_BYTES (XSTRING (this));
645 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
646 XSTRING (this)->size
);
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;
679 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
681 for (argnum
= 0; argnum
< nargs
; argnum
++)
685 register unsigned int thisindex
= 0;
686 register unsigned int thisindex_byte
= 0;
690 thislen
= Flength (this), thisleni
= XINT (thislen
);
692 /* Between strings of the same kind, copy fast. */
693 if (STRINGP (this) && STRINGP (val
)
694 && STRING_MULTIBYTE (this) == some_multibyte
)
696 int thislen_byte
= STRING_BYTES (XSTRING (this));
699 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
700 STRING_BYTES (XSTRING (this)));
701 combined
= (some_multibyte
&& toindex_byte
> 0
702 ? count_combining (XSTRING (val
)->data
,
703 toindex_byte
+ thislen_byte
,
706 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
708 textprops
[num_textprops
].argnum
= argnum
;
709 /* We ignore text properties on characters being combined. */
710 textprops
[num_textprops
].from
= combined
;
711 textprops
[num_textprops
++].to
= toindex
;
713 toindex_byte
+= thislen_byte
;
714 toindex
+= thisleni
- combined
;
715 XSTRING (val
)->size
-= combined
;
717 /* Copy a single-byte string to a multibyte string. */
718 else if (STRINGP (this) && STRINGP (val
))
720 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
722 textprops
[num_textprops
].argnum
= argnum
;
723 textprops
[num_textprops
].from
= 0;
724 textprops
[num_textprops
++].to
= toindex
;
726 toindex_byte
+= copy_text (XSTRING (this)->data
,
727 XSTRING (val
)->data
+ toindex_byte
,
728 XSTRING (this)->size
, 0, 1);
732 /* Copy element by element. */
735 register Lisp_Object elt
;
737 /* Fetch next element of `this' arg into `elt', or break if
738 `this' is exhausted. */
739 if (NILP (this)) break;
741 elt
= XCAR (this), this = XCDR (this);
742 else if (thisindex
>= thisleni
)
744 else if (STRINGP (this))
747 if (STRING_MULTIBYTE (this))
749 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
752 XSETFASTINT (elt
, c
);
756 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
758 && (XINT (elt
) >= 0240
759 || (XINT (elt
) >= 0200
760 && ! NILP (Vnonascii_translation_table
)))
761 && XINT (elt
) < 0400)
763 c
= unibyte_char_to_multibyte (XINT (elt
));
768 else if (BOOL_VECTOR_P (this))
771 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
772 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
779 elt
= XVECTOR (this)->contents
[thisindex
++];
781 /* Store this element into the result. */
788 else if (VECTORP (val
))
789 XVECTOR (val
)->contents
[toindex
++] = elt
;
792 CHECK_NUMBER (elt
, 0);
793 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
797 += CHAR_STRING (XINT (elt
),
798 XSTRING (val
)->data
+ toindex_byte
);
800 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
803 && count_combining (XSTRING (val
)->data
,
804 toindex_byte
, toindex_byte
- 1))
805 XSTRING (val
)->size
--;
810 /* If we have any multibyte characters,
811 we already decided to make a multibyte string. */
814 /* P exists as a variable
815 to avoid a bug on the Masscomp C compiler. */
816 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
818 toindex_byte
+= CHAR_STRING (c
, p
);
825 XCDR (prev
) = last_tail
;
827 if (num_textprops
> 0)
831 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
833 this = args
[textprops
[argnum
].argnum
];
834 props
= text_property_list (this,
836 make_number (XSTRING (this)->size
),
838 /* If successive arguments have properites, be sure that the
839 value of `composition' property be the copy. */
841 && textprops
[argnum
- 1].argnum
+ 1 == textprops
[argnum
].argnum
)
842 make_composition_value_copy (props
);
843 add_text_properties_from_list (val
, props
,
844 make_number (textprops
[argnum
].to
));
850 static Lisp_Object string_char_byte_cache_string
;
851 static int string_char_byte_cache_charpos
;
852 static int string_char_byte_cache_bytepos
;
855 clear_string_char_byte_cache ()
857 string_char_byte_cache_string
= Qnil
;
860 /* Return the character index corresponding to CHAR_INDEX in STRING. */
863 string_char_to_byte (string
, char_index
)
868 int best_below
, best_below_byte
;
869 int best_above
, best_above_byte
;
871 if (! STRING_MULTIBYTE (string
))
874 best_below
= best_below_byte
= 0;
875 best_above
= XSTRING (string
)->size
;
876 best_above_byte
= STRING_BYTES (XSTRING (string
));
878 if (EQ (string
, string_char_byte_cache_string
))
880 if (string_char_byte_cache_charpos
< char_index
)
882 best_below
= string_char_byte_cache_charpos
;
883 best_below_byte
= string_char_byte_cache_bytepos
;
887 best_above
= string_char_byte_cache_charpos
;
888 best_above_byte
= string_char_byte_cache_bytepos
;
892 if (char_index
- best_below
< best_above
- char_index
)
894 while (best_below
< char_index
)
897 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
898 best_below
, best_below_byte
);
901 i_byte
= best_below_byte
;
905 while (best_above
> char_index
)
907 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
908 unsigned char *pbeg
= pend
- best_above_byte
;
909 unsigned char *p
= pend
- 1;
912 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
913 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
914 if (bytes
== pend
- p
)
915 best_above_byte
-= bytes
;
916 else if (bytes
> pend
- p
)
917 best_above_byte
-= (pend
- p
);
923 i_byte
= best_above_byte
;
926 string_char_byte_cache_bytepos
= i_byte
;
927 string_char_byte_cache_charpos
= i
;
928 string_char_byte_cache_string
= string
;
933 /* Return the character index corresponding to BYTE_INDEX in STRING. */
936 string_byte_to_char (string
, byte_index
)
941 int best_below
, best_below_byte
;
942 int best_above
, best_above_byte
;
944 if (! STRING_MULTIBYTE (string
))
947 best_below
= best_below_byte
= 0;
948 best_above
= XSTRING (string
)->size
;
949 best_above_byte
= STRING_BYTES (XSTRING (string
));
951 if (EQ (string
, string_char_byte_cache_string
))
953 if (string_char_byte_cache_bytepos
< byte_index
)
955 best_below
= string_char_byte_cache_charpos
;
956 best_below_byte
= string_char_byte_cache_bytepos
;
960 best_above
= string_char_byte_cache_charpos
;
961 best_above_byte
= string_char_byte_cache_bytepos
;
965 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
967 while (best_below_byte
< byte_index
)
970 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
971 best_below
, best_below_byte
);
974 i_byte
= best_below_byte
;
978 while (best_above_byte
> byte_index
)
980 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
981 unsigned char *pbeg
= pend
- best_above_byte
;
982 unsigned char *p
= pend
- 1;
985 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
986 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
987 if (bytes
== pend
- p
)
988 best_above_byte
-= bytes
;
989 else if (bytes
> pend
- p
)
990 best_above_byte
-= (pend
- p
);
996 i_byte
= best_above_byte
;
999 string_char_byte_cache_bytepos
= i_byte
;
1000 string_char_byte_cache_charpos
= i
;
1001 string_char_byte_cache_string
= string
;
1006 /* Convert STRING to a multibyte string.
1007 Single-byte characters 0240 through 0377 are converted
1008 by adding nonascii_insert_offset to each. */
1011 string_make_multibyte (string
)
1017 if (STRING_MULTIBYTE (string
))
1020 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1021 XSTRING (string
)->size
);
1022 /* If all the chars are ASCII, they won't need any more bytes
1023 once converted. In that case, we can return STRING itself. */
1024 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1027 buf
= (unsigned char *) alloca (nbytes
);
1028 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1031 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1034 /* Convert STRING to a single-byte string. */
1037 string_make_unibyte (string
)
1042 if (! STRING_MULTIBYTE (string
))
1045 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1047 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1050 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1053 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1055 "Return the multibyte equivalent of STRING.\n\
1056 The function `unibyte-char-to-multibyte' is used to convert\n\
1057 each unibyte character to a multibyte character.")
1061 CHECK_STRING (string
, 0);
1063 return string_make_multibyte (string
);
1066 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1068 "Return the unibyte equivalent of STRING.\n\
1069 Multibyte character codes are converted to unibyte\n\
1070 by using just the low 8 bits.")
1074 CHECK_STRING (string
, 0);
1076 return string_make_unibyte (string
);
1079 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1081 "Return a unibyte string with the same individual bytes as STRING.\n\
1082 If STRING is unibyte, the result is STRING itself.\n\
1083 Otherwise it is a newly created string, with no text properties.\n\
1084 If STRING is multibyte and contains a character of charset `binary',\n\
1085 it is converted to the corresponding single byte.")
1089 CHECK_STRING (string
, 0);
1091 if (STRING_MULTIBYTE (string
))
1093 int bytes
= STRING_BYTES (XSTRING (string
));
1094 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1096 bcopy (XSTRING (string
)->data
, str
, bytes
);
1097 bytes
= str_as_unibyte (str
, bytes
);
1098 string
= make_unibyte_string (str
, bytes
);
1104 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1106 "Return a multibyte string with the same individual bytes as STRING.\n\
1107 If STRING is multibyte, the result is STRING itself.\n\
1108 Otherwise it is a newly created string, with no text properties.\n\
1109 If STRING is unibyte and contains an individual 8-bit byte (i.e. not\n\
1110 part of multibyte form), it is converted to the corresponding\n\
1111 multibyte character of charset `binary'.")
1115 CHECK_STRING (string
, 0);
1117 if (! STRING_MULTIBYTE (string
))
1119 Lisp_Object new_string
;
1122 parse_str_as_multibyte (XSTRING (string
)->data
,
1123 STRING_BYTES (XSTRING (string
)),
1125 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1126 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1127 STRING_BYTES (XSTRING (string
)));
1128 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1129 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1130 STRING_BYTES (XSTRING (string
)), NULL
);
1131 string
= new_string
;
1132 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1137 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1138 "Return a copy of ALIST.\n\
1139 This is an alist which represents the same mapping from objects to objects,\n\
1140 but does not share the alist structure with ALIST.\n\
1141 The objects mapped (cars and cdrs of elements of the alist)\n\
1142 are shared, however.\n\
1143 Elements of ALIST that are not conses are also shared.")
1147 register Lisp_Object tem
;
1149 CHECK_LIST (alist
, 0);
1152 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1153 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1155 register Lisp_Object car
;
1159 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1164 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1165 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1166 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1167 If FROM or TO is negative, it counts from the end.\n\
1169 This function allows vectors as well as strings.")
1172 register Lisp_Object from
, to
;
1177 int from_char
, to_char
;
1178 int from_byte
, to_byte
;
1180 if (! (STRINGP (string
) || VECTORP (string
)))
1181 wrong_type_argument (Qarrayp
, string
);
1183 CHECK_NUMBER (from
, 1);
1185 if (STRINGP (string
))
1187 size
= XSTRING (string
)->size
;
1188 size_byte
= STRING_BYTES (XSTRING (string
));
1191 size
= XVECTOR (string
)->size
;
1196 to_byte
= size_byte
;
1200 CHECK_NUMBER (to
, 2);
1202 to_char
= XINT (to
);
1206 if (STRINGP (string
))
1207 to_byte
= string_char_to_byte (string
, to_char
);
1210 from_char
= XINT (from
);
1213 if (STRINGP (string
))
1214 from_byte
= string_char_to_byte (string
, from_char
);
1216 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1217 args_out_of_range_3 (string
, make_number (from_char
),
1218 make_number (to_char
));
1220 if (STRINGP (string
))
1222 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1223 to_char
- from_char
, to_byte
- from_byte
,
1224 STRING_MULTIBYTE (string
));
1225 copy_text_properties (make_number (from_char
), make_number (to_char
),
1226 string
, make_number (0), res
, Qnil
);
1229 res
= Fvector (to_char
- from_char
,
1230 XVECTOR (string
)->contents
+ from_char
);
1235 /* Extract a substring of STRING, giving start and end positions
1236 both in characters and in bytes. */
1239 substring_both (string
, from
, from_byte
, to
, to_byte
)
1241 int from
, from_byte
, to
, to_byte
;
1247 if (! (STRINGP (string
) || VECTORP (string
)))
1248 wrong_type_argument (Qarrayp
, string
);
1250 if (STRINGP (string
))
1252 size
= XSTRING (string
)->size
;
1253 size_byte
= STRING_BYTES (XSTRING (string
));
1256 size
= XVECTOR (string
)->size
;
1258 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1259 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1261 if (STRINGP (string
))
1263 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1264 to
- from
, to_byte
- from_byte
,
1265 STRING_MULTIBYTE (string
));
1266 copy_text_properties (make_number (from
), make_number (to
),
1267 string
, make_number (0), res
, Qnil
);
1270 res
= Fvector (to
- from
,
1271 XVECTOR (string
)->contents
+ from
);
1276 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1277 "Take cdr N times on LIST, returns the result.")
1280 register Lisp_Object list
;
1282 register int i
, num
;
1283 CHECK_NUMBER (n
, 0);
1285 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1289 wrong_type_argument (Qlistp
, list
);
1295 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1296 "Return the Nth element of LIST.\n\
1297 N counts from zero. If LIST is not that long, nil is returned.")
1299 Lisp_Object n
, list
;
1301 return Fcar (Fnthcdr (n
, list
));
1304 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1305 "Return element of SEQUENCE at index N.")
1307 register Lisp_Object sequence
, n
;
1309 CHECK_NUMBER (n
, 0);
1312 if (CONSP (sequence
) || NILP (sequence
))
1313 return Fcar (Fnthcdr (n
, sequence
));
1314 else if (STRINGP (sequence
) || VECTORP (sequence
)
1315 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1316 return Faref (sequence
, n
);
1318 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1322 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1323 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1324 The value is actually the tail of LIST whose car is ELT.")
1326 register Lisp_Object elt
;
1329 register Lisp_Object tail
;
1330 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1332 register Lisp_Object tem
;
1334 wrong_type_argument (Qlistp
, list
);
1336 if (! NILP (Fequal (elt
, tem
)))
1343 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1344 "Return non-nil if ELT is an element of LIST.\n\
1345 Comparison done with EQ. The value is actually the tail of LIST\n\
1348 Lisp_Object elt
, list
;
1352 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1356 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1360 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1367 if (!CONSP (list
) && !NILP (list
))
1368 list
= wrong_type_argument (Qlistp
, list
);
1373 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1374 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1375 The value is actually the element of LIST whose car is KEY.\n\
1376 Elements of LIST that are not conses are ignored.")
1378 Lisp_Object key
, list
;
1385 || (CONSP (XCAR (list
))
1386 && EQ (XCAR (XCAR (list
)), key
)))
1391 || (CONSP (XCAR (list
))
1392 && EQ (XCAR (XCAR (list
)), key
)))
1397 || (CONSP (XCAR (list
))
1398 && EQ (XCAR (XCAR (list
)), key
)))
1406 result
= XCAR (list
);
1407 else if (NILP (list
))
1410 result
= wrong_type_argument (Qlistp
, list
);
1415 /* Like Fassq but never report an error and do not allow quits.
1416 Use only on lists known never to be circular. */
1419 assq_no_quit (key
, list
)
1420 Lisp_Object key
, list
;
1423 && (!CONSP (XCAR (list
))
1424 || !EQ (XCAR (XCAR (list
)), key
)))
1427 return CONSP (list
) ? XCAR (list
) : Qnil
;
1430 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1431 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1432 The value is actually the element of LIST whose car equals KEY.")
1434 Lisp_Object key
, list
;
1436 Lisp_Object result
, car
;
1441 || (CONSP (XCAR (list
))
1442 && (car
= XCAR (XCAR (list
)),
1443 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1448 || (CONSP (XCAR (list
))
1449 && (car
= XCAR (XCAR (list
)),
1450 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1455 || (CONSP (XCAR (list
))
1456 && (car
= XCAR (XCAR (list
)),
1457 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1465 result
= XCAR (list
);
1466 else if (NILP (list
))
1469 result
= wrong_type_argument (Qlistp
, list
);
1474 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1475 "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
1476 The value is actually the element of LIST whose cdr is KEY.")
1478 register Lisp_Object key
;
1486 || (CONSP (XCAR (list
))
1487 && EQ (XCDR (XCAR (list
)), key
)))
1492 || (CONSP (XCAR (list
))
1493 && EQ (XCDR (XCAR (list
)), key
)))
1498 || (CONSP (XCAR (list
))
1499 && EQ (XCDR (XCAR (list
)), key
)))
1508 else if (CONSP (list
))
1509 result
= XCAR (list
);
1511 result
= wrong_type_argument (Qlistp
, list
);
1516 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1517 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1518 The value is actually the element of LIST whose cdr equals KEY.")
1520 Lisp_Object key
, list
;
1522 Lisp_Object result
, cdr
;
1527 || (CONSP (XCAR (list
))
1528 && (cdr
= XCDR (XCAR (list
)),
1529 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1534 || (CONSP (XCAR (list
))
1535 && (cdr
= XCDR (XCAR (list
)),
1536 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1541 || (CONSP (XCAR (list
))
1542 && (cdr
= XCDR (XCAR (list
)),
1543 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1551 result
= XCAR (list
);
1552 else if (NILP (list
))
1555 result
= wrong_type_argument (Qlistp
, list
);
1560 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1561 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1562 The modified LIST is returned. Comparison is done with `eq'.\n\
1563 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1564 therefore, write `(setq foo (delq element foo))'\n\
1565 to be sure of changing the value of `foo'.")
1567 register Lisp_Object elt
;
1570 register Lisp_Object tail
, prev
;
1571 register Lisp_Object tem
;
1575 while (!NILP (tail
))
1578 wrong_type_argument (Qlistp
, list
);
1585 Fsetcdr (prev
, XCDR (tail
));
1595 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1596 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1597 The modified LIST is returned. Comparison is done with `equal'.\n\
1598 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1599 it is simply using a different list.\n\
1600 Therefore, write `(setq foo (delete element foo))'\n\
1601 to be sure of changing the value of `foo'.")
1603 register Lisp_Object elt
;
1606 register Lisp_Object tail
, prev
;
1607 register Lisp_Object tem
;
1611 while (!NILP (tail
))
1614 wrong_type_argument (Qlistp
, list
);
1616 if (! NILP (Fequal (elt
, tem
)))
1621 Fsetcdr (prev
, XCDR (tail
));
1631 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1632 "Reverse LIST by modifying cdr pointers.\n\
1633 Returns the beginning of the reversed list.")
1637 register Lisp_Object prev
, tail
, next
;
1639 if (NILP (list
)) return list
;
1642 while (!NILP (tail
))
1646 wrong_type_argument (Qlistp
, list
);
1648 Fsetcdr (tail
, prev
);
1655 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1656 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1657 See also the function `nreverse', which is used more often.")
1663 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1664 new = Fcons (XCAR (list
), new);
1666 wrong_type_argument (Qconsp
, list
);
1670 Lisp_Object
merge ();
1672 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1673 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1674 Returns the sorted list. LIST is modified by side effects.\n\
1675 PREDICATE is called with two elements of LIST, and should return T\n\
1676 if the first element is \"less\" than the second.")
1678 Lisp_Object list
, predicate
;
1680 Lisp_Object front
, back
;
1681 register Lisp_Object len
, tem
;
1682 struct gcpro gcpro1
, gcpro2
;
1683 register int length
;
1686 len
= Flength (list
);
1687 length
= XINT (len
);
1691 XSETINT (len
, (length
/ 2) - 1);
1692 tem
= Fnthcdr (len
, list
);
1694 Fsetcdr (tem
, Qnil
);
1696 GCPRO2 (front
, back
);
1697 front
= Fsort (front
, predicate
);
1698 back
= Fsort (back
, predicate
);
1700 return merge (front
, back
, predicate
);
1704 merge (org_l1
, org_l2
, pred
)
1705 Lisp_Object org_l1
, org_l2
;
1709 register Lisp_Object tail
;
1711 register Lisp_Object l1
, l2
;
1712 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1719 /* It is sufficient to protect org_l1 and org_l2.
1720 When l1 and l2 are updated, we copy the new values
1721 back into the org_ vars. */
1722 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1742 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1758 Fsetcdr (tail
, tem
);
1764 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1765 "Extract a value from a property list.\n\
1766 PLIST is a property list, which is a list of the form\n\
1767 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1768 corresponding to the given PROP, or nil if PROP is not\n\
1769 one of the properties on the list.")
1772 register Lisp_Object prop
;
1774 register Lisp_Object tail
;
1775 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCDR (tail
)))
1777 register Lisp_Object tem
;
1780 return Fcar (XCDR (tail
));
1785 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1786 "Return the value of SYMBOL's PROPNAME property.\n\
1787 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1789 Lisp_Object symbol
, propname
;
1791 CHECK_SYMBOL (symbol
, 0);
1792 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1795 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1796 "Change value in PLIST of PROP to VAL.\n\
1797 PLIST is a property list, which is a list of the form\n\
1798 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1799 If PROP is already a property on the list, its value is set to VAL,\n\
1800 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1801 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1802 The PLIST is modified by side effects.")
1805 register Lisp_Object prop
;
1808 register Lisp_Object tail
, prev
;
1809 Lisp_Object newcell
;
1811 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1812 tail
= XCDR (XCDR (tail
)))
1814 if (EQ (prop
, XCAR (tail
)))
1816 Fsetcar (XCDR (tail
), val
);
1821 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1825 Fsetcdr (XCDR (prev
), newcell
);
1829 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1830 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1831 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1832 (symbol
, propname
, value
)
1833 Lisp_Object symbol
, propname
, value
;
1835 CHECK_SYMBOL (symbol
, 0);
1836 XSYMBOL (symbol
)->plist
1837 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1841 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1842 "Return t if two Lisp objects have similar structure and contents.\n\
1843 They must have the same data type.\n\
1844 Conses are compared by comparing the cars and the cdrs.\n\
1845 Vectors and strings are compared element by element.\n\
1846 Numbers are compared by value, but integers cannot equal floats.\n\
1847 (Use `=' if you want integers and floats to be able to be equal.)\n\
1848 Symbols must match exactly.")
1850 register Lisp_Object o1
, o2
;
1852 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1856 internal_equal (o1
, o2
, depth
)
1857 register Lisp_Object o1
, o2
;
1861 error ("Stack overflow in equal");
1867 if (XTYPE (o1
) != XTYPE (o2
))
1873 return (extract_float (o1
) == extract_float (o2
));
1876 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1883 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1887 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1889 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1892 o1
= XOVERLAY (o1
)->plist
;
1893 o2
= XOVERLAY (o2
)->plist
;
1898 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1899 && (XMARKER (o1
)->buffer
== 0
1900 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1904 case Lisp_Vectorlike
:
1906 register int i
, size
;
1907 size
= XVECTOR (o1
)->size
;
1908 /* Pseudovectors have the type encoded in the size field, so this test
1909 actually checks that the objects have the same type as well as the
1911 if (XVECTOR (o2
)->size
!= size
)
1913 /* Boolvectors are compared much like strings. */
1914 if (BOOL_VECTOR_P (o1
))
1917 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1919 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1921 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1926 if (WINDOW_CONFIGURATIONP (o1
))
1927 return compare_window_configurations (o1
, o2
, 0);
1929 /* Aside from them, only true vectors, char-tables, and compiled
1930 functions are sensible to compare, so eliminate the others now. */
1931 if (size
& PSEUDOVECTOR_FLAG
)
1933 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1935 size
&= PSEUDOVECTOR_SIZE_MASK
;
1937 for (i
= 0; i
< size
; i
++)
1940 v1
= XVECTOR (o1
)->contents
[i
];
1941 v2
= XVECTOR (o2
)->contents
[i
];
1942 if (!internal_equal (v1
, v2
, depth
+ 1))
1950 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1952 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1954 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1955 STRING_BYTES (XSTRING (o1
))))
1962 extern Lisp_Object
Fmake_char_internal ();
1964 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1965 "Store each element of ARRAY with ITEM.\n\
1966 ARRAY is a vector, string, char-table, or bool-vector.")
1968 Lisp_Object array
, item
;
1970 register int size
, index
, charval
;
1972 if (VECTORP (array
))
1974 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1975 size
= XVECTOR (array
)->size
;
1976 for (index
= 0; index
< size
; index
++)
1979 else if (CHAR_TABLE_P (array
))
1981 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1982 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1983 for (index
= 0; index
< size
; index
++)
1985 XCHAR_TABLE (array
)->defalt
= Qnil
;
1987 else if (STRINGP (array
))
1989 register unsigned char *p
= XSTRING (array
)->data
;
1990 CHECK_NUMBER (item
, 1);
1991 charval
= XINT (item
);
1992 size
= XSTRING (array
)->size
;
1993 if (STRING_MULTIBYTE (array
))
1995 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1996 int len
= CHAR_STRING (charval
, str
);
1997 int size_byte
= STRING_BYTES (XSTRING (array
));
1998 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2001 if (size
!= size_byte
)
2004 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2005 if (len
!= this_len
)
2006 error ("Attempt to change byte length of a string");
2009 for (i
= 0; i
< size_byte
; i
++)
2010 *p
++ = str
[i
% len
];
2013 for (index
= 0; index
< size
; index
++)
2016 else if (BOOL_VECTOR_P (array
))
2018 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2020 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2022 charval
= (! NILP (item
) ? -1 : 0);
2023 for (index
= 0; index
< size_in_chars
; index
++)
2028 array
= wrong_type_argument (Qarrayp
, array
);
2034 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2036 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
2038 Lisp_Object char_table
;
2040 CHECK_CHAR_TABLE (char_table
, 0);
2042 return XCHAR_TABLE (char_table
)->purpose
;
2045 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2047 "Return the parent char-table of CHAR-TABLE.\n\
2048 The value is either nil or another char-table.\n\
2049 If CHAR-TABLE holds nil for a given character,\n\
2050 then the actual applicable value is inherited from the parent char-table\n\
2051 \(or from its parents, if necessary).")
2053 Lisp_Object char_table
;
2055 CHECK_CHAR_TABLE (char_table
, 0);
2057 return XCHAR_TABLE (char_table
)->parent
;
2060 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2062 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
2063 PARENT must be either nil or another char-table.")
2064 (char_table
, parent
)
2065 Lisp_Object char_table
, parent
;
2069 CHECK_CHAR_TABLE (char_table
, 0);
2073 CHECK_CHAR_TABLE (parent
, 0);
2075 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2076 if (EQ (temp
, char_table
))
2077 error ("Attempt to make a chartable be its own parent");
2080 XCHAR_TABLE (char_table
)->parent
= parent
;
2085 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2087 "Return the value of CHAR-TABLE's extra-slot number N.")
2089 Lisp_Object char_table
, n
;
2091 CHECK_CHAR_TABLE (char_table
, 1);
2092 CHECK_NUMBER (n
, 2);
2094 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2095 args_out_of_range (char_table
, n
);
2097 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2100 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2101 Sset_char_table_extra_slot
,
2103 "Set CHAR-TABLE's extra-slot number N to VALUE.")
2104 (char_table
, n
, value
)
2105 Lisp_Object char_table
, n
, value
;
2107 CHECK_CHAR_TABLE (char_table
, 1);
2108 CHECK_NUMBER (n
, 2);
2110 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2111 args_out_of_range (char_table
, n
);
2113 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2116 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2118 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
2119 RANGE should be nil (for the default value)\n\
2120 a vector which identifies a character set or a row of a character set,\n\
2121 a character set name, or a character code.")
2123 Lisp_Object char_table
, range
;
2125 CHECK_CHAR_TABLE (char_table
, 0);
2127 if (EQ (range
, Qnil
))
2128 return XCHAR_TABLE (char_table
)->defalt
;
2129 else if (INTEGERP (range
))
2130 return Faref (char_table
, range
);
2131 else if (SYMBOLP (range
))
2133 Lisp_Object charset_info
;
2135 charset_info
= Fget (range
, Qcharset
);
2136 CHECK_VECTOR (charset_info
, 0);
2138 return Faref (char_table
,
2139 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2142 else if (VECTORP (range
))
2144 if (XVECTOR (range
)->size
== 1)
2145 return Faref (char_table
,
2146 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2149 int size
= XVECTOR (range
)->size
;
2150 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2151 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2152 size
<= 1 ? Qnil
: val
[1],
2153 size
<= 2 ? Qnil
: val
[2]);
2154 return Faref (char_table
, ch
);
2158 error ("Invalid RANGE argument to `char-table-range'");
2162 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2164 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2165 RANGE should be t (for all characters), nil (for the default value)\n\
2166 a vector which identifies a character set or a row of a character set,\n\
2167 a coding system, or a character code.")
2168 (char_table
, range
, value
)
2169 Lisp_Object char_table
, range
, value
;
2173 CHECK_CHAR_TABLE (char_table
, 0);
2176 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2177 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2178 else if (EQ (range
, Qnil
))
2179 XCHAR_TABLE (char_table
)->defalt
= value
;
2180 else if (SYMBOLP (range
))
2182 Lisp_Object charset_info
;
2184 charset_info
= Fget (range
, Qcharset
);
2185 CHECK_VECTOR (charset_info
, 0);
2187 return Faset (char_table
,
2188 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2192 else if (INTEGERP (range
))
2193 Faset (char_table
, range
, value
);
2194 else if (VECTORP (range
))
2196 if (XVECTOR (range
)->size
== 1)
2197 return Faset (char_table
,
2198 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2202 int size
= XVECTOR (range
)->size
;
2203 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2204 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2205 size
<= 1 ? Qnil
: val
[1],
2206 size
<= 2 ? Qnil
: val
[2]);
2207 return Faset (char_table
, ch
, value
);
2211 error ("Invalid RANGE argument to `set-char-table-range'");
2216 DEFUN ("set-char-table-default", Fset_char_table_default
,
2217 Sset_char_table_default
, 3, 3, 0,
2218 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2219 The generic character specifies the group of characters.\n\
2220 See also the documentation of make-char.")
2221 (char_table
, ch
, value
)
2222 Lisp_Object char_table
, ch
, value
;
2224 int c
, charset
, code1
, code2
;
2227 CHECK_CHAR_TABLE (char_table
, 0);
2228 CHECK_NUMBER (ch
, 1);
2231 SPLIT_CHAR (c
, charset
, code1
, code2
);
2233 /* Since we may want to set the default value for a character set
2234 not yet defined, we check only if the character set is in the
2235 valid range or not, instead of it is already defined or not. */
2236 if (! CHARSET_VALID_P (charset
))
2237 invalid_character (c
);
2239 if (charset
== CHARSET_ASCII
)
2240 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2242 /* Even if C is not a generic char, we had better behave as if a
2243 generic char is specified. */
2244 if (CHARSET_DIMENSION (charset
) == 1)
2246 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2249 if (SUB_CHAR_TABLE_P (temp
))
2250 XCHAR_TABLE (temp
)->defalt
= value
;
2252 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2256 if (! SUB_CHAR_TABLE_P (char_table
))
2257 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2258 = make_sub_char_table (temp
));
2259 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2260 if (SUB_CHAR_TABLE_P (temp
))
2261 XCHAR_TABLE (temp
)->defalt
= value
;
2263 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2267 /* Look up the element in TABLE at index CH,
2268 and return it as an integer.
2269 If the element is nil, return CH itself.
2270 (Actually we do that for any non-integer.) */
2273 char_table_translate (table
, ch
)
2278 value
= Faref (table
, make_number (ch
));
2279 if (! INTEGERP (value
))
2281 return XINT (value
);
2285 optimize_sub_char_table (table
, chars
)
2293 from
= 33, to
= 127;
2295 from
= 32, to
= 128;
2297 if (!SUB_CHAR_TABLE_P (*table
))
2299 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2300 for (; from
< to
; from
++)
2301 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2306 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2308 "Optimize char table TABLE.")
2316 CHECK_CHAR_TABLE (table
, 0);
2318 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2320 elt
= XCHAR_TABLE (table
)->contents
[i
];
2321 if (!SUB_CHAR_TABLE_P (elt
))
2323 dim
= CHARSET_DIMENSION (i
);
2325 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2326 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2327 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2333 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2334 character or group of characters that share a value.
2335 DEPTH is the current depth in the originally specified
2336 chartable, and INDICES contains the vector indices
2337 for the levels our callers have descended.
2339 ARG is passed to C_FUNCTION when that is called. */
2342 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2343 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2344 Lisp_Object function
, subtable
, arg
, *indices
;
2351 /* At first, handle ASCII and 8-bit European characters. */
2352 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2354 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2356 (*c_function
) (arg
, make_number (i
), elt
);
2358 call2 (function
, make_number (i
), elt
);
2360 #if 0 /* If the char table has entries for higher characters,
2361 we should report them. */
2362 if (NILP (current_buffer
->enable_multibyte_characters
))
2365 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2369 int charset
= XFASTINT (indices
[0]) - 128;
2372 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2373 if (CHARSET_CHARS (charset
) == 94)
2382 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2383 XSETFASTINT (indices
[depth
], i
);
2384 charset
= XFASTINT (indices
[0]) - 128;
2386 && (!CHARSET_DEFINED_P (charset
)
2387 || charset
== CHARSET_8_BIT_CONTROL
2388 || charset
== CHARSET_8_BIT_GRAPHIC
))
2391 if (SUB_CHAR_TABLE_P (elt
))
2394 error ("Too deep char table");
2395 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2402 elt
= XCHAR_TABLE (subtable
)->defalt
;
2403 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2404 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2405 c
= MAKE_CHAR (charset
, c1
, c2
);
2407 (*c_function
) (arg
, make_number (c
), elt
);
2409 call2 (function
, make_number (c
), elt
);
2414 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2416 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2417 FUNCTION is called with two arguments--a key and a value.\n\
2418 The key is always a possible IDX argument to `aref'.")
2419 (function
, char_table
)
2420 Lisp_Object function
, char_table
;
2422 /* The depth of char table is at most 3. */
2423 Lisp_Object indices
[3];
2425 CHECK_CHAR_TABLE (char_table
, 1);
2427 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2437 Lisp_Object args
[2];
2440 return Fnconc (2, args
);
2442 return Fnconc (2, &s1
);
2443 #endif /* NO_ARG_ARRAY */
2446 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2447 "Concatenate any number of lists by altering them.\n\
2448 Only the last argument is not altered, and need not be a list.")
2453 register int argnum
;
2454 register Lisp_Object tail
, tem
, val
;
2458 for (argnum
= 0; argnum
< nargs
; argnum
++)
2461 if (NILP (tem
)) continue;
2466 if (argnum
+ 1 == nargs
) break;
2469 tem
= wrong_type_argument (Qlistp
, tem
);
2478 tem
= args
[argnum
+ 1];
2479 Fsetcdr (tail
, tem
);
2481 args
[argnum
+ 1] = tail
;
2487 /* This is the guts of all mapping functions.
2488 Apply FN to each element of SEQ, one by one,
2489 storing the results into elements of VALS, a C vector of Lisp_Objects.
2490 LENI is the length of VALS, which should also be the length of SEQ. */
2493 mapcar1 (leni
, vals
, fn
, seq
)
2496 Lisp_Object fn
, seq
;
2498 register Lisp_Object tail
;
2501 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2505 /* Don't let vals contain any garbage when GC happens. */
2506 for (i
= 0; i
< leni
; i
++)
2509 GCPRO3 (dummy
, fn
, seq
);
2511 gcpro1
.nvars
= leni
;
2515 /* We need not explicitly protect `tail' because it is used only on lists, and
2516 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2520 for (i
= 0; i
< leni
; i
++)
2522 dummy
= XVECTOR (seq
)->contents
[i
];
2523 dummy
= call1 (fn
, dummy
);
2528 else if (BOOL_VECTOR_P (seq
))
2530 for (i
= 0; i
< leni
; i
++)
2533 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2534 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2539 dummy
= call1 (fn
, dummy
);
2544 else if (STRINGP (seq
))
2548 for (i
= 0, i_byte
= 0; i
< leni
;)
2553 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2554 XSETFASTINT (dummy
, c
);
2555 dummy
= call1 (fn
, dummy
);
2557 vals
[i_before
] = dummy
;
2560 else /* Must be a list, since Flength did not get an error */
2563 for (i
= 0; i
< leni
; i
++)
2565 dummy
= call1 (fn
, Fcar (tail
));
2575 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2576 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2577 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2578 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2579 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2580 (function
, sequence
, separator
)
2581 Lisp_Object function
, sequence
, separator
;
2586 register Lisp_Object
*args
;
2588 struct gcpro gcpro1
;
2590 len
= Flength (sequence
);
2592 nargs
= leni
+ leni
- 1;
2593 if (nargs
< 0) return build_string ("");
2595 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2598 mapcar1 (leni
, args
, function
, sequence
);
2601 for (i
= leni
- 1; i
>= 0; i
--)
2602 args
[i
+ i
] = args
[i
];
2604 for (i
= 1; i
< nargs
; i
+= 2)
2605 args
[i
] = separator
;
2607 return Fconcat (nargs
, args
);
2610 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2611 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2612 The result is a list just as long as SEQUENCE.\n\
2613 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2614 (function
, sequence
)
2615 Lisp_Object function
, sequence
;
2617 register Lisp_Object len
;
2619 register Lisp_Object
*args
;
2621 len
= Flength (sequence
);
2622 leni
= XFASTINT (len
);
2623 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2625 mapcar1 (leni
, args
, function
, sequence
);
2627 return Flist (leni
, args
);
2630 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2631 "Apply FUNCTION to each element of SEQUENCE for side effects only.\n\
2632 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.\n\
2633 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2634 (function
, sequence
)
2635 Lisp_Object function
, sequence
;
2639 leni
= XFASTINT (Flength (sequence
));
2640 mapcar1 (leni
, 0, function
, sequence
);
2645 /* Anything that calls this function must protect from GC! */
2647 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2648 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2649 Takes one argument, which is the string to display to ask the question.\n\
2650 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2651 No confirmation of the answer is requested; a single character is enough.\n\
2652 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2653 the bindings in `query-replace-map'; see the documentation of that variable\n\
2654 for more information. In this case, the useful bindings are `act', `skip',\n\
2655 `recenter', and `quit'.\)\n\
2657 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2662 register Lisp_Object obj
, key
, def
, map
;
2663 register int answer
;
2664 Lisp_Object xprompt
;
2665 Lisp_Object args
[2];
2666 struct gcpro gcpro1
, gcpro2
;
2667 int count
= specpdl_ptr
- specpdl
;
2669 specbind (Qcursor_in_echo_area
, Qt
);
2671 map
= Fsymbol_value (intern ("query-replace-map"));
2673 CHECK_STRING (prompt
, 0);
2675 GCPRO2 (prompt
, xprompt
);
2677 #ifdef HAVE_X_WINDOWS
2678 if (display_busy_cursor_p
)
2679 cancel_busy_cursor ();
2686 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2690 Lisp_Object pane
, menu
;
2691 redisplay_preserve_echo_area ();
2692 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2693 Fcons (Fcons (build_string ("No"), Qnil
),
2695 menu
= Fcons (prompt
, pane
);
2696 obj
= Fx_popup_dialog (Qt
, menu
);
2697 answer
= !NILP (obj
);
2700 #endif /* HAVE_MENUS */
2701 cursor_in_echo_area
= 1;
2702 choose_minibuf_frame ();
2703 message_with_string ("%s(y or n) ", xprompt
, 0);
2705 if (minibuffer_auto_raise
)
2707 Lisp_Object mini_frame
;
2709 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2711 Fraise_frame (mini_frame
);
2714 obj
= read_filtered_event (1, 0, 0, 0);
2715 cursor_in_echo_area
= 0;
2716 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2719 key
= Fmake_vector (make_number (1), obj
);
2720 def
= Flookup_key (map
, key
, Qt
);
2722 if (EQ (def
, intern ("skip")))
2727 else if (EQ (def
, intern ("act")))
2732 else if (EQ (def
, intern ("recenter")))
2738 else if (EQ (def
, intern ("quit")))
2740 /* We want to exit this command for exit-prefix,
2741 and this is the only way to do it. */
2742 else if (EQ (def
, intern ("exit-prefix")))
2747 /* If we don't clear this, then the next call to read_char will
2748 return quit_char again, and we'll enter an infinite loop. */
2753 if (EQ (xprompt
, prompt
))
2755 args
[0] = build_string ("Please answer y or n. ");
2757 xprompt
= Fconcat (2, args
);
2762 if (! noninteractive
)
2764 cursor_in_echo_area
= -1;
2765 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2769 unbind_to (count
, Qnil
);
2770 return answer
? Qt
: Qnil
;
2773 /* This is how C code calls `yes-or-no-p' and allows the user
2776 Anything that calls this function must protect from GC! */
2779 do_yes_or_no_p (prompt
)
2782 return call1 (intern ("yes-or-no-p"), prompt
);
2785 /* Anything that calls this function must protect from GC! */
2787 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2788 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2789 Takes one argument, which is the string to display to ask the question.\n\
2790 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2791 The user must confirm the answer with RET,\n\
2792 and can edit it until it has been confirmed.\n\
2794 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2799 register Lisp_Object ans
;
2800 Lisp_Object args
[2];
2801 struct gcpro gcpro1
;
2803 CHECK_STRING (prompt
, 0);
2806 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2810 Lisp_Object pane
, menu
, obj
;
2811 redisplay_preserve_echo_area ();
2812 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2813 Fcons (Fcons (build_string ("No"), Qnil
),
2816 menu
= Fcons (prompt
, pane
);
2817 obj
= Fx_popup_dialog (Qt
, menu
);
2821 #endif /* HAVE_MENUS */
2824 args
[1] = build_string ("(yes or no) ");
2825 prompt
= Fconcat (2, args
);
2831 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2832 Qyes_or_no_p_history
, Qnil
,
2834 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2839 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2847 message ("Please answer yes or no.");
2848 Fsleep_for (make_number (2), Qnil
);
2852 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2853 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2854 Each of the three load averages is multiplied by 100,\n\
2855 then converted to integer.\n\
2856 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2857 These floats are not multiplied by 100.\n\n\
2858 If the 5-minute or 15-minute load averages are not available, return a\n\
2859 shortened list, containing only those averages which are available.")
2861 Lisp_Object use_floats
;
2864 int loads
= getloadavg (load_ave
, 3);
2865 Lisp_Object ret
= Qnil
;
2868 error ("load-average not implemented for this operating system");
2872 Lisp_Object load
= (NILP (use_floats
) ?
2873 make_number ((int) (100.0 * load_ave
[loads
]))
2874 : make_float (load_ave
[loads
]));
2875 ret
= Fcons (load
, ret
);
2881 Lisp_Object Vfeatures
;
2883 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2884 "Returns t if FEATURE is present in this Emacs.\n\
2885 Use this to conditionalize execution of lisp code based on the presence or\n\
2886 absence of emacs or environment extensions.\n\
2887 Use `provide' to declare that a feature is available.\n\
2888 This function looks at the value of the variable `features'.")
2890 Lisp_Object feature
;
2892 register Lisp_Object tem
;
2893 CHECK_SYMBOL (feature
, 0);
2894 tem
= Fmemq (feature
, Vfeatures
);
2895 return (NILP (tem
)) ? Qnil
: Qt
;
2898 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2899 "Announce that FEATURE is a feature of the current Emacs.")
2901 Lisp_Object feature
;
2903 register Lisp_Object tem
;
2904 CHECK_SYMBOL (feature
, 0);
2905 if (!NILP (Vautoload_queue
))
2906 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2907 tem
= Fmemq (feature
, Vfeatures
);
2909 Vfeatures
= Fcons (feature
, Vfeatures
);
2910 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2914 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2915 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2916 If FEATURE is not a member of the list `features', then the feature\n\
2917 is not loaded; so load the file FILENAME.\n\
2918 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2919 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2920 If the optional third argument NOERROR is non-nil,\n\
2921 then return nil if the file is not found.\n\
2922 Normally the return value is FEATURE.")
2923 (feature
, file_name
, noerror
)
2924 Lisp_Object feature
, file_name
, noerror
;
2926 register Lisp_Object tem
;
2927 CHECK_SYMBOL (feature
, 0);
2928 tem
= Fmemq (feature
, Vfeatures
);
2929 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2932 int count
= specpdl_ptr
- specpdl
;
2934 /* Value saved here is to be restored into Vautoload_queue */
2935 record_unwind_protect (un_autoload
, Vautoload_queue
);
2936 Vautoload_queue
= Qt
;
2938 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2939 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2940 /* If load failed entirely, return nil. */
2942 return unbind_to (count
, Qnil
);
2944 tem
= Fmemq (feature
, Vfeatures
);
2946 error ("Required feature %s was not provided",
2947 XSYMBOL (feature
)->name
->data
);
2949 /* Once loading finishes, don't undo it. */
2950 Vautoload_queue
= Qt
;
2951 feature
= unbind_to (count
, feature
);
2956 /* Primitives for work of the "widget" library.
2957 In an ideal world, this section would not have been necessary.
2958 However, lisp function calls being as slow as they are, it turns
2959 out that some functions in the widget library (wid-edit.el) are the
2960 bottleneck of Widget operation. Here is their translation to C,
2961 for the sole reason of efficiency. */
2963 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2964 "Return non-nil if PLIST has the property PROP.\n\
2965 PLIST is a property list, which is a list of the form\n\
2966 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2967 Unlike `plist-get', this allows you to distinguish between a missing\n\
2968 property and a property with the value nil.\n\
2969 The value is actually the tail of PLIST whose car is PROP.")
2971 Lisp_Object plist
, prop
;
2973 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2976 plist
= XCDR (plist
);
2977 plist
= CDR (plist
);
2982 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2983 "In WIDGET, set PROPERTY to VALUE.\n\
2984 The value can later be retrieved with `widget-get'.")
2985 (widget
, property
, value
)
2986 Lisp_Object widget
, property
, value
;
2988 CHECK_CONS (widget
, 1);
2989 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2993 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2994 "In WIDGET, get the value of PROPERTY.\n\
2995 The value could either be specified when the widget was created, or\n\
2996 later with `widget-put'.")
2998 Lisp_Object widget
, property
;
3006 CHECK_CONS (widget
, 1);
3007 tmp
= Fplist_member (XCDR (widget
), property
);
3013 tmp
= XCAR (widget
);
3016 widget
= Fget (tmp
, Qwidget_type
);
3020 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3021 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
3022 ARGS are passed as extra arguments to the function.")
3027 /* This function can GC. */
3028 Lisp_Object newargs
[3];
3029 struct gcpro gcpro1
, gcpro2
;
3032 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3033 newargs
[1] = args
[0];
3034 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3035 GCPRO2 (newargs
[0], newargs
[2]);
3036 result
= Fapply (3, newargs
);
3041 /* base64 encode/decode functions.
3042 Based on code from GNU recode. */
3044 #define MIME_LINE_LENGTH 76
3046 #define IS_ASCII(Character) \
3048 #define IS_BASE64(Character) \
3049 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3050 #define IS_BASE64_IGNORABLE(Character) \
3051 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3052 || (Character) == '\f' || (Character) == '\r')
3054 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3055 character or return retval if there are no characters left to
3057 #define READ_QUADRUPLET_BYTE(retval) \
3064 while (IS_BASE64_IGNORABLE (c))
3066 /* Don't use alloca for regions larger than this, lest we overflow
3068 #define MAX_ALLOCA 16*1024
3070 /* Table of characters coding the 64 values. */
3071 static char base64_value_to_char
[64] =
3073 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3074 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3075 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3076 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3077 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3078 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3079 '8', '9', '+', '/' /* 60-63 */
3082 /* Table of base64 values for first 128 characters. */
3083 static short base64_char_to_value
[128] =
3085 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3086 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3087 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3088 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3089 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3090 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3091 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3092 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3093 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3094 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3095 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3096 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3097 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3100 /* The following diagram shows the logical steps by which three octets
3101 get transformed into four base64 characters.
3103 .--------. .--------. .--------.
3104 |aaaaaabb| |bbbbcccc| |ccdddddd|
3105 `--------' `--------' `--------'
3107 .--------+--------+--------+--------.
3108 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3109 `--------+--------+--------+--------'
3111 .--------+--------+--------+--------.
3112 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3113 `--------+--------+--------+--------'
3115 The octets are divided into 6 bit chunks, which are then encoded into
3116 base64 characters. */
3119 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3120 static int base64_decode_1
P_ ((const char *, char *, int));
3122 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3124 "Base64-encode the region between BEG and END.\n\
3125 Return the length of the encoded text.\n\
3126 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3127 into shorter lines.")
3128 (beg
, end
, no_line_break
)
3129 Lisp_Object beg
, end
, no_line_break
;
3132 int allength
, length
;
3133 int ibeg
, iend
, encoded_length
;
3136 validate_region (&beg
, &end
);
3138 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3139 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3140 move_gap_both (XFASTINT (beg
), ibeg
);
3142 /* We need to allocate enough room for encoding the text.
3143 We need 33 1/3% more space, plus a newline every 76
3144 characters, and then we round up. */
3145 length
= iend
- ibeg
;
3146 allength
= length
+ length
/3 + 1;
3147 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3149 if (allength
<= MAX_ALLOCA
)
3150 encoded
= (char *) alloca (allength
);
3152 encoded
= (char *) xmalloc (allength
);
3153 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3154 NILP (no_line_break
),
3155 !NILP (current_buffer
->enable_multibyte_characters
));
3156 if (encoded_length
> allength
)
3159 if (encoded_length
< 0)
3161 /* The encoding wasn't possible. */
3162 if (length
> MAX_ALLOCA
)
3164 error ("Base64 encoding failed");
3167 /* Now we have encoded the region, so we insert the new contents
3168 and delete the old. (Insert first in order to preserve markers.) */
3169 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3170 insert (encoded
, encoded_length
);
3171 if (allength
> MAX_ALLOCA
)
3173 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3175 /* If point was outside of the region, restore it exactly; else just
3176 move to the beginning of the region. */
3177 if (old_pos
>= XFASTINT (end
))
3178 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3179 else if (old_pos
> XFASTINT (beg
))
3180 old_pos
= XFASTINT (beg
);
3183 /* We return the length of the encoded text. */
3184 return make_number (encoded_length
);
3187 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3189 "Base64-encode STRING and return the result.\n\
3190 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3191 into shorter lines.")
3192 (string
, no_line_break
)
3193 Lisp_Object string
, no_line_break
;
3195 int allength
, length
, encoded_length
;
3197 Lisp_Object encoded_string
;
3199 CHECK_STRING (string
, 1);
3201 /* We need to allocate enough room for encoding the text.
3202 We need 33 1/3% more space, plus a newline every 76
3203 characters, and then we round up. */
3204 length
= STRING_BYTES (XSTRING (string
));
3205 allength
= length
+ length
/3 + 1;
3206 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3208 /* We need to allocate enough room for decoding the text. */
3209 if (allength
<= MAX_ALLOCA
)
3210 encoded
= (char *) alloca (allength
);
3212 encoded
= (char *) xmalloc (allength
);
3214 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3215 encoded
, length
, NILP (no_line_break
),
3216 STRING_MULTIBYTE (string
));
3217 if (encoded_length
> allength
)
3220 if (encoded_length
< 0)
3222 /* The encoding wasn't possible. */
3223 if (length
> MAX_ALLOCA
)
3225 error ("Base64 encoding failed");
3228 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3229 if (allength
> MAX_ALLOCA
)
3232 return encoded_string
;
3236 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3243 int counter
= 0, i
= 0;
3253 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3254 if (!SINGLE_BYTE_CHAR_P (c
))
3261 /* Wrap line every 76 characters. */
3265 if (counter
< MIME_LINE_LENGTH
/ 4)
3274 /* Process first byte of a triplet. */
3276 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3277 value
= (0x03 & c
) << 4;
3279 /* Process second byte of a triplet. */
3283 *e
++ = base64_value_to_char
[value
];
3291 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3297 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3298 value
= (0x0f & c
) << 2;
3300 /* Process third byte of a triplet. */
3304 *e
++ = base64_value_to_char
[value
];
3311 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3317 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3318 *e
++ = base64_value_to_char
[0x3f & c
];
3325 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3327 "Base64-decode the region between BEG and END.\n\
3328 Return the length of the decoded text.\n\
3329 If the region can't be decoded, signal an error and don't modify the buffer.")
3331 Lisp_Object beg
, end
;
3333 int ibeg
, iend
, length
;
3339 validate_region (&beg
, &end
);
3341 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3342 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3344 length
= iend
- ibeg
;
3345 /* We need to allocate enough room for decoding the text. */
3346 if (length
<= MAX_ALLOCA
)
3347 decoded
= (char *) alloca (length
);
3349 decoded
= (char *) xmalloc (length
);
3351 move_gap_both (XFASTINT (beg
), ibeg
);
3352 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3353 if (decoded_length
> length
)
3356 if (decoded_length
< 0)
3358 /* The decoding wasn't possible. */
3359 if (length
> MAX_ALLOCA
)
3361 error ("Base64 decoding failed");
3364 inserted_chars
= decoded_length
;
3365 if (!NILP (current_buffer
->enable_multibyte_characters
))
3366 decoded_length
= str_to_multibyte (decoded
, length
, decoded_length
);
3368 /* Now we have decoded the region, so we insert the new contents
3369 and delete the old. (Insert first in order to preserve markers.) */
3370 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3371 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3372 if (length
> MAX_ALLOCA
)
3374 /* Delete the original text. */
3375 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3376 iend
+ decoded_length
, 1);
3378 /* If point was outside of the region, restore it exactly; else just
3379 move to the beginning of the region. */
3380 if (old_pos
>= XFASTINT (end
))
3381 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3382 else if (old_pos
> XFASTINT (beg
))
3383 old_pos
= XFASTINT (beg
);
3384 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3386 return make_number (inserted_chars
);
3389 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3391 "Base64-decode STRING and return the result.")
3396 int length
, decoded_length
;
3397 Lisp_Object decoded_string
;
3399 CHECK_STRING (string
, 1);
3401 length
= STRING_BYTES (XSTRING (string
));
3402 /* We need to allocate enough room for decoding the text. */
3403 if (length
<= MAX_ALLOCA
)
3404 decoded
= (char *) alloca (length
);
3406 decoded
= (char *) xmalloc (length
);
3408 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3409 if (decoded_length
> length
)
3411 else if (decoded_length
>= 0)
3412 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3414 decoded_string
= Qnil
;
3416 if (length
> MAX_ALLOCA
)
3418 if (!STRINGP (decoded_string
))
3419 error ("Base64 decoding failed");
3421 return decoded_string
;
3425 base64_decode_1 (from
, to
, length
)
3433 unsigned long value
;
3437 /* Process first byte of a quadruplet. */
3439 READ_QUADRUPLET_BYTE (e
-to
);
3443 value
= base64_char_to_value
[c
] << 18;
3445 /* Process second byte of a quadruplet. */
3447 READ_QUADRUPLET_BYTE (-1);
3451 value
|= base64_char_to_value
[c
] << 12;
3453 *e
++ = (unsigned char) (value
>> 16);
3455 /* Process third byte of a quadruplet. */
3457 READ_QUADRUPLET_BYTE (-1);
3461 READ_QUADRUPLET_BYTE (-1);
3470 value
|= base64_char_to_value
[c
] << 6;
3472 *e
++ = (unsigned char) (0xff & value
>> 8);
3474 /* Process fourth byte of a quadruplet. */
3476 READ_QUADRUPLET_BYTE (-1);
3483 value
|= base64_char_to_value
[c
];
3485 *e
++ = (unsigned char) (0xff & value
);
3491 /***********************************************************************
3493 ***** Hash Tables *****
3495 ***********************************************************************/
3497 /* Implemented by gerd@gnu.org. This hash table implementation was
3498 inspired by CMUCL hash tables. */
3502 1. For small tables, association lists are probably faster than
3503 hash tables because they have lower overhead.
3505 For uses of hash tables where the O(1) behavior of table
3506 operations is not a requirement, it might therefore be a good idea
3507 not to hash. Instead, we could just do a linear search in the
3508 key_and_value vector of the hash table. This could be done
3509 if a `:linear-search t' argument is given to make-hash-table. */
3512 /* Return the contents of vector V at index IDX. */
3514 #define AREF(V, IDX) XVECTOR (V)->contents[IDX]
3516 /* Value is the key part of entry IDX in hash table H. */
3518 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3520 /* Value is the value part of entry IDX in hash table H. */
3522 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3524 /* Value is the index of the next entry following the one at IDX
3527 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3529 /* Value is the hash code computed for entry IDX in hash table H. */
3531 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3533 /* Value is the index of the element in hash table H that is the
3534 start of the collision list at index IDX in the index vector of H. */
3536 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3538 /* Value is the size of hash table H. */
3540 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3542 /* The list of all weak hash tables. Don't staticpro this one. */
3544 Lisp_Object Vweak_hash_tables
;
3546 /* Various symbols. */
3548 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3549 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3550 Lisp_Object Qhash_table_test
;
3552 /* Function prototypes. */
3554 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3555 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3556 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3557 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3558 Lisp_Object
, unsigned));
3559 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3560 Lisp_Object
, unsigned));
3561 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3562 unsigned, Lisp_Object
, unsigned));
3563 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3564 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3565 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3566 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3568 static unsigned sxhash_string
P_ ((unsigned char *, int));
3569 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3570 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3571 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3572 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3576 /***********************************************************************
3578 ***********************************************************************/
3580 /* If OBJ is a Lisp hash table, return a pointer to its struct
3581 Lisp_Hash_Table. Otherwise, signal an error. */
3583 static struct Lisp_Hash_Table
*
3584 check_hash_table (obj
)
3587 CHECK_HASH_TABLE (obj
, 0);
3588 return XHASH_TABLE (obj
);
3592 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3596 next_almost_prime (n
)
3609 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3610 which USED[I] is non-zero. If found at index I in ARGS, set
3611 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3612 -1. This function is used to extract a keyword/argument pair from
3613 a DEFUN parameter list. */
3616 get_key_arg (key
, nargs
, args
, used
)
3624 for (i
= 0; i
< nargs
- 1; ++i
)
3625 if (!used
[i
] && EQ (args
[i
], key
))
3640 /* Return a Lisp vector which has the same contents as VEC but has
3641 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3642 vector that are not copied from VEC are set to INIT. */
3645 larger_vector (vec
, new_size
, init
)
3650 struct Lisp_Vector
*v
;
3653 xassert (VECTORP (vec
));
3654 old_size
= XVECTOR (vec
)->size
;
3655 xassert (new_size
>= old_size
);
3657 v
= allocate_vectorlike (new_size
);
3659 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3660 old_size
* sizeof *v
->contents
);
3661 for (i
= old_size
; i
< new_size
; ++i
)
3662 v
->contents
[i
] = init
;
3663 XSETVECTOR (vec
, v
);
3668 /***********************************************************************
3670 ***********************************************************************/
3672 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3673 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3674 KEY2 are the same. */
3677 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3678 struct Lisp_Hash_Table
*h
;
3679 Lisp_Object key1
, key2
;
3680 unsigned hash1
, hash2
;
3682 return (FLOATP (key1
)
3684 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3688 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3689 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3690 KEY2 are the same. */
3693 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3694 struct Lisp_Hash_Table
*h
;
3695 Lisp_Object key1
, key2
;
3696 unsigned hash1
, hash2
;
3698 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3702 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3703 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3704 if KEY1 and KEY2 are the same. */
3707 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3708 struct Lisp_Hash_Table
*h
;
3709 Lisp_Object key1
, key2
;
3710 unsigned hash1
, hash2
;
3714 Lisp_Object args
[3];
3716 args
[0] = h
->user_cmp_function
;
3719 return !NILP (Ffuncall (3, args
));
3726 /* Value is a hash code for KEY for use in hash table H which uses
3727 `eq' to compare keys. The hash code returned is guaranteed to fit
3728 in a Lisp integer. */
3732 struct Lisp_Hash_Table
*h
;
3735 /* Lisp strings can change their address. Don't try to compute a
3736 hash code for a string from its address. */
3738 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3740 return XUINT (key
) ^ XGCTYPE (key
);
3744 /* Value is a hash code for KEY for use in hash table H which uses
3745 `eql' to compare keys. The hash code returned is guaranteed to fit
3746 in a Lisp integer. */
3750 struct Lisp_Hash_Table
*h
;
3753 /* Lisp strings can change their address. Don't try to compute a
3754 hash code for a string from its address. */
3756 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3757 else if (FLOATP (key
))
3758 return sxhash (key
, 0);
3760 return XUINT (key
) ^ XGCTYPE (key
);
3764 /* Value is a hash code for KEY for use in hash table H which uses
3765 `equal' to compare keys. The hash code returned is guaranteed to fit
3766 in a Lisp integer. */
3769 hashfn_equal (h
, key
)
3770 struct Lisp_Hash_Table
*h
;
3773 return sxhash (key
, 0);
3777 /* Value is a hash code for KEY for use in hash table H which uses as
3778 user-defined function to compare keys. The hash code returned is
3779 guaranteed to fit in a Lisp integer. */
3782 hashfn_user_defined (h
, key
)
3783 struct Lisp_Hash_Table
*h
;
3786 Lisp_Object args
[2], hash
;
3788 args
[0] = h
->user_hash_function
;
3790 hash
= Ffuncall (2, args
);
3791 if (!INTEGERP (hash
))
3793 list2 (build_string ("Illegal hash code returned from \
3794 user-supplied hash function"),
3796 return XUINT (hash
);
3800 /* Create and initialize a new hash table.
3802 TEST specifies the test the hash table will use to compare keys.
3803 It must be either one of the predefined tests `eq', `eql' or
3804 `equal' or a symbol denoting a user-defined test named TEST with
3805 test and hash functions USER_TEST and USER_HASH.
3807 Give the table initial capacity SIZE, SIZE > 0, an integer.
3809 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3810 new size when it becomes full is computed by adding REHASH_SIZE to
3811 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3812 table's new size is computed by multiplying its old size with
3815 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3816 be resized when the ratio of (number of entries in the table) /
3817 (table size) is >= REHASH_THRESHOLD.
3819 WEAK specifies the weakness of the table. If non-nil, it must be
3820 one of the symbols `key', `value' or t. */
3823 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3824 user_test
, user_hash
)
3825 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3826 Lisp_Object user_test
, user_hash
;
3828 struct Lisp_Hash_Table
*h
;
3829 struct Lisp_Vector
*v
;
3831 int index_size
, i
, len
, sz
;
3833 /* Preconditions. */
3834 xassert (SYMBOLP (test
));
3835 xassert (INTEGERP (size
) && XINT (size
) > 0);
3836 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3837 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3838 xassert (FLOATP (rehash_threshold
)
3839 && XFLOATINT (rehash_threshold
) > 0
3840 && XFLOATINT (rehash_threshold
) <= 1.0);
3842 /* Allocate a vector, and initialize it. */
3843 len
= VECSIZE (struct Lisp_Hash_Table
);
3844 v
= allocate_vectorlike (len
);
3846 for (i
= 0; i
< len
; ++i
)
3847 v
->contents
[i
] = Qnil
;
3849 /* Initialize hash table slots. */
3850 sz
= XFASTINT (size
);
3851 h
= (struct Lisp_Hash_Table
*) v
;
3854 if (EQ (test
, Qeql
))
3856 h
->cmpfn
= cmpfn_eql
;
3857 h
->hashfn
= hashfn_eql
;
3859 else if (EQ (test
, Qeq
))
3862 h
->hashfn
= hashfn_eq
;
3864 else if (EQ (test
, Qequal
))
3866 h
->cmpfn
= cmpfn_equal
;
3867 h
->hashfn
= hashfn_equal
;
3871 h
->user_cmp_function
= user_test
;
3872 h
->user_hash_function
= user_hash
;
3873 h
->cmpfn
= cmpfn_user_defined
;
3874 h
->hashfn
= hashfn_user_defined
;
3878 h
->rehash_threshold
= rehash_threshold
;
3879 h
->rehash_size
= rehash_size
;
3880 h
->count
= make_number (0);
3881 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3882 h
->hash
= Fmake_vector (size
, Qnil
);
3883 h
->next
= Fmake_vector (size
, Qnil
);
3884 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3885 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3886 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3888 /* Set up the free list. */
3889 for (i
= 0; i
< sz
- 1; ++i
)
3890 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3891 h
->next_free
= make_number (0);
3893 XSET_HASH_TABLE (table
, h
);
3894 xassert (HASH_TABLE_P (table
));
3895 xassert (XHASH_TABLE (table
) == h
);
3897 /* Maybe add this hash table to the list of all weak hash tables. */
3899 h
->next_weak
= Qnil
;
3902 h
->next_weak
= Vweak_hash_tables
;
3903 Vweak_hash_tables
= table
;
3910 /* Return a copy of hash table H1. Keys and values are not copied,
3911 only the table itself is. */
3914 copy_hash_table (h1
)
3915 struct Lisp_Hash_Table
*h1
;
3918 struct Lisp_Hash_Table
*h2
;
3919 struct Lisp_Vector
*v
, *next
;
3922 len
= VECSIZE (struct Lisp_Hash_Table
);
3923 v
= allocate_vectorlike (len
);
3924 h2
= (struct Lisp_Hash_Table
*) v
;
3925 next
= h2
->vec_next
;
3926 bcopy (h1
, h2
, sizeof *h2
);
3927 h2
->vec_next
= next
;
3928 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3929 h2
->hash
= Fcopy_sequence (h1
->hash
);
3930 h2
->next
= Fcopy_sequence (h1
->next
);
3931 h2
->index
= Fcopy_sequence (h1
->index
);
3932 XSET_HASH_TABLE (table
, h2
);
3934 /* Maybe add this hash table to the list of all weak hash tables. */
3935 if (!NILP (h2
->weak
))
3937 h2
->next_weak
= Vweak_hash_tables
;
3938 Vweak_hash_tables
= table
;
3945 /* Resize hash table H if it's too full. If H cannot be resized
3946 because it's already too large, throw an error. */
3949 maybe_resize_hash_table (h
)
3950 struct Lisp_Hash_Table
*h
;
3952 if (NILP (h
->next_free
))
3954 int old_size
= HASH_TABLE_SIZE (h
);
3955 int i
, new_size
, index_size
;
3957 if (INTEGERP (h
->rehash_size
))
3958 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3960 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3961 new_size
= max (old_size
+ 1, new_size
);
3962 index_size
= next_almost_prime ((int)
3964 / XFLOATINT (h
->rehash_threshold
)));
3965 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3966 error ("Hash table too large to resize");
3968 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3969 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3970 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3971 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3973 /* Update the free list. Do it so that new entries are added at
3974 the end of the free list. This makes some operations like
3976 for (i
= old_size
; i
< new_size
- 1; ++i
)
3977 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3979 if (!NILP (h
->next_free
))
3981 Lisp_Object last
, next
;
3983 last
= h
->next_free
;
3984 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3988 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3991 XSETFASTINT (h
->next_free
, old_size
);
3994 for (i
= 0; i
< old_size
; ++i
)
3995 if (!NILP (HASH_HASH (h
, i
)))
3997 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3998 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3999 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4000 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4006 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4007 the hash code of KEY. Value is the index of the entry in H
4008 matching KEY, or -1 if not found. */
4011 hash_lookup (h
, key
, hash
)
4012 struct Lisp_Hash_Table
*h
;
4017 int start_of_bucket
;
4020 hash_code
= h
->hashfn (h
, key
);
4024 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4025 idx
= HASH_INDEX (h
, start_of_bucket
);
4027 /* We need not gcpro idx since it's either an integer or nil. */
4030 int i
= XFASTINT (idx
);
4031 if (EQ (key
, HASH_KEY (h
, i
))
4033 && h
->cmpfn (h
, key
, hash_code
,
4034 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4036 idx
= HASH_NEXT (h
, i
);
4039 return NILP (idx
) ? -1 : XFASTINT (idx
);
4043 /* Put an entry into hash table H that associates KEY with VALUE.
4044 HASH is a previously computed hash code of KEY.
4045 Value is the index of the entry in H matching KEY. */
4048 hash_put (h
, key
, value
, hash
)
4049 struct Lisp_Hash_Table
*h
;
4050 Lisp_Object key
, value
;
4053 int start_of_bucket
, i
;
4055 xassert ((hash
& ~VALMASK
) == 0);
4057 /* Increment count after resizing because resizing may fail. */
4058 maybe_resize_hash_table (h
);
4059 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4061 /* Store key/value in the key_and_value vector. */
4062 i
= XFASTINT (h
->next_free
);
4063 h
->next_free
= HASH_NEXT (h
, i
);
4064 HASH_KEY (h
, i
) = key
;
4065 HASH_VALUE (h
, i
) = value
;
4067 /* Remember its hash code. */
4068 HASH_HASH (h
, i
) = make_number (hash
);
4070 /* Add new entry to its collision chain. */
4071 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4072 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4073 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4078 /* Remove the entry matching KEY from hash table H, if there is one. */
4081 hash_remove (h
, key
)
4082 struct Lisp_Hash_Table
*h
;
4086 int start_of_bucket
;
4087 Lisp_Object idx
, prev
;
4089 hash_code
= h
->hashfn (h
, key
);
4090 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4091 idx
= HASH_INDEX (h
, start_of_bucket
);
4094 /* We need not gcpro idx, prev since they're either integers or nil. */
4097 int i
= XFASTINT (idx
);
4099 if (EQ (key
, HASH_KEY (h
, i
))
4101 && h
->cmpfn (h
, key
, hash_code
,
4102 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4104 /* Take entry out of collision chain. */
4106 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4108 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4110 /* Clear slots in key_and_value and add the slots to
4112 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4113 HASH_NEXT (h
, i
) = h
->next_free
;
4114 h
->next_free
= make_number (i
);
4115 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4116 xassert (XINT (h
->count
) >= 0);
4122 idx
= HASH_NEXT (h
, i
);
4128 /* Clear hash table H. */
4132 struct Lisp_Hash_Table
*h
;
4134 if (XFASTINT (h
->count
) > 0)
4136 int i
, size
= HASH_TABLE_SIZE (h
);
4138 for (i
= 0; i
< size
; ++i
)
4140 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4141 HASH_KEY (h
, i
) = Qnil
;
4142 HASH_VALUE (h
, i
) = Qnil
;
4143 HASH_HASH (h
, i
) = Qnil
;
4146 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4147 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4149 h
->next_free
= make_number (0);
4150 h
->count
= make_number (0);
4156 /************************************************************************
4158 ************************************************************************/
4160 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4161 entries from the table that don't survive the current GC.
4162 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4163 non-zero if anything was marked. */
4166 sweep_weak_table (h
, remove_entries_p
)
4167 struct Lisp_Hash_Table
*h
;
4168 int remove_entries_p
;
4170 int bucket
, n
, marked
;
4172 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4175 for (bucket
= 0; bucket
< n
; ++bucket
)
4177 Lisp_Object idx
, prev
;
4179 /* Follow collision chain, removing entries that
4180 don't survive this garbage collection. */
4181 idx
= HASH_INDEX (h
, bucket
);
4183 while (!GC_NILP (idx
))
4186 int i
= XFASTINT (idx
);
4188 int key_known_to_survive_p
, value_known_to_survive_p
;
4190 key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4191 value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4193 if (EQ (h
->weak
, Qkey
))
4194 remove_p
= !key_known_to_survive_p
;
4195 else if (EQ (h
->weak
, Qvalue
))
4196 remove_p
= !value_known_to_survive_p
;
4197 else if (EQ (h
->weak
, Qt
))
4198 remove_p
= !key_known_to_survive_p
|| !value_known_to_survive_p
;
4202 next
= HASH_NEXT (h
, i
);
4204 if (remove_entries_p
)
4208 /* Take out of collision chain. */
4210 HASH_INDEX (h
, i
) = next
;
4212 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4214 /* Add to free list. */
4215 HASH_NEXT (h
, i
) = h
->next_free
;
4218 /* Clear key, value, and hash. */
4219 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4220 HASH_HASH (h
, i
) = Qnil
;
4222 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4229 /* Make sure key and value survive. */
4230 if (!key_known_to_survive_p
)
4232 mark_object (&HASH_KEY (h
, i
));
4236 if (!value_known_to_survive_p
)
4238 mark_object (&HASH_VALUE (h
, i
));
4251 /* Remove elements from weak hash tables that don't survive the
4252 current garbage collection. Remove weak tables that don't survive
4253 from Vweak_hash_tables. Called from gc_sweep. */
4256 sweep_weak_hash_tables ()
4259 struct Lisp_Hash_Table
*h
, *prev
;
4262 /* Mark all keys and values that are in use. Keep on marking until
4263 there is no more change. This is necessary for cases like
4264 value-weak table A containing an entry X -> Y, where Y is used in a
4265 key-weak table B, Z -> Y. If B comes after A in the list of weak
4266 tables, X -> Y might be removed from A, although when looking at B
4267 one finds that it shouldn't. */
4271 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4273 h
= XHASH_TABLE (table
);
4274 if (h
->size
& ARRAY_MARK_FLAG
)
4275 marked
|= sweep_weak_table (h
, 0);
4280 /* Remove tables and entries that aren't used. */
4282 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4285 h
= XHASH_TABLE (table
);
4287 if (h
->size
& ARRAY_MARK_FLAG
)
4289 if (XFASTINT (h
->count
) > 0)
4290 sweep_weak_table (h
, 1);
4294 /* Table is not marked, and will thus be freed.
4295 Take it out of the list of weak hash tables. */
4297 prev
->next_weak
= h
->next_weak
;
4299 Vweak_hash_tables
= h
->next_weak
;
4306 /***********************************************************************
4307 Hash Code Computation
4308 ***********************************************************************/
4310 /* Maximum depth up to which to dive into Lisp structures. */
4312 #define SXHASH_MAX_DEPTH 3
4314 /* Maximum length up to which to take list and vector elements into
4317 #define SXHASH_MAX_LEN 7
4319 /* Combine two integers X and Y for hashing. */
4321 #define SXHASH_COMBINE(X, Y) \
4322 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4326 /* Return a hash for string PTR which has length LEN. */
4329 sxhash_string (ptr
, len
)
4333 unsigned char *p
= ptr
;
4334 unsigned char *end
= p
+ len
;
4343 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4346 return hash
& 07777777777;
4350 /* Return a hash for list LIST. DEPTH is the current depth in the
4351 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4354 sxhash_list (list
, depth
)
4361 if (depth
< SXHASH_MAX_DEPTH
)
4363 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4364 list
= XCDR (list
), ++i
)
4366 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4367 hash
= SXHASH_COMBINE (hash
, hash2
);
4374 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4375 the Lisp structure. */
4378 sxhash_vector (vec
, depth
)
4382 unsigned hash
= XVECTOR (vec
)->size
;
4385 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4386 for (i
= 0; i
< n
; ++i
)
4388 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4389 hash
= SXHASH_COMBINE (hash
, hash2
);
4396 /* Return a hash for bool-vector VECTOR. */
4399 sxhash_bool_vector (vec
)
4402 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4405 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4406 for (i
= 0; i
< n
; ++i
)
4407 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4413 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4414 structure. Value is an unsigned integer clipped to VALMASK. */
4423 if (depth
> SXHASH_MAX_DEPTH
)
4426 switch (XTYPE (obj
))
4433 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4434 XSYMBOL (obj
)->name
->size
);
4442 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4445 /* This can be everything from a vector to an overlay. */
4446 case Lisp_Vectorlike
:
4448 /* According to the CL HyperSpec, two arrays are equal only if
4449 they are `eq', except for strings and bit-vectors. In
4450 Emacs, this works differently. We have to compare element
4452 hash
= sxhash_vector (obj
, depth
);
4453 else if (BOOL_VECTOR_P (obj
))
4454 hash
= sxhash_bool_vector (obj
);
4456 /* Others are `equal' if they are `eq', so let's take their
4462 hash
= sxhash_list (obj
, depth
);
4467 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4468 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4469 for (hash
= 0; p
< e
; ++p
)
4470 hash
= SXHASH_COMBINE (hash
, *p
);
4478 return hash
& VALMASK
;
4483 /***********************************************************************
4485 ***********************************************************************/
4488 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4489 "Compute a hash code for OBJ and return it as integer.")
4493 unsigned hash
= sxhash (obj
, 0);;
4494 return make_number (hash
);
4498 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4499 "Create and return a new hash table.\n\
4500 Arguments are specified as keyword/argument pairs. The following\n\
4501 arguments are defined:\n\
4503 :TEST TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4504 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4505 User-supplied test and hash functions can be specified via\n\
4506 `define-hash-table-test'.\n\
4508 :SIZE SIZE -- A hint as to how many elements will be put in the table.\n\
4511 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4512 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4513 If it is a float, it must be > 1.0, and the new size is computed by\n\
4514 multiplying the old size with that factor. Default is 1.5.\n\
4516 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4517 Resize the hash table when ratio of the number of entries in the table.\n\
4520 :WEAKNESS WEAK -- WEAK must be one of nil, t, `key', or `value'.\n\
4521 If WEAK is not nil, the table returned is a weak table. Key/value\n\
4522 pairs are removed from a weak hash table when their key, value or both\n\
4523 (WEAK t) are otherwise unreferenced. Default is nil.")
4528 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4529 Lisp_Object user_test
, user_hash
;
4533 /* The vector `used' is used to keep track of arguments that
4534 have been consumed. */
4535 used
= (char *) alloca (nargs
* sizeof *used
);
4536 bzero (used
, nargs
* sizeof *used
);
4538 /* See if there's a `:test TEST' among the arguments. */
4539 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4540 test
= i
< 0 ? Qeql
: args
[i
];
4541 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4543 /* See if it is a user-defined test. */
4546 prop
= Fget (test
, Qhash_table_test
);
4547 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4548 Fsignal (Qerror
, list2 (build_string ("Illegal hash table test"),
4550 user_test
= Fnth (make_number (0), prop
);
4551 user_hash
= Fnth (make_number (1), prop
);
4554 user_test
= user_hash
= Qnil
;
4556 /* See if there's a `:size SIZE' argument. */
4557 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4558 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4559 if (!INTEGERP (size
) || XINT (size
) <= 0)
4561 list2 (build_string ("Illegal hash table size"),
4564 /* Look for `:rehash-size SIZE'. */
4565 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4566 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4567 if (!NUMBERP (rehash_size
)
4568 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4569 || XFLOATINT (rehash_size
) <= 1.0)
4571 list2 (build_string ("Illegal hash table rehash size"),
4574 /* Look for `:rehash-threshold THRESHOLD'. */
4575 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4576 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4577 if (!FLOATP (rehash_threshold
)
4578 || XFLOATINT (rehash_threshold
) <= 0.0
4579 || XFLOATINT (rehash_threshold
) > 1.0)
4581 list2 (build_string ("Illegal hash table rehash threshold"),
4584 /* Look for `:weakness WEAK'. */
4585 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4586 weak
= i
< 0 ? Qnil
: args
[i
];
4590 && !EQ (weak
, Qvalue
))
4591 Fsignal (Qerror
, list2 (build_string ("Illegal hash table weakness"),
4594 /* Now, all args should have been used up, or there's a problem. */
4595 for (i
= 0; i
< nargs
; ++i
)
4598 list2 (build_string ("Invalid argument list"), args
[i
]));
4600 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4601 user_test
, user_hash
);
4605 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4606 "Return a copy of hash table TABLE.")
4610 return copy_hash_table (check_hash_table (table
));
4614 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4615 "Create a new hash table.\n\
4616 Optional first argument TEST specifies how to compare keys in\n\
4617 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4618 is `eql'. New tests can be defined with `define-hash-table-test'.")
4622 Lisp_Object args
[2];
4625 return Fmake_hash_table (2, args
);
4629 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4630 "Return the number of elements in TABLE.")
4634 return check_hash_table (table
)->count
;
4638 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4639 Shash_table_rehash_size
, 1, 1, 0,
4640 "Return the current rehash size of TABLE.")
4644 return check_hash_table (table
)->rehash_size
;
4648 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4649 Shash_table_rehash_threshold
, 1, 1, 0,
4650 "Return the current rehash threshold of TABLE.")
4654 return check_hash_table (table
)->rehash_threshold
;
4658 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4659 "Return the size of TABLE.\n\
4660 The size can be used as an argument to `make-hash-table' to create\n\
4661 a hash table than can hold as many elements of TABLE holds\n\
4662 without need for resizing.")
4666 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4667 return make_number (HASH_TABLE_SIZE (h
));
4671 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4672 "Return the test TABLE uses.")
4676 return check_hash_table (table
)->test
;
4680 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4682 "Return the weakness of TABLE.")
4686 return check_hash_table (table
)->weak
;
4690 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4691 "Return t if OBJ is a Lisp hash table object.")
4695 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4699 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4700 "Clear hash table TABLE.")
4704 hash_clear (check_hash_table (table
));
4709 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4710 "Look up KEY in TABLE and return its associated value.\n\
4711 If KEY is not found, return DFLT which defaults to nil.")
4713 Lisp_Object key
, table
, dflt
;
4715 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4716 int i
= hash_lookup (h
, key
, NULL
);
4717 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4721 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4722 "Associate KEY with VALUE in hash table TABLE.\n\
4723 If KEY is already present in table, replace its current value with\n\
4726 Lisp_Object key
, value
, table
;
4728 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4732 i
= hash_lookup (h
, key
, &hash
);
4734 HASH_VALUE (h
, i
) = value
;
4736 hash_put (h
, key
, value
, hash
);
4742 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4743 "Remove KEY from TABLE.")
4745 Lisp_Object key
, table
;
4747 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4748 hash_remove (h
, key
);
4753 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4754 "Call FUNCTION for all entries in hash table TABLE.\n\
4755 FUNCTION is called with 2 arguments KEY and VALUE.")
4757 Lisp_Object function
, table
;
4759 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4760 Lisp_Object args
[3];
4763 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4764 if (!NILP (HASH_HASH (h
, i
)))
4767 args
[1] = HASH_KEY (h
, i
);
4768 args
[2] = HASH_VALUE (h
, i
);
4776 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4777 Sdefine_hash_table_test
, 3, 3, 0,
4778 "Define a new hash table test with name NAME, a symbol.\n\
4779 In hash tables create with NAME specified as test, use TEST to compare\n\
4780 keys, and HASH for computing hash codes of keys.\n\
4782 TEST must be a function taking two arguments and returning non-nil\n\
4783 if both arguments are the same. HASH must be a function taking\n\
4784 one argument and return an integer that is the hash code of the\n\
4785 argument. Hash code computation should use the whole value range of\n\
4786 integers, including negative integers.")
4788 Lisp_Object name
, test
, hash
;
4790 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4799 /* Hash table stuff. */
4800 Qhash_table_p
= intern ("hash-table-p");
4801 staticpro (&Qhash_table_p
);
4802 Qeq
= intern ("eq");
4804 Qeql
= intern ("eql");
4806 Qequal
= intern ("equal");
4807 staticpro (&Qequal
);
4808 QCtest
= intern (":test");
4809 staticpro (&QCtest
);
4810 QCsize
= intern (":size");
4811 staticpro (&QCsize
);
4812 QCrehash_size
= intern (":rehash-size");
4813 staticpro (&QCrehash_size
);
4814 QCrehash_threshold
= intern (":rehash-threshold");
4815 staticpro (&QCrehash_threshold
);
4816 QCweakness
= intern (":weakness");
4817 staticpro (&QCweakness
);
4818 Qkey
= intern ("key");
4820 Qvalue
= intern ("value");
4821 staticpro (&Qvalue
);
4822 Qhash_table_test
= intern ("hash-table-test");
4823 staticpro (&Qhash_table_test
);
4826 defsubr (&Smake_hash_table
);
4827 defsubr (&Scopy_hash_table
);
4828 defsubr (&Smakehash
);
4829 defsubr (&Shash_table_count
);
4830 defsubr (&Shash_table_rehash_size
);
4831 defsubr (&Shash_table_rehash_threshold
);
4832 defsubr (&Shash_table_size
);
4833 defsubr (&Shash_table_test
);
4834 defsubr (&Shash_table_weakness
);
4835 defsubr (&Shash_table_p
);
4836 defsubr (&Sclrhash
);
4837 defsubr (&Sgethash
);
4838 defsubr (&Sputhash
);
4839 defsubr (&Sremhash
);
4840 defsubr (&Smaphash
);
4841 defsubr (&Sdefine_hash_table_test
);
4843 Qstring_lessp
= intern ("string-lessp");
4844 staticpro (&Qstring_lessp
);
4845 Qprovide
= intern ("provide");
4846 staticpro (&Qprovide
);
4847 Qrequire
= intern ("require");
4848 staticpro (&Qrequire
);
4849 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4850 staticpro (&Qyes_or_no_p_history
);
4851 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4852 staticpro (&Qcursor_in_echo_area
);
4853 Qwidget_type
= intern ("widget-type");
4854 staticpro (&Qwidget_type
);
4856 staticpro (&string_char_byte_cache_string
);
4857 string_char_byte_cache_string
= Qnil
;
4859 Fset (Qyes_or_no_p_history
, Qnil
);
4861 DEFVAR_LISP ("features", &Vfeatures
,
4862 "A list of symbols which are the features of the executing emacs.\n\
4863 Used by `featurep' and `require', and altered by `provide'.");
4866 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4867 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
4868 This applies to y-or-n and yes-or-no questions asked by commands\n\
4869 invoked by mouse clicks and mouse menu items.");
4872 defsubr (&Sidentity
);
4875 defsubr (&Ssafe_length
);
4876 defsubr (&Sstring_bytes
);
4877 defsubr (&Sstring_equal
);
4878 defsubr (&Scompare_strings
);
4879 defsubr (&Sstring_lessp
);
4882 defsubr (&Svconcat
);
4883 defsubr (&Scopy_sequence
);
4884 defsubr (&Sstring_make_multibyte
);
4885 defsubr (&Sstring_make_unibyte
);
4886 defsubr (&Sstring_as_multibyte
);
4887 defsubr (&Sstring_as_unibyte
);
4888 defsubr (&Scopy_alist
);
4889 defsubr (&Ssubstring
);
4901 defsubr (&Snreverse
);
4902 defsubr (&Sreverse
);
4904 defsubr (&Splist_get
);
4906 defsubr (&Splist_put
);
4909 defsubr (&Sfillarray
);
4910 defsubr (&Schar_table_subtype
);
4911 defsubr (&Schar_table_parent
);
4912 defsubr (&Sset_char_table_parent
);
4913 defsubr (&Schar_table_extra_slot
);
4914 defsubr (&Sset_char_table_extra_slot
);
4915 defsubr (&Schar_table_range
);
4916 defsubr (&Sset_char_table_range
);
4917 defsubr (&Sset_char_table_default
);
4918 defsubr (&Soptimize_char_table
);
4919 defsubr (&Smap_char_table
);
4923 defsubr (&Smapconcat
);
4924 defsubr (&Sy_or_n_p
);
4925 defsubr (&Syes_or_no_p
);
4926 defsubr (&Sload_average
);
4927 defsubr (&Sfeaturep
);
4928 defsubr (&Srequire
);
4929 defsubr (&Sprovide
);
4930 defsubr (&Splist_member
);
4931 defsubr (&Swidget_put
);
4932 defsubr (&Swidget_get
);
4933 defsubr (&Swidget_apply
);
4934 defsubr (&Sbase64_encode_region
);
4935 defsubr (&Sbase64_decode_region
);
4936 defsubr (&Sbase64_encode_string
);
4937 defsubr (&Sbase64_decode_string
);
4944 Vweak_hash_tables
= Qnil
;