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)
829 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
831 this = args
[textprops
[argnum
].argnum
];
832 copy_text_properties (make_number (textprops
[argnum
].from
),
833 make_number (XSTRING (this)->size
), this,
834 make_number (textprops
[argnum
].to
), val
, Qnil
);
840 static Lisp_Object string_char_byte_cache_string
;
841 static int string_char_byte_cache_charpos
;
842 static int string_char_byte_cache_bytepos
;
845 clear_string_char_byte_cache ()
847 string_char_byte_cache_string
= Qnil
;
850 /* Return the character index corresponding to CHAR_INDEX in STRING. */
853 string_char_to_byte (string
, char_index
)
858 int best_below
, best_below_byte
;
859 int best_above
, best_above_byte
;
861 if (! STRING_MULTIBYTE (string
))
864 best_below
= best_below_byte
= 0;
865 best_above
= XSTRING (string
)->size
;
866 best_above_byte
= STRING_BYTES (XSTRING (string
));
868 if (EQ (string
, string_char_byte_cache_string
))
870 if (string_char_byte_cache_charpos
< char_index
)
872 best_below
= string_char_byte_cache_charpos
;
873 best_below_byte
= string_char_byte_cache_bytepos
;
877 best_above
= string_char_byte_cache_charpos
;
878 best_above_byte
= string_char_byte_cache_bytepos
;
882 if (char_index
- best_below
< best_above
- char_index
)
884 while (best_below
< char_index
)
887 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
888 best_below
, best_below_byte
);
891 i_byte
= best_below_byte
;
895 while (best_above
> char_index
)
897 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
898 unsigned char *pbeg
= pend
- best_above_byte
;
899 unsigned char *p
= pend
- 1;
902 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
903 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
904 if (bytes
== pend
- p
)
905 best_above_byte
-= bytes
;
906 else if (bytes
> pend
- p
)
907 best_above_byte
-= (pend
- p
);
913 i_byte
= best_above_byte
;
916 string_char_byte_cache_bytepos
= i_byte
;
917 string_char_byte_cache_charpos
= i
;
918 string_char_byte_cache_string
= string
;
923 /* Return the character index corresponding to BYTE_INDEX in STRING. */
926 string_byte_to_char (string
, byte_index
)
931 int best_below
, best_below_byte
;
932 int best_above
, best_above_byte
;
934 if (! STRING_MULTIBYTE (string
))
937 best_below
= best_below_byte
= 0;
938 best_above
= XSTRING (string
)->size
;
939 best_above_byte
= STRING_BYTES (XSTRING (string
));
941 if (EQ (string
, string_char_byte_cache_string
))
943 if (string_char_byte_cache_bytepos
< byte_index
)
945 best_below
= string_char_byte_cache_charpos
;
946 best_below_byte
= string_char_byte_cache_bytepos
;
950 best_above
= string_char_byte_cache_charpos
;
951 best_above_byte
= string_char_byte_cache_bytepos
;
955 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
957 while (best_below_byte
< byte_index
)
960 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
961 best_below
, best_below_byte
);
964 i_byte
= best_below_byte
;
968 while (best_above_byte
> byte_index
)
970 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
971 unsigned char *pbeg
= pend
- best_above_byte
;
972 unsigned char *p
= pend
- 1;
975 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
976 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
977 if (bytes
== pend
- p
)
978 best_above_byte
-= bytes
;
979 else if (bytes
> pend
- p
)
980 best_above_byte
-= (pend
- p
);
986 i_byte
= best_above_byte
;
989 string_char_byte_cache_bytepos
= i_byte
;
990 string_char_byte_cache_charpos
= i
;
991 string_char_byte_cache_string
= string
;
996 /* Convert STRING to a multibyte string.
997 Single-byte characters 0240 through 0377 are converted
998 by adding nonascii_insert_offset to each. */
1001 string_make_multibyte (string
)
1007 if (STRING_MULTIBYTE (string
))
1010 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1011 XSTRING (string
)->size
);
1012 /* If all the chars are ASCII, they won't need any more bytes
1013 once converted. In that case, we can return STRING itself. */
1014 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1017 buf
= (unsigned char *) alloca (nbytes
);
1018 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1021 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1024 /* Convert STRING to a single-byte string. */
1027 string_make_unibyte (string
)
1032 if (! STRING_MULTIBYTE (string
))
1035 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1037 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1040 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1043 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1045 "Return the multibyte equivalent of STRING.\n\
1046 The function `unibyte-char-to-multibyte' is used to convert\n\
1047 each unibyte character to a multibyte character.")
1051 CHECK_STRING (string
, 0);
1053 return string_make_multibyte (string
);
1056 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1058 "Return the unibyte equivalent of STRING.\n\
1059 Multibyte character codes are converted to unibyte\n\
1060 by using just the low 8 bits.")
1064 CHECK_STRING (string
, 0);
1066 return string_make_unibyte (string
);
1069 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1071 "Return a unibyte string with the same individual bytes as STRING.\n\
1072 If STRING is unibyte, the result is STRING itself.\n\
1073 Otherwise it is a newly created string, with no text properties.\n\
1074 If STRING is multibyte and contains a character of charset `binary',\n\
1075 it is converted to the corresponding single byte.")
1079 CHECK_STRING (string
, 0);
1081 if (STRING_MULTIBYTE (string
))
1083 int bytes
= STRING_BYTES (XSTRING (string
));
1084 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1086 bcopy (XSTRING (string
)->data
, str
, bytes
);
1087 bytes
= str_as_unibyte (str
, bytes
);
1088 string
= make_unibyte_string (str
, bytes
);
1094 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1096 "Return a multibyte string with the same individual bytes as STRING.\n\
1097 If STRING is multibyte, the result is STRING itself.\n\
1098 Otherwise it is a newly created string, with no text properties.\n\
1099 If STRING is unibyte and contains an individual 8-bit byte (i.e. not\n\
1100 part of multibyte form), it is converted to the corresponding\n\
1101 multibyte character of charset `binary'.")
1105 CHECK_STRING (string
, 0);
1107 if (! STRING_MULTIBYTE (string
))
1109 Lisp_Object new_string
;
1112 parse_str_as_multibyte (XSTRING (string
)->data
,
1113 STRING_BYTES (XSTRING (string
)),
1115 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1116 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1117 STRING_BYTES (XSTRING (string
)));
1118 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1119 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1120 STRING_BYTES (XSTRING (string
)), NULL
);
1121 string
= new_string
;
1122 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1127 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1128 "Return a copy of ALIST.\n\
1129 This is an alist which represents the same mapping from objects to objects,\n\
1130 but does not share the alist structure with ALIST.\n\
1131 The objects mapped (cars and cdrs of elements of the alist)\n\
1132 are shared, however.\n\
1133 Elements of ALIST that are not conses are also shared.")
1137 register Lisp_Object tem
;
1139 CHECK_LIST (alist
, 0);
1142 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1143 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1145 register Lisp_Object car
;
1149 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1154 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1155 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1156 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1157 If FROM or TO is negative, it counts from the end.\n\
1159 This function allows vectors as well as strings.")
1162 register Lisp_Object from
, to
;
1167 int from_char
, to_char
;
1168 int from_byte
, to_byte
;
1170 if (! (STRINGP (string
) || VECTORP (string
)))
1171 wrong_type_argument (Qarrayp
, string
);
1173 CHECK_NUMBER (from
, 1);
1175 if (STRINGP (string
))
1177 size
= XSTRING (string
)->size
;
1178 size_byte
= STRING_BYTES (XSTRING (string
));
1181 size
= XVECTOR (string
)->size
;
1186 to_byte
= size_byte
;
1190 CHECK_NUMBER (to
, 2);
1192 to_char
= XINT (to
);
1196 if (STRINGP (string
))
1197 to_byte
= string_char_to_byte (string
, to_char
);
1200 from_char
= XINT (from
);
1203 if (STRINGP (string
))
1204 from_byte
= string_char_to_byte (string
, from_char
);
1206 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1207 args_out_of_range_3 (string
, make_number (from_char
),
1208 make_number (to_char
));
1210 if (STRINGP (string
))
1212 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1213 to_char
- from_char
, to_byte
- from_byte
,
1214 STRING_MULTIBYTE (string
));
1215 copy_text_properties (make_number (from_char
), make_number (to_char
),
1216 string
, make_number (0), res
, Qnil
);
1219 res
= Fvector (to_char
- from_char
,
1220 XVECTOR (string
)->contents
+ from_char
);
1225 /* Extract a substring of STRING, giving start and end positions
1226 both in characters and in bytes. */
1229 substring_both (string
, from
, from_byte
, to
, to_byte
)
1231 int from
, from_byte
, to
, to_byte
;
1237 if (! (STRINGP (string
) || VECTORP (string
)))
1238 wrong_type_argument (Qarrayp
, string
);
1240 if (STRINGP (string
))
1242 size
= XSTRING (string
)->size
;
1243 size_byte
= STRING_BYTES (XSTRING (string
));
1246 size
= XVECTOR (string
)->size
;
1248 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1249 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1251 if (STRINGP (string
))
1253 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1254 to
- from
, to_byte
- from_byte
,
1255 STRING_MULTIBYTE (string
));
1256 copy_text_properties (make_number (from
), make_number (to
),
1257 string
, make_number (0), res
, Qnil
);
1260 res
= Fvector (to
- from
,
1261 XVECTOR (string
)->contents
+ from
);
1266 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1267 "Take cdr N times on LIST, returns the result.")
1270 register Lisp_Object list
;
1272 register int i
, num
;
1273 CHECK_NUMBER (n
, 0);
1275 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1279 wrong_type_argument (Qlistp
, list
);
1285 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1286 "Return the Nth element of LIST.\n\
1287 N counts from zero. If LIST is not that long, nil is returned.")
1289 Lisp_Object n
, list
;
1291 return Fcar (Fnthcdr (n
, list
));
1294 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1295 "Return element of SEQUENCE at index N.")
1297 register Lisp_Object sequence
, n
;
1299 CHECK_NUMBER (n
, 0);
1302 if (CONSP (sequence
) || NILP (sequence
))
1303 return Fcar (Fnthcdr (n
, sequence
));
1304 else if (STRINGP (sequence
) || VECTORP (sequence
)
1305 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1306 return Faref (sequence
, n
);
1308 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1312 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1313 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1314 The value is actually the tail of LIST whose car is ELT.")
1316 register Lisp_Object elt
;
1319 register Lisp_Object tail
;
1320 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1322 register Lisp_Object tem
;
1324 wrong_type_argument (Qlistp
, list
);
1326 if (! NILP (Fequal (elt
, tem
)))
1333 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1334 "Return non-nil if ELT is an element of LIST.\n\
1335 Comparison done with EQ. The value is actually the tail of LIST\n\
1338 Lisp_Object elt
, list
;
1342 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1346 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1350 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1357 if (!CONSP (list
) && !NILP (list
))
1358 list
= wrong_type_argument (Qlistp
, list
);
1363 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1364 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1365 The value is actually the element of LIST whose car is KEY.\n\
1366 Elements of LIST that are not conses are ignored.")
1368 Lisp_Object key
, list
;
1375 || (CONSP (XCAR (list
))
1376 && EQ (XCAR (XCAR (list
)), key
)))
1381 || (CONSP (XCAR (list
))
1382 && EQ (XCAR (XCAR (list
)), key
)))
1387 || (CONSP (XCAR (list
))
1388 && EQ (XCAR (XCAR (list
)), key
)))
1396 result
= XCAR (list
);
1397 else if (NILP (list
))
1400 result
= wrong_type_argument (Qlistp
, list
);
1405 /* Like Fassq but never report an error and do not allow quits.
1406 Use only on lists known never to be circular. */
1409 assq_no_quit (key
, list
)
1410 Lisp_Object key
, list
;
1413 && (!CONSP (XCAR (list
))
1414 || !EQ (XCAR (XCAR (list
)), key
)))
1417 return CONSP (list
) ? XCAR (list
) : Qnil
;
1420 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1421 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1422 The value is actually the element of LIST whose car equals KEY.")
1424 Lisp_Object key
, list
;
1426 Lisp_Object result
, car
;
1431 || (CONSP (XCAR (list
))
1432 && (car
= XCAR (XCAR (list
)),
1433 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1438 || (CONSP (XCAR (list
))
1439 && (car
= XCAR (XCAR (list
)),
1440 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1445 || (CONSP (XCAR (list
))
1446 && (car
= XCAR (XCAR (list
)),
1447 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1455 result
= XCAR (list
);
1456 else if (NILP (list
))
1459 result
= wrong_type_argument (Qlistp
, list
);
1464 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1465 "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
1466 The value is actually the element of LIST whose cdr is KEY.")
1468 register Lisp_Object key
;
1476 || (CONSP (XCAR (list
))
1477 && EQ (XCDR (XCAR (list
)), key
)))
1482 || (CONSP (XCAR (list
))
1483 && EQ (XCDR (XCAR (list
)), key
)))
1488 || (CONSP (XCAR (list
))
1489 && EQ (XCDR (XCAR (list
)), key
)))
1498 else if (CONSP (list
))
1499 result
= XCAR (list
);
1501 result
= wrong_type_argument (Qlistp
, list
);
1506 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1507 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1508 The value is actually the element of LIST whose cdr equals KEY.")
1510 Lisp_Object key
, list
;
1512 Lisp_Object result
, cdr
;
1517 || (CONSP (XCAR (list
))
1518 && (cdr
= XCDR (XCAR (list
)),
1519 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1524 || (CONSP (XCAR (list
))
1525 && (cdr
= XCDR (XCAR (list
)),
1526 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1531 || (CONSP (XCAR (list
))
1532 && (cdr
= XCDR (XCAR (list
)),
1533 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1541 result
= XCAR (list
);
1542 else if (NILP (list
))
1545 result
= wrong_type_argument (Qlistp
, list
);
1550 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1551 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1552 The modified LIST is returned. Comparison is done with `eq'.\n\
1553 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1554 therefore, write `(setq foo (delq element foo))'\n\
1555 to be sure of changing the value of `foo'.")
1557 register Lisp_Object elt
;
1560 register Lisp_Object tail
, prev
;
1561 register Lisp_Object tem
;
1565 while (!NILP (tail
))
1568 wrong_type_argument (Qlistp
, list
);
1575 Fsetcdr (prev
, XCDR (tail
));
1585 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1586 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1587 The modified LIST is returned. Comparison is done with `equal'.\n\
1588 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1589 it is simply using a different list.\n\
1590 Therefore, write `(setq foo (delete element foo))'\n\
1591 to be sure of changing the value of `foo'.")
1593 register Lisp_Object elt
;
1596 register Lisp_Object tail
, prev
;
1597 register Lisp_Object tem
;
1601 while (!NILP (tail
))
1604 wrong_type_argument (Qlistp
, list
);
1606 if (! NILP (Fequal (elt
, tem
)))
1611 Fsetcdr (prev
, XCDR (tail
));
1621 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1622 "Reverse LIST by modifying cdr pointers.\n\
1623 Returns the beginning of the reversed list.")
1627 register Lisp_Object prev
, tail
, next
;
1629 if (NILP (list
)) return list
;
1632 while (!NILP (tail
))
1636 wrong_type_argument (Qlistp
, list
);
1638 Fsetcdr (tail
, prev
);
1645 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1646 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1647 See also the function `nreverse', which is used more often.")
1653 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1654 new = Fcons (XCAR (list
), new);
1656 wrong_type_argument (Qconsp
, list
);
1660 Lisp_Object
merge ();
1662 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1663 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1664 Returns the sorted list. LIST is modified by side effects.\n\
1665 PREDICATE is called with two elements of LIST, and should return T\n\
1666 if the first element is \"less\" than the second.")
1668 Lisp_Object list
, predicate
;
1670 Lisp_Object front
, back
;
1671 register Lisp_Object len
, tem
;
1672 struct gcpro gcpro1
, gcpro2
;
1673 register int length
;
1676 len
= Flength (list
);
1677 length
= XINT (len
);
1681 XSETINT (len
, (length
/ 2) - 1);
1682 tem
= Fnthcdr (len
, list
);
1684 Fsetcdr (tem
, Qnil
);
1686 GCPRO2 (front
, back
);
1687 front
= Fsort (front
, predicate
);
1688 back
= Fsort (back
, predicate
);
1690 return merge (front
, back
, predicate
);
1694 merge (org_l1
, org_l2
, pred
)
1695 Lisp_Object org_l1
, org_l2
;
1699 register Lisp_Object tail
;
1701 register Lisp_Object l1
, l2
;
1702 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1709 /* It is sufficient to protect org_l1 and org_l2.
1710 When l1 and l2 are updated, we copy the new values
1711 back into the org_ vars. */
1712 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1732 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1748 Fsetcdr (tail
, tem
);
1754 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1755 "Extract a value from a property list.\n\
1756 PLIST is a property list, which is a list of the form\n\
1757 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1758 corresponding to the given PROP, or nil if PROP is not\n\
1759 one of the properties on the list.")
1762 register Lisp_Object prop
;
1764 register Lisp_Object tail
;
1765 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCDR (tail
)))
1767 register Lisp_Object tem
;
1770 return Fcar (XCDR (tail
));
1775 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1776 "Return the value of SYMBOL's PROPNAME property.\n\
1777 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1779 Lisp_Object symbol
, propname
;
1781 CHECK_SYMBOL (symbol
, 0);
1782 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1785 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1786 "Change value in PLIST of PROP to VAL.\n\
1787 PLIST is a property list, which is a list of the form\n\
1788 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1789 If PROP is already a property on the list, its value is set to VAL,\n\
1790 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1791 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1792 The PLIST is modified by side effects.")
1795 register Lisp_Object prop
;
1798 register Lisp_Object tail
, prev
;
1799 Lisp_Object newcell
;
1801 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1802 tail
= XCDR (XCDR (tail
)))
1804 if (EQ (prop
, XCAR (tail
)))
1806 Fsetcar (XCDR (tail
), val
);
1811 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1815 Fsetcdr (XCDR (prev
), newcell
);
1819 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1820 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1821 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1822 (symbol
, propname
, value
)
1823 Lisp_Object symbol
, propname
, value
;
1825 CHECK_SYMBOL (symbol
, 0);
1826 XSYMBOL (symbol
)->plist
1827 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1831 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1832 "Return t if two Lisp objects have similar structure and contents.\n\
1833 They must have the same data type.\n\
1834 Conses are compared by comparing the cars and the cdrs.\n\
1835 Vectors and strings are compared element by element.\n\
1836 Numbers are compared by value, but integers cannot equal floats.\n\
1837 (Use `=' if you want integers and floats to be able to be equal.)\n\
1838 Symbols must match exactly.")
1840 register Lisp_Object o1
, o2
;
1842 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1846 internal_equal (o1
, o2
, depth
)
1847 register Lisp_Object o1
, o2
;
1851 error ("Stack overflow in equal");
1857 if (XTYPE (o1
) != XTYPE (o2
))
1863 return (extract_float (o1
) == extract_float (o2
));
1866 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1873 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1877 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1879 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1882 o1
= XOVERLAY (o1
)->plist
;
1883 o2
= XOVERLAY (o2
)->plist
;
1888 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1889 && (XMARKER (o1
)->buffer
== 0
1890 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1894 case Lisp_Vectorlike
:
1896 register int i
, size
;
1897 size
= XVECTOR (o1
)->size
;
1898 /* Pseudovectors have the type encoded in the size field, so this test
1899 actually checks that the objects have the same type as well as the
1901 if (XVECTOR (o2
)->size
!= size
)
1903 /* Boolvectors are compared much like strings. */
1904 if (BOOL_VECTOR_P (o1
))
1907 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1909 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1911 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1916 if (WINDOW_CONFIGURATIONP (o1
))
1917 return compare_window_configurations (o1
, o2
, 0);
1919 /* Aside from them, only true vectors, char-tables, and compiled
1920 functions are sensible to compare, so eliminate the others now. */
1921 if (size
& PSEUDOVECTOR_FLAG
)
1923 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1925 size
&= PSEUDOVECTOR_SIZE_MASK
;
1927 for (i
= 0; i
< size
; i
++)
1930 v1
= XVECTOR (o1
)->contents
[i
];
1931 v2
= XVECTOR (o2
)->contents
[i
];
1932 if (!internal_equal (v1
, v2
, depth
+ 1))
1940 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1942 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1944 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1945 STRING_BYTES (XSTRING (o1
))))
1952 extern Lisp_Object
Fmake_char_internal ();
1954 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1955 "Store each element of ARRAY with ITEM.\n\
1956 ARRAY is a vector, string, char-table, or bool-vector.")
1958 Lisp_Object array
, item
;
1960 register int size
, index
, charval
;
1962 if (VECTORP (array
))
1964 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1965 size
= XVECTOR (array
)->size
;
1966 for (index
= 0; index
< size
; index
++)
1969 else if (CHAR_TABLE_P (array
))
1971 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1972 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1973 for (index
= 0; index
< size
; index
++)
1975 XCHAR_TABLE (array
)->defalt
= Qnil
;
1977 else if (STRINGP (array
))
1979 register unsigned char *p
= XSTRING (array
)->data
;
1980 CHECK_NUMBER (item
, 1);
1981 charval
= XINT (item
);
1982 size
= XSTRING (array
)->size
;
1983 if (STRING_MULTIBYTE (array
))
1985 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1986 int len
= CHAR_STRING (charval
, str
);
1987 int size_byte
= STRING_BYTES (XSTRING (array
));
1988 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
1991 if (size
!= size_byte
)
1994 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
1995 if (len
!= this_len
)
1996 error ("Attempt to change byte length of a string");
1999 for (i
= 0; i
< size_byte
; i
++)
2000 *p
++ = str
[i
% len
];
2003 for (index
= 0; index
< size
; index
++)
2006 else if (BOOL_VECTOR_P (array
))
2008 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2010 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2012 charval
= (! NILP (item
) ? -1 : 0);
2013 for (index
= 0; index
< size_in_chars
; index
++)
2018 array
= wrong_type_argument (Qarrayp
, array
);
2024 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2026 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
2028 Lisp_Object char_table
;
2030 CHECK_CHAR_TABLE (char_table
, 0);
2032 return XCHAR_TABLE (char_table
)->purpose
;
2035 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2037 "Return the parent char-table of CHAR-TABLE.\n\
2038 The value is either nil or another char-table.\n\
2039 If CHAR-TABLE holds nil for a given character,\n\
2040 then the actual applicable value is inherited from the parent char-table\n\
2041 \(or from its parents, if necessary).")
2043 Lisp_Object char_table
;
2045 CHECK_CHAR_TABLE (char_table
, 0);
2047 return XCHAR_TABLE (char_table
)->parent
;
2050 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2052 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
2053 PARENT must be either nil or another char-table.")
2054 (char_table
, parent
)
2055 Lisp_Object char_table
, parent
;
2059 CHECK_CHAR_TABLE (char_table
, 0);
2063 CHECK_CHAR_TABLE (parent
, 0);
2065 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2066 if (EQ (temp
, char_table
))
2067 error ("Attempt to make a chartable be its own parent");
2070 XCHAR_TABLE (char_table
)->parent
= parent
;
2075 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2077 "Return the value of CHAR-TABLE's extra-slot number N.")
2079 Lisp_Object char_table
, n
;
2081 CHECK_CHAR_TABLE (char_table
, 1);
2082 CHECK_NUMBER (n
, 2);
2084 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2085 args_out_of_range (char_table
, n
);
2087 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2090 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2091 Sset_char_table_extra_slot
,
2093 "Set CHAR-TABLE's extra-slot number N to VALUE.")
2094 (char_table
, n
, value
)
2095 Lisp_Object char_table
, n
, value
;
2097 CHECK_CHAR_TABLE (char_table
, 1);
2098 CHECK_NUMBER (n
, 2);
2100 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2101 args_out_of_range (char_table
, n
);
2103 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2106 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2108 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
2109 RANGE should be nil (for the default value)\n\
2110 a vector which identifies a character set or a row of a character set,\n\
2111 a character set name, or a character code.")
2113 Lisp_Object char_table
, range
;
2115 CHECK_CHAR_TABLE (char_table
, 0);
2117 if (EQ (range
, Qnil
))
2118 return XCHAR_TABLE (char_table
)->defalt
;
2119 else if (INTEGERP (range
))
2120 return Faref (char_table
, range
);
2121 else if (SYMBOLP (range
))
2123 Lisp_Object charset_info
;
2125 charset_info
= Fget (range
, Qcharset
);
2126 CHECK_VECTOR (charset_info
, 0);
2128 return Faref (char_table
,
2129 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2132 else if (VECTORP (range
))
2134 if (XVECTOR (range
)->size
== 1)
2135 return Faref (char_table
,
2136 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2139 int size
= XVECTOR (range
)->size
;
2140 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2141 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2142 size
<= 1 ? Qnil
: val
[1],
2143 size
<= 2 ? Qnil
: val
[2]);
2144 return Faref (char_table
, ch
);
2148 error ("Invalid RANGE argument to `char-table-range'");
2152 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2154 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2155 RANGE should be t (for all characters), nil (for the default value)\n\
2156 a vector which identifies a character set or a row of a character set,\n\
2157 a coding system, or a character code.")
2158 (char_table
, range
, value
)
2159 Lisp_Object char_table
, range
, value
;
2163 CHECK_CHAR_TABLE (char_table
, 0);
2166 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2167 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2168 else if (EQ (range
, Qnil
))
2169 XCHAR_TABLE (char_table
)->defalt
= value
;
2170 else if (SYMBOLP (range
))
2172 Lisp_Object charset_info
;
2174 charset_info
= Fget (range
, Qcharset
);
2175 CHECK_VECTOR (charset_info
, 0);
2177 return Faset (char_table
,
2178 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2182 else if (INTEGERP (range
))
2183 Faset (char_table
, range
, value
);
2184 else if (VECTORP (range
))
2186 if (XVECTOR (range
)->size
== 1)
2187 return Faset (char_table
,
2188 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2192 int size
= XVECTOR (range
)->size
;
2193 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2194 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2195 size
<= 1 ? Qnil
: val
[1],
2196 size
<= 2 ? Qnil
: val
[2]);
2197 return Faset (char_table
, ch
, value
);
2201 error ("Invalid RANGE argument to `set-char-table-range'");
2206 DEFUN ("set-char-table-default", Fset_char_table_default
,
2207 Sset_char_table_default
, 3, 3, 0,
2208 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2209 The generic character specifies the group of characters.\n\
2210 See also the documentation of make-char.")
2211 (char_table
, ch
, value
)
2212 Lisp_Object char_table
, ch
, value
;
2214 int c
, charset
, code1
, code2
;
2217 CHECK_CHAR_TABLE (char_table
, 0);
2218 CHECK_NUMBER (ch
, 1);
2221 SPLIT_CHAR (c
, charset
, code1
, code2
);
2223 /* Since we may want to set the default value for a character set
2224 not yet defined, we check only if the character set is in the
2225 valid range or not, instead of it is already defined or not. */
2226 if (! CHARSET_VALID_P (charset
))
2227 invalid_character (c
);
2229 if (charset
== CHARSET_ASCII
)
2230 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2232 /* Even if C is not a generic char, we had better behave as if a
2233 generic char is specified. */
2234 if (CHARSET_DIMENSION (charset
) == 1)
2236 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2239 if (SUB_CHAR_TABLE_P (temp
))
2240 XCHAR_TABLE (temp
)->defalt
= value
;
2242 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2246 if (! SUB_CHAR_TABLE_P (char_table
))
2247 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2248 = make_sub_char_table (temp
));
2249 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2250 if (SUB_CHAR_TABLE_P (temp
))
2251 XCHAR_TABLE (temp
)->defalt
= value
;
2253 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2257 /* Look up the element in TABLE at index CH,
2258 and return it as an integer.
2259 If the element is nil, return CH itself.
2260 (Actually we do that for any non-integer.) */
2263 char_table_translate (table
, ch
)
2268 value
= Faref (table
, make_number (ch
));
2269 if (! INTEGERP (value
))
2271 return XINT (value
);
2275 optimize_sub_char_table (table
, chars
)
2283 from
= 33, to
= 127;
2285 from
= 32, to
= 128;
2287 if (!SUB_CHAR_TABLE_P (*table
))
2289 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2290 for (; from
< to
; from
++)
2291 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2296 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2298 "Optimize char table TABLE.")
2306 CHECK_CHAR_TABLE (table
, 0);
2308 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2310 elt
= XCHAR_TABLE (table
)->contents
[i
];
2311 if (!SUB_CHAR_TABLE_P (elt
))
2313 dim
= CHARSET_DIMENSION (i
);
2315 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2316 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2317 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2323 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2324 character or group of characters that share a value.
2325 DEPTH is the current depth in the originally specified
2326 chartable, and INDICES contains the vector indices
2327 for the levels our callers have descended.
2329 ARG is passed to C_FUNCTION when that is called. */
2332 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2333 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2334 Lisp_Object function
, subtable
, arg
, *indices
;
2341 /* At first, handle ASCII and 8-bit European characters. */
2342 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2344 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2346 (*c_function
) (arg
, make_number (i
), elt
);
2348 call2 (function
, make_number (i
), elt
);
2350 #if 0 /* If the char table has entries for higher characters,
2351 we should report them. */
2352 if (NILP (current_buffer
->enable_multibyte_characters
))
2355 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2359 int charset
= XFASTINT (indices
[0]) - 128;
2362 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2363 if (CHARSET_CHARS (charset
) == 94)
2372 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2373 XSETFASTINT (indices
[depth
], i
);
2374 charset
= XFASTINT (indices
[0]) - 128;
2376 && (!CHARSET_DEFINED_P (charset
)
2377 || charset
== CHARSET_8_BIT_CONTROL
2378 || charset
== CHARSET_8_BIT_GRAPHIC
))
2381 if (SUB_CHAR_TABLE_P (elt
))
2384 error ("Too deep char table");
2385 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2392 elt
= XCHAR_TABLE (subtable
)->defalt
;
2393 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2394 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2395 c
= MAKE_CHAR (charset
, c1
, c2
);
2397 (*c_function
) (arg
, make_number (c
), elt
);
2399 call2 (function
, make_number (c
), elt
);
2404 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2406 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2407 FUNCTION is called with two arguments--a key and a value.\n\
2408 The key is always a possible IDX argument to `aref'.")
2409 (function
, char_table
)
2410 Lisp_Object function
, char_table
;
2412 /* The depth of char table is at most 3. */
2413 Lisp_Object indices
[3];
2415 CHECK_CHAR_TABLE (char_table
, 1);
2417 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2427 Lisp_Object args
[2];
2430 return Fnconc (2, args
);
2432 return Fnconc (2, &s1
);
2433 #endif /* NO_ARG_ARRAY */
2436 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2437 "Concatenate any number of lists by altering them.\n\
2438 Only the last argument is not altered, and need not be a list.")
2443 register int argnum
;
2444 register Lisp_Object tail
, tem
, val
;
2448 for (argnum
= 0; argnum
< nargs
; argnum
++)
2451 if (NILP (tem
)) continue;
2456 if (argnum
+ 1 == nargs
) break;
2459 tem
= wrong_type_argument (Qlistp
, tem
);
2468 tem
= args
[argnum
+ 1];
2469 Fsetcdr (tail
, tem
);
2471 args
[argnum
+ 1] = tail
;
2477 /* This is the guts of all mapping functions.
2478 Apply FN to each element of SEQ, one by one,
2479 storing the results into elements of VALS, a C vector of Lisp_Objects.
2480 LENI is the length of VALS, which should also be the length of SEQ. */
2483 mapcar1 (leni
, vals
, fn
, seq
)
2486 Lisp_Object fn
, seq
;
2488 register Lisp_Object tail
;
2491 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2495 /* Don't let vals contain any garbage when GC happens. */
2496 for (i
= 0; i
< leni
; i
++)
2499 GCPRO3 (dummy
, fn
, seq
);
2501 gcpro1
.nvars
= leni
;
2505 /* We need not explicitly protect `tail' because it is used only on lists, and
2506 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2510 for (i
= 0; i
< leni
; i
++)
2512 dummy
= XVECTOR (seq
)->contents
[i
];
2513 dummy
= call1 (fn
, dummy
);
2518 else if (BOOL_VECTOR_P (seq
))
2520 for (i
= 0; i
< leni
; i
++)
2523 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2524 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2529 dummy
= call1 (fn
, dummy
);
2534 else if (STRINGP (seq
))
2538 for (i
= 0, i_byte
= 0; i
< leni
;)
2543 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2544 XSETFASTINT (dummy
, c
);
2545 dummy
= call1 (fn
, dummy
);
2547 vals
[i_before
] = dummy
;
2550 else /* Must be a list, since Flength did not get an error */
2553 for (i
= 0; i
< leni
; i
++)
2555 dummy
= call1 (fn
, Fcar (tail
));
2565 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2566 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2567 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2568 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2569 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2570 (function
, sequence
, separator
)
2571 Lisp_Object function
, sequence
, separator
;
2576 register Lisp_Object
*args
;
2578 struct gcpro gcpro1
;
2580 len
= Flength (sequence
);
2582 nargs
= leni
+ leni
- 1;
2583 if (nargs
< 0) return build_string ("");
2585 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2588 mapcar1 (leni
, args
, function
, sequence
);
2591 for (i
= leni
- 1; i
>= 0; i
--)
2592 args
[i
+ i
] = args
[i
];
2594 for (i
= 1; i
< nargs
; i
+= 2)
2595 args
[i
] = separator
;
2597 return Fconcat (nargs
, args
);
2600 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2601 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2602 The result is a list just as long as SEQUENCE.\n\
2603 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2604 (function
, sequence
)
2605 Lisp_Object function
, sequence
;
2607 register Lisp_Object len
;
2609 register Lisp_Object
*args
;
2611 len
= Flength (sequence
);
2612 leni
= XFASTINT (len
);
2613 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2615 mapcar1 (leni
, args
, function
, sequence
);
2617 return Flist (leni
, args
);
2620 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2621 "Apply FUNCTION to each element of SEQUENCE for side effects only.\n\
2622 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.\n\
2623 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2624 (function
, sequence
)
2625 Lisp_Object function
, sequence
;
2629 leni
= XFASTINT (Flength (sequence
));
2630 mapcar1 (leni
, 0, function
, sequence
);
2635 /* Anything that calls this function must protect from GC! */
2637 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2638 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2639 Takes one argument, which is the string to display to ask the question.\n\
2640 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2641 No confirmation of the answer is requested; a single character is enough.\n\
2642 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2643 the bindings in `query-replace-map'; see the documentation of that variable\n\
2644 for more information. In this case, the useful bindings are `act', `skip',\n\
2645 `recenter', and `quit'.\)\n\
2647 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2652 register Lisp_Object obj
, key
, def
, map
;
2653 register int answer
;
2654 Lisp_Object xprompt
;
2655 Lisp_Object args
[2];
2656 struct gcpro gcpro1
, gcpro2
;
2657 int count
= specpdl_ptr
- specpdl
;
2659 specbind (Qcursor_in_echo_area
, Qt
);
2661 map
= Fsymbol_value (intern ("query-replace-map"));
2663 CHECK_STRING (prompt
, 0);
2665 GCPRO2 (prompt
, xprompt
);
2667 #ifdef HAVE_X_WINDOWS
2668 if (display_busy_cursor_p
)
2669 cancel_busy_cursor ();
2676 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2680 Lisp_Object pane
, menu
;
2681 redisplay_preserve_echo_area ();
2682 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2683 Fcons (Fcons (build_string ("No"), Qnil
),
2685 menu
= Fcons (prompt
, pane
);
2686 obj
= Fx_popup_dialog (Qt
, menu
);
2687 answer
= !NILP (obj
);
2690 #endif /* HAVE_MENUS */
2691 cursor_in_echo_area
= 1;
2692 choose_minibuf_frame ();
2693 message_with_string ("%s(y or n) ", xprompt
, 0);
2695 if (minibuffer_auto_raise
)
2697 Lisp_Object mini_frame
;
2699 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2701 Fraise_frame (mini_frame
);
2704 obj
= read_filtered_event (1, 0, 0, 0);
2705 cursor_in_echo_area
= 0;
2706 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2709 key
= Fmake_vector (make_number (1), obj
);
2710 def
= Flookup_key (map
, key
, Qt
);
2712 if (EQ (def
, intern ("skip")))
2717 else if (EQ (def
, intern ("act")))
2722 else if (EQ (def
, intern ("recenter")))
2728 else if (EQ (def
, intern ("quit")))
2730 /* We want to exit this command for exit-prefix,
2731 and this is the only way to do it. */
2732 else if (EQ (def
, intern ("exit-prefix")))
2737 /* If we don't clear this, then the next call to read_char will
2738 return quit_char again, and we'll enter an infinite loop. */
2743 if (EQ (xprompt
, prompt
))
2745 args
[0] = build_string ("Please answer y or n. ");
2747 xprompt
= Fconcat (2, args
);
2752 if (! noninteractive
)
2754 cursor_in_echo_area
= -1;
2755 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2759 unbind_to (count
, Qnil
);
2760 return answer
? Qt
: Qnil
;
2763 /* This is how C code calls `yes-or-no-p' and allows the user
2766 Anything that calls this function must protect from GC! */
2769 do_yes_or_no_p (prompt
)
2772 return call1 (intern ("yes-or-no-p"), prompt
);
2775 /* Anything that calls this function must protect from GC! */
2777 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2778 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2779 Takes one argument, which is the string to display to ask the question.\n\
2780 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2781 The user must confirm the answer with RET,\n\
2782 and can edit it until it has been confirmed.\n\
2784 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2789 register Lisp_Object ans
;
2790 Lisp_Object args
[2];
2791 struct gcpro gcpro1
;
2793 CHECK_STRING (prompt
, 0);
2796 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2800 Lisp_Object pane
, menu
, obj
;
2801 redisplay_preserve_echo_area ();
2802 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2803 Fcons (Fcons (build_string ("No"), Qnil
),
2806 menu
= Fcons (prompt
, pane
);
2807 obj
= Fx_popup_dialog (Qt
, menu
);
2811 #endif /* HAVE_MENUS */
2814 args
[1] = build_string ("(yes or no) ");
2815 prompt
= Fconcat (2, args
);
2821 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2822 Qyes_or_no_p_history
, Qnil
,
2824 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2829 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2837 message ("Please answer yes or no.");
2838 Fsleep_for (make_number (2), Qnil
);
2842 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2843 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2844 Each of the three load averages is multiplied by 100,\n\
2845 then converted to integer.\n\
2846 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2847 These floats are not multiplied by 100.\n\n\
2848 If the 5-minute or 15-minute load averages are not available, return a\n\
2849 shortened list, containing only those averages which are available.")
2851 Lisp_Object use_floats
;
2854 int loads
= getloadavg (load_ave
, 3);
2855 Lisp_Object ret
= Qnil
;
2858 error ("load-average not implemented for this operating system");
2862 Lisp_Object load
= (NILP (use_floats
) ?
2863 make_number ((int) (100.0 * load_ave
[loads
]))
2864 : make_float (load_ave
[loads
]));
2865 ret
= Fcons (load
, ret
);
2871 Lisp_Object Vfeatures
;
2873 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2874 "Returns t if FEATURE is present in this Emacs.\n\
2875 Use this to conditionalize execution of lisp code based on the presence or\n\
2876 absence of emacs or environment extensions.\n\
2877 Use `provide' to declare that a feature is available.\n\
2878 This function looks at the value of the variable `features'.")
2880 Lisp_Object feature
;
2882 register Lisp_Object tem
;
2883 CHECK_SYMBOL (feature
, 0);
2884 tem
= Fmemq (feature
, Vfeatures
);
2885 return (NILP (tem
)) ? Qnil
: Qt
;
2888 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2889 "Announce that FEATURE is a feature of the current Emacs.")
2891 Lisp_Object feature
;
2893 register Lisp_Object tem
;
2894 CHECK_SYMBOL (feature
, 0);
2895 if (!NILP (Vautoload_queue
))
2896 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2897 tem
= Fmemq (feature
, Vfeatures
);
2899 Vfeatures
= Fcons (feature
, Vfeatures
);
2900 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2904 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2905 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2906 If FEATURE is not a member of the list `features', then the feature\n\
2907 is not loaded; so load the file FILENAME.\n\
2908 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2909 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2910 If the optional third argument NOERROR is non-nil,\n\
2911 then return nil if the file is not found.\n\
2912 Normally the return value is FEATURE.")
2913 (feature
, file_name
, noerror
)
2914 Lisp_Object feature
, file_name
, noerror
;
2916 register Lisp_Object tem
;
2917 CHECK_SYMBOL (feature
, 0);
2918 tem
= Fmemq (feature
, Vfeatures
);
2919 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2922 int count
= specpdl_ptr
- specpdl
;
2924 /* Value saved here is to be restored into Vautoload_queue */
2925 record_unwind_protect (un_autoload
, Vautoload_queue
);
2926 Vautoload_queue
= Qt
;
2928 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2929 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2930 /* If load failed entirely, return nil. */
2932 return unbind_to (count
, Qnil
);
2934 tem
= Fmemq (feature
, Vfeatures
);
2936 error ("Required feature %s was not provided",
2937 XSYMBOL (feature
)->name
->data
);
2939 /* Once loading finishes, don't undo it. */
2940 Vautoload_queue
= Qt
;
2941 feature
= unbind_to (count
, feature
);
2946 /* Primitives for work of the "widget" library.
2947 In an ideal world, this section would not have been necessary.
2948 However, lisp function calls being as slow as they are, it turns
2949 out that some functions in the widget library (wid-edit.el) are the
2950 bottleneck of Widget operation. Here is their translation to C,
2951 for the sole reason of efficiency. */
2953 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2954 "Return non-nil if PLIST has the property PROP.\n\
2955 PLIST is a property list, which is a list of the form\n\
2956 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2957 Unlike `plist-get', this allows you to distinguish between a missing\n\
2958 property and a property with the value nil.\n\
2959 The value is actually the tail of PLIST whose car is PROP.")
2961 Lisp_Object plist
, prop
;
2963 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2966 plist
= XCDR (plist
);
2967 plist
= CDR (plist
);
2972 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2973 "In WIDGET, set PROPERTY to VALUE.\n\
2974 The value can later be retrieved with `widget-get'.")
2975 (widget
, property
, value
)
2976 Lisp_Object widget
, property
, value
;
2978 CHECK_CONS (widget
, 1);
2979 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2983 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2984 "In WIDGET, get the value of PROPERTY.\n\
2985 The value could either be specified when the widget was created, or\n\
2986 later with `widget-put'.")
2988 Lisp_Object widget
, property
;
2996 CHECK_CONS (widget
, 1);
2997 tmp
= Fplist_member (XCDR (widget
), property
);
3003 tmp
= XCAR (widget
);
3006 widget
= Fget (tmp
, Qwidget_type
);
3010 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3011 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
3012 ARGS are passed as extra arguments to the function.")
3017 /* This function can GC. */
3018 Lisp_Object newargs
[3];
3019 struct gcpro gcpro1
, gcpro2
;
3022 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3023 newargs
[1] = args
[0];
3024 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3025 GCPRO2 (newargs
[0], newargs
[2]);
3026 result
= Fapply (3, newargs
);
3031 /* base64 encode/decode functions.
3032 Based on code from GNU recode. */
3034 #define MIME_LINE_LENGTH 76
3036 #define IS_ASCII(Character) \
3038 #define IS_BASE64(Character) \
3039 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3040 #define IS_BASE64_IGNORABLE(Character) \
3041 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3042 || (Character) == '\f' || (Character) == '\r')
3044 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3045 character or return retval if there are no characters left to
3047 #define READ_QUADRUPLET_BYTE(retval) \
3054 while (IS_BASE64_IGNORABLE (c))
3056 /* Don't use alloca for regions larger than this, lest we overflow
3058 #define MAX_ALLOCA 16*1024
3060 /* Table of characters coding the 64 values. */
3061 static char base64_value_to_char
[64] =
3063 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3064 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3065 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3066 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3067 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3068 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3069 '8', '9', '+', '/' /* 60-63 */
3072 /* Table of base64 values for first 128 characters. */
3073 static short base64_char_to_value
[128] =
3075 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3076 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3077 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3078 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3079 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3080 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3081 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3082 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3083 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3084 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3085 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3086 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3087 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3090 /* The following diagram shows the logical steps by which three octets
3091 get transformed into four base64 characters.
3093 .--------. .--------. .--------.
3094 |aaaaaabb| |bbbbcccc| |ccdddddd|
3095 `--------' `--------' `--------'
3097 .--------+--------+--------+--------.
3098 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3099 `--------+--------+--------+--------'
3101 .--------+--------+--------+--------.
3102 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3103 `--------+--------+--------+--------'
3105 The octets are divided into 6 bit chunks, which are then encoded into
3106 base64 characters. */
3109 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3110 static int base64_decode_1
P_ ((const char *, char *, int));
3112 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3114 "Base64-encode the region between BEG and END.\n\
3115 Return the length of the encoded text.\n\
3116 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3117 into shorter lines.")
3118 (beg
, end
, no_line_break
)
3119 Lisp_Object beg
, end
, no_line_break
;
3122 int allength
, length
;
3123 int ibeg
, iend
, encoded_length
;
3126 validate_region (&beg
, &end
);
3128 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3129 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3130 move_gap_both (XFASTINT (beg
), ibeg
);
3132 /* We need to allocate enough room for encoding the text.
3133 We need 33 1/3% more space, plus a newline every 76
3134 characters, and then we round up. */
3135 length
= iend
- ibeg
;
3136 allength
= length
+ length
/3 + 1;
3137 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3139 if (allength
<= MAX_ALLOCA
)
3140 encoded
= (char *) alloca (allength
);
3142 encoded
= (char *) xmalloc (allength
);
3143 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3144 NILP (no_line_break
),
3145 !NILP (current_buffer
->enable_multibyte_characters
));
3146 if (encoded_length
> allength
)
3149 if (encoded_length
< 0)
3151 /* The encoding wasn't possible. */
3152 if (length
> MAX_ALLOCA
)
3154 error ("Base64 encoding failed");
3157 /* Now we have encoded the region, so we insert the new contents
3158 and delete the old. (Insert first in order to preserve markers.) */
3159 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3160 insert (encoded
, encoded_length
);
3161 if (allength
> MAX_ALLOCA
)
3163 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3165 /* If point was outside of the region, restore it exactly; else just
3166 move to the beginning of the region. */
3167 if (old_pos
>= XFASTINT (end
))
3168 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3169 else if (old_pos
> XFASTINT (beg
))
3170 old_pos
= XFASTINT (beg
);
3173 /* We return the length of the encoded text. */
3174 return make_number (encoded_length
);
3177 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3179 "Base64-encode STRING and return the result.\n\
3180 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3181 into shorter lines.")
3182 (string
, no_line_break
)
3183 Lisp_Object string
, no_line_break
;
3185 int allength
, length
, encoded_length
;
3187 Lisp_Object encoded_string
;
3189 CHECK_STRING (string
, 1);
3191 /* We need to allocate enough room for encoding the text.
3192 We need 33 1/3% more space, plus a newline every 76
3193 characters, and then we round up. */
3194 length
= STRING_BYTES (XSTRING (string
));
3195 allength
= length
+ length
/3 + 1;
3196 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3198 /* We need to allocate enough room for decoding the text. */
3199 if (allength
<= MAX_ALLOCA
)
3200 encoded
= (char *) alloca (allength
);
3202 encoded
= (char *) xmalloc (allength
);
3204 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3205 encoded
, length
, NILP (no_line_break
),
3206 STRING_MULTIBYTE (string
));
3207 if (encoded_length
> allength
)
3210 if (encoded_length
< 0)
3212 /* The encoding wasn't possible. */
3213 if (length
> MAX_ALLOCA
)
3215 error ("Base64 encoding failed");
3218 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3219 if (allength
> MAX_ALLOCA
)
3222 return encoded_string
;
3226 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3233 int counter
= 0, i
= 0;
3243 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3244 if (!SINGLE_BYTE_CHAR_P (c
))
3251 /* Wrap line every 76 characters. */
3255 if (counter
< MIME_LINE_LENGTH
/ 4)
3264 /* Process first byte of a triplet. */
3266 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3267 value
= (0x03 & c
) << 4;
3269 /* Process second byte of a triplet. */
3273 *e
++ = base64_value_to_char
[value
];
3281 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3287 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3288 value
= (0x0f & c
) << 2;
3290 /* Process third byte of a triplet. */
3294 *e
++ = base64_value_to_char
[value
];
3301 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3307 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3308 *e
++ = base64_value_to_char
[0x3f & c
];
3315 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3317 "Base64-decode the region between BEG and END.\n\
3318 Return the length of the decoded text.\n\
3319 If the region can't be decoded, signal an error and don't modify the buffer.")
3321 Lisp_Object beg
, end
;
3323 int ibeg
, iend
, length
;
3329 validate_region (&beg
, &end
);
3331 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3332 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3334 length
= iend
- ibeg
;
3335 /* We need to allocate enough room for decoding the text. */
3336 if (length
<= MAX_ALLOCA
)
3337 decoded
= (char *) alloca (length
);
3339 decoded
= (char *) xmalloc (length
);
3341 move_gap_both (XFASTINT (beg
), ibeg
);
3342 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3343 if (decoded_length
> length
)
3346 if (decoded_length
< 0)
3348 /* The decoding wasn't possible. */
3349 if (length
> MAX_ALLOCA
)
3351 error ("Base64 decoding failed");
3354 inserted_chars
= decoded_length
;
3355 if (!NILP (current_buffer
->enable_multibyte_characters
))
3356 decoded_length
= str_to_multibyte (decoded
, length
, decoded_length
);
3358 /* Now we have decoded the region, so we insert the new contents
3359 and delete the old. (Insert first in order to preserve markers.) */
3360 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3361 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3362 if (length
> MAX_ALLOCA
)
3364 /* Delete the original text. */
3365 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3366 iend
+ decoded_length
, 1);
3368 /* If point was outside of the region, restore it exactly; else just
3369 move to the beginning of the region. */
3370 if (old_pos
>= XFASTINT (end
))
3371 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3372 else if (old_pos
> XFASTINT (beg
))
3373 old_pos
= XFASTINT (beg
);
3374 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3376 return make_number (inserted_chars
);
3379 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3381 "Base64-decode STRING and return the result.")
3386 int length
, decoded_length
;
3387 Lisp_Object decoded_string
;
3389 CHECK_STRING (string
, 1);
3391 length
= STRING_BYTES (XSTRING (string
));
3392 /* We need to allocate enough room for decoding the text. */
3393 if (length
<= MAX_ALLOCA
)
3394 decoded
= (char *) alloca (length
);
3396 decoded
= (char *) xmalloc (length
);
3398 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3399 if (decoded_length
> length
)
3401 else if (decoded_length
>= 0)
3402 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3404 decoded_string
= Qnil
;
3406 if (length
> MAX_ALLOCA
)
3408 if (!STRINGP (decoded_string
))
3409 error ("Base64 decoding failed");
3411 return decoded_string
;
3415 base64_decode_1 (from
, to
, length
)
3423 unsigned long value
;
3427 /* Process first byte of a quadruplet. */
3429 READ_QUADRUPLET_BYTE (e
-to
);
3433 value
= base64_char_to_value
[c
] << 18;
3435 /* Process second byte of a quadruplet. */
3437 READ_QUADRUPLET_BYTE (-1);
3441 value
|= base64_char_to_value
[c
] << 12;
3443 *e
++ = (unsigned char) (value
>> 16);
3445 /* Process third byte of a quadruplet. */
3447 READ_QUADRUPLET_BYTE (-1);
3451 READ_QUADRUPLET_BYTE (-1);
3460 value
|= base64_char_to_value
[c
] << 6;
3462 *e
++ = (unsigned char) (0xff & value
>> 8);
3464 /* Process fourth byte of a quadruplet. */
3466 READ_QUADRUPLET_BYTE (-1);
3473 value
|= base64_char_to_value
[c
];
3475 *e
++ = (unsigned char) (0xff & value
);
3481 /***********************************************************************
3483 ***** Hash Tables *****
3485 ***********************************************************************/
3487 /* Implemented by gerd@gnu.org. This hash table implementation was
3488 inspired by CMUCL hash tables. */
3492 1. For small tables, association lists are probably faster than
3493 hash tables because they have lower overhead.
3495 For uses of hash tables where the O(1) behavior of table
3496 operations is not a requirement, it might therefore be a good idea
3497 not to hash. Instead, we could just do a linear search in the
3498 key_and_value vector of the hash table. This could be done
3499 if a `:linear-search t' argument is given to make-hash-table. */
3502 /* Return the contents of vector V at index IDX. */
3504 #define AREF(V, IDX) XVECTOR (V)->contents[IDX]
3506 /* Value is the key part of entry IDX in hash table H. */
3508 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3510 /* Value is the value part of entry IDX in hash table H. */
3512 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3514 /* Value is the index of the next entry following the one at IDX
3517 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3519 /* Value is the hash code computed for entry IDX in hash table H. */
3521 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3523 /* Value is the index of the element in hash table H that is the
3524 start of the collision list at index IDX in the index vector of H. */
3526 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3528 /* Value is the size of hash table H. */
3530 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3532 /* The list of all weak hash tables. Don't staticpro this one. */
3534 Lisp_Object Vweak_hash_tables
;
3536 /* Various symbols. */
3538 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3539 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3540 Lisp_Object Qhash_table_test
;
3542 /* Function prototypes. */
3544 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3545 static int next_almost_prime
P_ ((int));
3546 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3547 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3548 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3549 Lisp_Object
, unsigned));
3550 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3551 Lisp_Object
, unsigned));
3552 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3553 unsigned, Lisp_Object
, unsigned));
3554 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3555 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3556 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3557 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3559 static unsigned sxhash_string
P_ ((unsigned char *, int));
3560 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3561 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3562 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3563 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3567 /***********************************************************************
3569 ***********************************************************************/
3571 /* If OBJ is a Lisp hash table, return a pointer to its struct
3572 Lisp_Hash_Table. Otherwise, signal an error. */
3574 static struct Lisp_Hash_Table
*
3575 check_hash_table (obj
)
3578 CHECK_HASH_TABLE (obj
, 0);
3579 return XHASH_TABLE (obj
);
3583 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3587 next_almost_prime (n
)
3600 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3601 which USED[I] is non-zero. If found at index I in ARGS, set
3602 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3603 -1. This function is used to extract a keyword/argument pair from
3604 a DEFUN parameter list. */
3607 get_key_arg (key
, nargs
, args
, used
)
3615 for (i
= 0; i
< nargs
- 1; ++i
)
3616 if (!used
[i
] && EQ (args
[i
], key
))
3631 /* Return a Lisp vector which has the same contents as VEC but has
3632 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3633 vector that are not copied from VEC are set to INIT. */
3636 larger_vector (vec
, new_size
, init
)
3641 struct Lisp_Vector
*v
;
3644 xassert (VECTORP (vec
));
3645 old_size
= XVECTOR (vec
)->size
;
3646 xassert (new_size
>= old_size
);
3648 v
= allocate_vectorlike (new_size
);
3650 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3651 old_size
* sizeof *v
->contents
);
3652 for (i
= old_size
; i
< new_size
; ++i
)
3653 v
->contents
[i
] = init
;
3654 XSETVECTOR (vec
, v
);
3659 /***********************************************************************
3661 ***********************************************************************/
3663 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3664 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3665 KEY2 are the same. */
3668 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3669 struct Lisp_Hash_Table
*h
;
3670 Lisp_Object key1
, key2
;
3671 unsigned hash1
, hash2
;
3673 return (FLOATP (key1
)
3675 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3679 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3680 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3681 KEY2 are the same. */
3684 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3685 struct Lisp_Hash_Table
*h
;
3686 Lisp_Object key1
, key2
;
3687 unsigned hash1
, hash2
;
3689 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3693 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3694 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3695 if KEY1 and KEY2 are the same. */
3698 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3699 struct Lisp_Hash_Table
*h
;
3700 Lisp_Object key1
, key2
;
3701 unsigned hash1
, hash2
;
3705 Lisp_Object args
[3];
3707 args
[0] = h
->user_cmp_function
;
3710 return !NILP (Ffuncall (3, args
));
3717 /* Value is a hash code for KEY for use in hash table H which uses
3718 `eq' to compare keys. The hash code returned is guaranteed to fit
3719 in a Lisp integer. */
3723 struct Lisp_Hash_Table
*h
;
3726 /* Lisp strings can change their address. Don't try to compute a
3727 hash code for a string from its address. */
3729 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3731 return XUINT (key
) ^ XGCTYPE (key
);
3735 /* Value is a hash code for KEY for use in hash table H which uses
3736 `eql' to compare keys. The hash code returned is guaranteed to fit
3737 in a Lisp integer. */
3741 struct Lisp_Hash_Table
*h
;
3744 /* Lisp strings can change their address. Don't try to compute a
3745 hash code for a string from its address. */
3747 return sxhash_string (XSTRING (key
)->data
, XSTRING (key
)->size
);
3748 else if (FLOATP (key
))
3749 return sxhash (key
, 0);
3751 return XUINT (key
) ^ XGCTYPE (key
);
3755 /* Value is a hash code for KEY for use in hash table H which uses
3756 `equal' to compare keys. The hash code returned is guaranteed to fit
3757 in a Lisp integer. */
3760 hashfn_equal (h
, key
)
3761 struct Lisp_Hash_Table
*h
;
3764 return sxhash (key
, 0);
3768 /* Value is a hash code for KEY for use in hash table H which uses as
3769 user-defined function to compare keys. The hash code returned is
3770 guaranteed to fit in a Lisp integer. */
3773 hashfn_user_defined (h
, key
)
3774 struct Lisp_Hash_Table
*h
;
3777 Lisp_Object args
[2], hash
;
3779 args
[0] = h
->user_hash_function
;
3781 hash
= Ffuncall (2, args
);
3782 if (!INTEGERP (hash
))
3784 list2 (build_string ("Illegal hash code returned from \
3785 user-supplied hash function"),
3787 return XUINT (hash
);
3791 /* Create and initialize a new hash table.
3793 TEST specifies the test the hash table will use to compare keys.
3794 It must be either one of the predefined tests `eq', `eql' or
3795 `equal' or a symbol denoting a user-defined test named TEST with
3796 test and hash functions USER_TEST and USER_HASH.
3798 Give the table initial capacity SIZE, SIZE > 0, an integer.
3800 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3801 new size when it becomes full is computed by adding REHASH_SIZE to
3802 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3803 table's new size is computed by multiplying its old size with
3806 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3807 be resized when the ratio of (number of entries in the table) /
3808 (table size) is >= REHASH_THRESHOLD.
3810 WEAK specifies the weakness of the table. If non-nil, it must be
3811 one of the symbols `key', `value' or t. */
3814 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3815 user_test
, user_hash
)
3816 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3817 Lisp_Object user_test
, user_hash
;
3819 struct Lisp_Hash_Table
*h
;
3820 struct Lisp_Vector
*v
;
3822 int index_size
, i
, len
, sz
;
3824 /* Preconditions. */
3825 xassert (SYMBOLP (test
));
3826 xassert (INTEGERP (size
) && XINT (size
) > 0);
3827 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3828 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3829 xassert (FLOATP (rehash_threshold
)
3830 && XFLOATINT (rehash_threshold
) > 0
3831 && XFLOATINT (rehash_threshold
) <= 1.0);
3833 /* Allocate a vector, and initialize it. */
3834 len
= VECSIZE (struct Lisp_Hash_Table
);
3835 v
= allocate_vectorlike (len
);
3837 for (i
= 0; i
< len
; ++i
)
3838 v
->contents
[i
] = Qnil
;
3840 /* Initialize hash table slots. */
3841 sz
= XFASTINT (size
);
3842 h
= (struct Lisp_Hash_Table
*) v
;
3845 if (EQ (test
, Qeql
))
3847 h
->cmpfn
= cmpfn_eql
;
3848 h
->hashfn
= hashfn_eql
;
3850 else if (EQ (test
, Qeq
))
3853 h
->hashfn
= hashfn_eq
;
3855 else if (EQ (test
, Qequal
))
3857 h
->cmpfn
= cmpfn_equal
;
3858 h
->hashfn
= hashfn_equal
;
3862 h
->user_cmp_function
= user_test
;
3863 h
->user_hash_function
= user_hash
;
3864 h
->cmpfn
= cmpfn_user_defined
;
3865 h
->hashfn
= hashfn_user_defined
;
3869 h
->rehash_threshold
= rehash_threshold
;
3870 h
->rehash_size
= rehash_size
;
3871 h
->count
= make_number (0);
3872 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3873 h
->hash
= Fmake_vector (size
, Qnil
);
3874 h
->next
= Fmake_vector (size
, Qnil
);
3875 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3876 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3877 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3879 /* Set up the free list. */
3880 for (i
= 0; i
< sz
- 1; ++i
)
3881 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3882 h
->next_free
= make_number (0);
3884 XSET_HASH_TABLE (table
, h
);
3885 xassert (HASH_TABLE_P (table
));
3886 xassert (XHASH_TABLE (table
) == h
);
3888 /* Maybe add this hash table to the list of all weak hash tables. */
3890 h
->next_weak
= Qnil
;
3893 h
->next_weak
= Vweak_hash_tables
;
3894 Vweak_hash_tables
= table
;
3901 /* Return a copy of hash table H1. Keys and values are not copied,
3902 only the table itself is. */
3905 copy_hash_table (h1
)
3906 struct Lisp_Hash_Table
*h1
;
3909 struct Lisp_Hash_Table
*h2
;
3910 struct Lisp_Vector
*v
, *next
;
3913 len
= VECSIZE (struct Lisp_Hash_Table
);
3914 v
= allocate_vectorlike (len
);
3915 h2
= (struct Lisp_Hash_Table
*) v
;
3916 next
= h2
->vec_next
;
3917 bcopy (h1
, h2
, sizeof *h2
);
3918 h2
->vec_next
= next
;
3919 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3920 h2
->hash
= Fcopy_sequence (h1
->hash
);
3921 h2
->next
= Fcopy_sequence (h1
->next
);
3922 h2
->index
= Fcopy_sequence (h1
->index
);
3923 XSET_HASH_TABLE (table
, h2
);
3925 /* Maybe add this hash table to the list of all weak hash tables. */
3926 if (!NILP (h2
->weak
))
3928 h2
->next_weak
= Vweak_hash_tables
;
3929 Vweak_hash_tables
= table
;
3936 /* Resize hash table H if it's too full. If H cannot be resized
3937 because it's already too large, throw an error. */
3940 maybe_resize_hash_table (h
)
3941 struct Lisp_Hash_Table
*h
;
3943 if (NILP (h
->next_free
))
3945 int old_size
= HASH_TABLE_SIZE (h
);
3946 int i
, new_size
, index_size
;
3948 if (INTEGERP (h
->rehash_size
))
3949 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3951 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3952 new_size
= max (old_size
+ 1, new_size
);
3953 index_size
= next_almost_prime ((int)
3955 / XFLOATINT (h
->rehash_threshold
)));
3956 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3957 error ("Hash table too large to resize");
3959 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3960 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3961 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3962 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3964 /* Update the free list. Do it so that new entries are added at
3965 the end of the free list. This makes some operations like
3967 for (i
= old_size
; i
< new_size
- 1; ++i
)
3968 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3970 if (!NILP (h
->next_free
))
3972 Lisp_Object last
, next
;
3974 last
= h
->next_free
;
3975 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3979 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3982 XSETFASTINT (h
->next_free
, old_size
);
3985 for (i
= 0; i
< old_size
; ++i
)
3986 if (!NILP (HASH_HASH (h
, i
)))
3988 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3989 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3990 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3991 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3997 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3998 the hash code of KEY. Value is the index of the entry in H
3999 matching KEY, or -1 if not found. */
4002 hash_lookup (h
, key
, hash
)
4003 struct Lisp_Hash_Table
*h
;
4008 int start_of_bucket
;
4011 hash_code
= h
->hashfn (h
, key
);
4015 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4016 idx
= HASH_INDEX (h
, start_of_bucket
);
4018 /* We need not gcpro idx since it's either an integer or nil. */
4021 int i
= XFASTINT (idx
);
4022 if (EQ (key
, HASH_KEY (h
, i
))
4024 && h
->cmpfn (h
, key
, hash_code
,
4025 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4027 idx
= HASH_NEXT (h
, i
);
4030 return NILP (idx
) ? -1 : XFASTINT (idx
);
4034 /* Put an entry into hash table H that associates KEY with VALUE.
4035 HASH is a previously computed hash code of KEY.
4036 Value is the index of the entry in H matching KEY. */
4039 hash_put (h
, key
, value
, hash
)
4040 struct Lisp_Hash_Table
*h
;
4041 Lisp_Object key
, value
;
4044 int start_of_bucket
, i
;
4046 xassert ((hash
& ~VALMASK
) == 0);
4048 /* Increment count after resizing because resizing may fail. */
4049 maybe_resize_hash_table (h
);
4050 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4052 /* Store key/value in the key_and_value vector. */
4053 i
= XFASTINT (h
->next_free
);
4054 h
->next_free
= HASH_NEXT (h
, i
);
4055 HASH_KEY (h
, i
) = key
;
4056 HASH_VALUE (h
, i
) = value
;
4058 /* Remember its hash code. */
4059 HASH_HASH (h
, i
) = make_number (hash
);
4061 /* Add new entry to its collision chain. */
4062 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4063 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4064 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4069 /* Remove the entry matching KEY from hash table H, if there is one. */
4072 hash_remove (h
, key
)
4073 struct Lisp_Hash_Table
*h
;
4077 int start_of_bucket
;
4078 Lisp_Object idx
, prev
;
4080 hash_code
= h
->hashfn (h
, key
);
4081 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4082 idx
= HASH_INDEX (h
, start_of_bucket
);
4085 /* We need not gcpro idx, prev since they're either integers or nil. */
4088 int i
= XFASTINT (idx
);
4090 if (EQ (key
, HASH_KEY (h
, i
))
4092 && h
->cmpfn (h
, key
, hash_code
,
4093 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4095 /* Take entry out of collision chain. */
4097 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4099 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4101 /* Clear slots in key_and_value and add the slots to
4103 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4104 HASH_NEXT (h
, i
) = h
->next_free
;
4105 h
->next_free
= make_number (i
);
4106 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4107 xassert (XINT (h
->count
) >= 0);
4113 idx
= HASH_NEXT (h
, i
);
4119 /* Clear hash table H. */
4123 struct Lisp_Hash_Table
*h
;
4125 if (XFASTINT (h
->count
) > 0)
4127 int i
, size
= HASH_TABLE_SIZE (h
);
4129 for (i
= 0; i
< size
; ++i
)
4131 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4132 HASH_KEY (h
, i
) = Qnil
;
4133 HASH_VALUE (h
, i
) = Qnil
;
4134 HASH_HASH (h
, i
) = Qnil
;
4137 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4138 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4140 h
->next_free
= make_number (0);
4141 h
->count
= make_number (0);
4147 /************************************************************************
4149 ************************************************************************/
4151 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4152 entries from the table that don't survive the current GC.
4153 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4154 non-zero if anything was marked. */
4157 sweep_weak_table (h
, remove_entries_p
)
4158 struct Lisp_Hash_Table
*h
;
4159 int remove_entries_p
;
4161 int bucket
, n
, marked
;
4163 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4166 for (bucket
= 0; bucket
< n
; ++bucket
)
4168 Lisp_Object idx
, prev
;
4170 /* Follow collision chain, removing entries that
4171 don't survive this garbage collection. */
4172 idx
= HASH_INDEX (h
, bucket
);
4174 while (!GC_NILP (idx
))
4177 int i
= XFASTINT (idx
);
4180 if (EQ (h
->weak
, Qkey
))
4181 remove_p
= !survives_gc_p (HASH_KEY (h
, i
));
4182 else if (EQ (h
->weak
, Qvalue
))
4183 remove_p
= !survives_gc_p (HASH_VALUE (h
, i
));
4184 else if (EQ (h
->weak
, Qt
))
4185 remove_p
= (!survives_gc_p (HASH_KEY (h
, i
))
4186 || !survives_gc_p (HASH_VALUE (h
, i
)));
4190 next
= HASH_NEXT (h
, i
);
4192 if (remove_entries_p
)
4196 /* Take out of collision chain. */
4198 HASH_INDEX (h
, i
) = next
;
4200 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4202 /* Add to free list. */
4203 HASH_NEXT (h
, i
) = h
->next_free
;
4206 /* Clear key, value, and hash. */
4207 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4208 HASH_HASH (h
, i
) = Qnil
;
4210 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4217 /* Make sure key and value survive. */
4218 mark_object (&HASH_KEY (h
, i
));
4219 mark_object (&HASH_VALUE (h
, i
));
4231 /* Remove elements from weak hash tables that don't survive the
4232 current garbage collection. Remove weak tables that don't survive
4233 from Vweak_hash_tables. Called from gc_sweep. */
4236 sweep_weak_hash_tables ()
4239 struct Lisp_Hash_Table
*h
, *prev
;
4242 /* Mark all keys and values that are in use. Keep on marking until
4243 there is no more change. This is necessary for cases like
4244 value-weak table A containing an entry X -> Y, where Y is used in a
4245 key-weak table B, Z -> Y. If B comes after A in the list of weak
4246 tables, X -> Y might be removed from A, although when looking at B
4247 one finds that it shouldn't. */
4251 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4253 h
= XHASH_TABLE (table
);
4254 if (h
->size
& ARRAY_MARK_FLAG
)
4255 marked
|= sweep_weak_table (h
, 0);
4260 /* Remove tables and entries that aren't used. */
4262 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4265 h
= XHASH_TABLE (table
);
4267 if (h
->size
& ARRAY_MARK_FLAG
)
4269 if (XFASTINT (h
->count
) > 0)
4270 sweep_weak_table (h
, 1);
4274 /* Table is not marked, and will thus be freed.
4275 Take it out of the list of weak hash tables. */
4277 prev
->next_weak
= h
->next_weak
;
4279 Vweak_hash_tables
= h
->next_weak
;
4286 /***********************************************************************
4287 Hash Code Computation
4288 ***********************************************************************/
4290 /* Maximum depth up to which to dive into Lisp structures. */
4292 #define SXHASH_MAX_DEPTH 3
4294 /* Maximum length up to which to take list and vector elements into
4297 #define SXHASH_MAX_LEN 7
4299 /* Combine two integers X and Y for hashing. */
4301 #define SXHASH_COMBINE(X, Y) \
4302 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4306 /* Return a hash for string PTR which has length LEN. */
4309 sxhash_string (ptr
, len
)
4313 unsigned char *p
= ptr
;
4314 unsigned char *end
= p
+ len
;
4323 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4326 return hash
& 07777777777;
4330 /* Return a hash for list LIST. DEPTH is the current depth in the
4331 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4334 sxhash_list (list
, depth
)
4341 if (depth
< SXHASH_MAX_DEPTH
)
4343 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4344 list
= XCDR (list
), ++i
)
4346 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4347 hash
= SXHASH_COMBINE (hash
, hash2
);
4354 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4355 the Lisp structure. */
4358 sxhash_vector (vec
, depth
)
4362 unsigned hash
= XVECTOR (vec
)->size
;
4365 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4366 for (i
= 0; i
< n
; ++i
)
4368 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4369 hash
= SXHASH_COMBINE (hash
, hash2
);
4376 /* Return a hash for bool-vector VECTOR. */
4379 sxhash_bool_vector (vec
)
4382 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4385 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4386 for (i
= 0; i
< n
; ++i
)
4387 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4393 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4394 structure. Value is an unsigned integer clipped to VALMASK. */
4403 if (depth
> SXHASH_MAX_DEPTH
)
4406 switch (XTYPE (obj
))
4413 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4414 XSYMBOL (obj
)->name
->size
);
4422 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4425 /* This can be everything from a vector to an overlay. */
4426 case Lisp_Vectorlike
:
4428 /* According to the CL HyperSpec, two arrays are equal only if
4429 they are `eq', except for strings and bit-vectors. In
4430 Emacs, this works differently. We have to compare element
4432 hash
= sxhash_vector (obj
, depth
);
4433 else if (BOOL_VECTOR_P (obj
))
4434 hash
= sxhash_bool_vector (obj
);
4436 /* Others are `equal' if they are `eq', so let's take their
4442 hash
= sxhash_list (obj
, depth
);
4447 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4448 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4449 for (hash
= 0; p
< e
; ++p
)
4450 hash
= SXHASH_COMBINE (hash
, *p
);
4458 return hash
& VALMASK
;
4463 /***********************************************************************
4465 ***********************************************************************/
4468 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4469 "Compute a hash code for OBJ and return it as integer.")
4473 unsigned hash
= sxhash (obj
, 0);;
4474 return make_number (hash
);
4478 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4479 "Create and return a new hash table.\n\
4480 Arguments are specified as keyword/argument pairs. The following\n\
4481 arguments are defined:\n\
4483 :TEST TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4484 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4485 User-supplied test and hash functions can be specified via\n\
4486 `define-hash-table-test'.\n\
4488 :SIZE SIZE -- A hint as to how many elements will be put in the table.\n\
4491 :REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
4492 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4493 If it is a float, it must be > 1.0, and the new size is computed by\n\
4494 multiplying the old size with that factor. Default is 1.5.\n\
4496 :REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4497 Resize the hash table when ratio of the number of entries in the table.\n\
4500 :WEAKNESS WEAK -- WEAK must be one of nil, t, `key', or `value'.\n\
4501 If WEAK is not nil, the table returned is a weak table. Key/value\n\
4502 pairs are removed from a weak hash table when their key, value or both\n\
4503 (WEAK t) are otherwise unreferenced. Default is nil.")
4508 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4509 Lisp_Object user_test
, user_hash
;
4513 /* The vector `used' is used to keep track of arguments that
4514 have been consumed. */
4515 used
= (char *) alloca (nargs
* sizeof *used
);
4516 bzero (used
, nargs
* sizeof *used
);
4518 /* See if there's a `:test TEST' among the arguments. */
4519 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4520 test
= i
< 0 ? Qeql
: args
[i
];
4521 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4523 /* See if it is a user-defined test. */
4526 prop
= Fget (test
, Qhash_table_test
);
4527 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4528 Fsignal (Qerror
, list2 (build_string ("Illegal hash table test"),
4530 user_test
= Fnth (make_number (0), prop
);
4531 user_hash
= Fnth (make_number (1), prop
);
4534 user_test
= user_hash
= Qnil
;
4536 /* See if there's a `:size SIZE' argument. */
4537 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4538 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4539 if (!INTEGERP (size
) || XINT (size
) <= 0)
4541 list2 (build_string ("Illegal hash table size"),
4544 /* Look for `:rehash-size SIZE'. */
4545 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4546 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4547 if (!NUMBERP (rehash_size
)
4548 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4549 || XFLOATINT (rehash_size
) <= 1.0)
4551 list2 (build_string ("Illegal hash table rehash size"),
4554 /* Look for `:rehash-threshold THRESHOLD'. */
4555 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4556 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4557 if (!FLOATP (rehash_threshold
)
4558 || XFLOATINT (rehash_threshold
) <= 0.0
4559 || XFLOATINT (rehash_threshold
) > 1.0)
4561 list2 (build_string ("Illegal hash table rehash threshold"),
4564 /* Look for `:weakness WEAK'. */
4565 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4566 weak
= i
< 0 ? Qnil
: args
[i
];
4570 && !EQ (weak
, Qvalue
))
4571 Fsignal (Qerror
, list2 (build_string ("Illegal hash table weakness"),
4574 /* Now, all args should have been used up, or there's a problem. */
4575 for (i
= 0; i
< nargs
; ++i
)
4578 list2 (build_string ("Invalid argument list"), args
[i
]));
4580 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4581 user_test
, user_hash
);
4585 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4586 "Return a copy of hash table TABLE.")
4590 return copy_hash_table (check_hash_table (table
));
4594 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4595 "Create a new hash table.\n\
4596 Optional first argument TEST specifies how to compare keys in\n\
4597 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4598 is `eql'. New tests can be defined with `define-hash-table-test'.")
4602 Lisp_Object args
[2];
4605 return Fmake_hash_table (2, args
);
4609 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4610 "Return the number of elements in TABLE.")
4614 return check_hash_table (table
)->count
;
4618 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4619 Shash_table_rehash_size
, 1, 1, 0,
4620 "Return the current rehash size of TABLE.")
4624 return check_hash_table (table
)->rehash_size
;
4628 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4629 Shash_table_rehash_threshold
, 1, 1, 0,
4630 "Return the current rehash threshold of TABLE.")
4634 return check_hash_table (table
)->rehash_threshold
;
4638 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4639 "Return the size of TABLE.\n\
4640 The size can be used as an argument to `make-hash-table' to create\n\
4641 a hash table than can hold as many elements of TABLE holds\n\
4642 without need for resizing.")
4646 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4647 return make_number (HASH_TABLE_SIZE (h
));
4651 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4652 "Return the test TABLE uses.")
4656 return check_hash_table (table
)->test
;
4660 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4662 "Return the weakness of TABLE.")
4666 return check_hash_table (table
)->weak
;
4670 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4671 "Return t if OBJ is a Lisp hash table object.")
4675 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4679 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4680 "Clear hash table TABLE.")
4684 hash_clear (check_hash_table (table
));
4689 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4690 "Look up KEY in TABLE and return its associated value.\n\
4691 If KEY is not found, return DFLT which defaults to nil.")
4693 Lisp_Object key
, table
, dflt
;
4695 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4696 int i
= hash_lookup (h
, key
, NULL
);
4697 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4701 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4702 "Associate KEY with VALUE in hash table TABLE.\n\
4703 If KEY is already present in table, replace its current value with\n\
4706 Lisp_Object key
, value
, table
;
4708 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4712 i
= hash_lookup (h
, key
, &hash
);
4714 HASH_VALUE (h
, i
) = value
;
4716 hash_put (h
, key
, value
, hash
);
4722 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4723 "Remove KEY from TABLE.")
4725 Lisp_Object key
, table
;
4727 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4728 hash_remove (h
, key
);
4733 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4734 "Call FUNCTION for all entries in hash table TABLE.\n\
4735 FUNCTION is called with 2 arguments KEY and VALUE.")
4737 Lisp_Object function
, table
;
4739 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4740 Lisp_Object args
[3];
4743 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4744 if (!NILP (HASH_HASH (h
, i
)))
4747 args
[1] = HASH_KEY (h
, i
);
4748 args
[2] = HASH_VALUE (h
, i
);
4756 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4757 Sdefine_hash_table_test
, 3, 3, 0,
4758 "Define a new hash table test with name NAME, a symbol.\n\
4759 In hash tables create with NAME specified as test, use TEST to compare\n\
4760 keys, and HASH for computing hash codes of keys.\n\
4762 TEST must be a function taking two arguments and returning non-nil\n\
4763 if both arguments are the same. HASH must be a function taking\n\
4764 one argument and return an integer that is the hash code of the\n\
4765 argument. Hash code computation should use the whole value range of\n\
4766 integers, including negative integers.")
4768 Lisp_Object name
, test
, hash
;
4770 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4779 /* Hash table stuff. */
4780 Qhash_table_p
= intern ("hash-table-p");
4781 staticpro (&Qhash_table_p
);
4782 Qeq
= intern ("eq");
4784 Qeql
= intern ("eql");
4786 Qequal
= intern ("equal");
4787 staticpro (&Qequal
);
4788 QCtest
= intern (":test");
4789 staticpro (&QCtest
);
4790 QCsize
= intern (":size");
4791 staticpro (&QCsize
);
4792 QCrehash_size
= intern (":rehash-size");
4793 staticpro (&QCrehash_size
);
4794 QCrehash_threshold
= intern (":rehash-threshold");
4795 staticpro (&QCrehash_threshold
);
4796 QCweakness
= intern (":weakness");
4797 staticpro (&QCweakness
);
4798 Qkey
= intern ("key");
4800 Qvalue
= intern ("value");
4801 staticpro (&Qvalue
);
4802 Qhash_table_test
= intern ("hash-table-test");
4803 staticpro (&Qhash_table_test
);
4806 defsubr (&Smake_hash_table
);
4807 defsubr (&Scopy_hash_table
);
4808 defsubr (&Smakehash
);
4809 defsubr (&Shash_table_count
);
4810 defsubr (&Shash_table_rehash_size
);
4811 defsubr (&Shash_table_rehash_threshold
);
4812 defsubr (&Shash_table_size
);
4813 defsubr (&Shash_table_test
);
4814 defsubr (&Shash_table_weakness
);
4815 defsubr (&Shash_table_p
);
4816 defsubr (&Sclrhash
);
4817 defsubr (&Sgethash
);
4818 defsubr (&Sputhash
);
4819 defsubr (&Sremhash
);
4820 defsubr (&Smaphash
);
4821 defsubr (&Sdefine_hash_table_test
);
4823 Qstring_lessp
= intern ("string-lessp");
4824 staticpro (&Qstring_lessp
);
4825 Qprovide
= intern ("provide");
4826 staticpro (&Qprovide
);
4827 Qrequire
= intern ("require");
4828 staticpro (&Qrequire
);
4829 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4830 staticpro (&Qyes_or_no_p_history
);
4831 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4832 staticpro (&Qcursor_in_echo_area
);
4833 Qwidget_type
= intern ("widget-type");
4834 staticpro (&Qwidget_type
);
4836 staticpro (&string_char_byte_cache_string
);
4837 string_char_byte_cache_string
= Qnil
;
4839 Fset (Qyes_or_no_p_history
, Qnil
);
4841 DEFVAR_LISP ("features", &Vfeatures
,
4842 "A list of symbols which are the features of the executing emacs.\n\
4843 Used by `featurep' and `require', and altered by `provide'.");
4846 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4847 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
4848 This applies to y-or-n and yes-or-no questions asked by commands\n\
4849 invoked by mouse clicks and mouse menu items.");
4852 defsubr (&Sidentity
);
4855 defsubr (&Ssafe_length
);
4856 defsubr (&Sstring_bytes
);
4857 defsubr (&Sstring_equal
);
4858 defsubr (&Scompare_strings
);
4859 defsubr (&Sstring_lessp
);
4862 defsubr (&Svconcat
);
4863 defsubr (&Scopy_sequence
);
4864 defsubr (&Sstring_make_multibyte
);
4865 defsubr (&Sstring_make_unibyte
);
4866 defsubr (&Sstring_as_multibyte
);
4867 defsubr (&Sstring_as_unibyte
);
4868 defsubr (&Scopy_alist
);
4869 defsubr (&Ssubstring
);
4881 defsubr (&Snreverse
);
4882 defsubr (&Sreverse
);
4884 defsubr (&Splist_get
);
4886 defsubr (&Splist_put
);
4889 defsubr (&Sfillarray
);
4890 defsubr (&Schar_table_subtype
);
4891 defsubr (&Schar_table_parent
);
4892 defsubr (&Sset_char_table_parent
);
4893 defsubr (&Schar_table_extra_slot
);
4894 defsubr (&Sset_char_table_extra_slot
);
4895 defsubr (&Schar_table_range
);
4896 defsubr (&Sset_char_table_range
);
4897 defsubr (&Sset_char_table_default
);
4898 defsubr (&Soptimize_char_table
);
4899 defsubr (&Smap_char_table
);
4903 defsubr (&Smapconcat
);
4904 defsubr (&Sy_or_n_p
);
4905 defsubr (&Syes_or_no_p
);
4906 defsubr (&Sload_average
);
4907 defsubr (&Sfeaturep
);
4908 defsubr (&Srequire
);
4909 defsubr (&Sprovide
);
4910 defsubr (&Splist_member
);
4911 defsubr (&Swidget_put
);
4912 defsubr (&Swidget_get
);
4913 defsubr (&Swidget_apply
);
4914 defsubr (&Sbase64_encode_region
);
4915 defsubr (&Sbase64_decode_region
);
4916 defsubr (&Sbase64_encode_string
);
4917 defsubr (&Sbase64_decode_string
);
4924 Vweak_hash_tables
= Qnil
;