1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 2002
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* On Mac OS X, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 extern int minibuffer_auto_raise
;
63 extern Lisp_Object minibuf_window
;
64 extern Lisp_Object Vlocale_coding_system
;
66 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
67 Lisp_Object Qyes_or_no_p_history
;
68 Lisp_Object Qcursor_in_echo_area
;
69 Lisp_Object Qwidget_type
;
70 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
72 extern Lisp_Object Qinput_method_function
;
74 static int internal_equal ();
76 extern long get_random ();
77 extern void seed_random ();
83 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
84 doc
: /* Return the argument unchanged. */)
91 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
92 doc
: /* Return a pseudo-random number.
93 All integers representable in Lisp are equally likely.
94 On most systems, this is 28 bits' worth.
95 With positive integer argument N, return random number in interval [0,N).
96 With argument t, set the random number seed from the current time and pid. */)
101 Lisp_Object lispy_val
;
102 unsigned long denominator
;
105 seed_random (getpid () + time (NULL
));
106 if (NATNUMP (n
) && XFASTINT (n
) != 0)
108 /* Try to take our random number from the higher bits of VAL,
109 not the lower, since (says Gentzel) the low bits of `random'
110 are less random than the higher ones. We do this by using the
111 quotient rather than the remainder. At the high end of the RNG
112 it's possible to get a quotient larger than n; discarding
113 these values eliminates the bias that would otherwise appear
114 when using a large n. */
115 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
117 val
= get_random () / denominator
;
118 while (val
>= XFASTINT (n
));
122 XSETINT (lispy_val
, val
);
126 /* Random data-structure functions */
128 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
129 doc
: /* Return the length of vector, list or string SEQUENCE.
130 A byte-code function object is also allowed.
131 If the string contains multibyte characters, this is not necessarily
132 the number of bytes in the string; it is the number of characters.
133 To get the number of bytes, use `string-bytes'. */)
135 register Lisp_Object sequence
;
137 register Lisp_Object val
;
141 if (STRINGP (sequence
))
142 XSETFASTINT (val
, SCHARS (sequence
));
143 else if (VECTORP (sequence
))
144 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
145 else if (CHAR_TABLE_P (sequence
))
146 XSETFASTINT (val
, MAX_CHAR
);
147 else if (BOOL_VECTOR_P (sequence
))
148 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
149 else if (COMPILEDP (sequence
))
150 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
151 else if (CONSP (sequence
))
154 while (CONSP (sequence
))
156 sequence
= XCDR (sequence
);
159 if (!CONSP (sequence
))
162 sequence
= XCDR (sequence
);
167 if (!NILP (sequence
))
168 wrong_type_argument (Qlistp
, sequence
);
170 val
= make_number (i
);
172 else if (NILP (sequence
))
173 XSETFASTINT (val
, 0);
176 sequence
= wrong_type_argument (Qsequencep
, sequence
);
182 /* This does not check for quits. That is safe
183 since it must terminate. */
185 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
186 doc
: /* Return the length of a list, but avoid error or infinite loop.
187 This function never gets an error. If LIST is not really a list,
188 it returns 0. If LIST is circular, it returns a finite value
189 which is at least the number of distinct elements. */)
193 Lisp_Object tail
, halftail
, length
;
196 /* halftail is used to detect circular lists. */
198 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
200 if (EQ (tail
, halftail
) && len
!= 0)
204 halftail
= XCDR (halftail
);
207 XSETINT (length
, len
);
211 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
212 doc
: /* Return the number of bytes in STRING.
213 If STRING is a multibyte string, this is greater than the length of STRING. */)
217 CHECK_STRING (string
);
218 return make_number (SBYTES (string
));
221 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
222 doc
: /* Return t if two strings have identical contents.
223 Case is significant, but text properties are ignored.
224 Symbols are also allowed; their print names are used instead. */)
226 register Lisp_Object s1
, s2
;
229 s1
= SYMBOL_NAME (s1
);
231 s2
= SYMBOL_NAME (s2
);
235 if (SCHARS (s1
) != SCHARS (s2
)
236 || SBYTES (s1
) != SBYTES (s2
)
237 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
242 DEFUN ("compare-strings", Fcompare_strings
,
243 Scompare_strings
, 6, 7, 0,
244 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
245 In string STR1, skip the first START1 characters and stop at END1.
246 In string STR2, skip the first START2 characters and stop at END2.
247 END1 and END2 default to the full lengths of the respective strings.
249 Case is significant in this comparison if IGNORE-CASE is nil.
250 Unibyte strings are converted to multibyte for comparison.
252 The value is t if the strings (or specified portions) match.
253 If string STR1 is less, the value is a negative number N;
254 - 1 - N is the number of characters that match at the beginning.
255 If string STR1 is greater, the value is a positive number N;
256 N - 1 is the number of characters that match at the beginning. */)
257 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
258 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
260 register int end1_char
, end2_char
;
261 register int i1
, i1_byte
, i2
, i2_byte
;
266 start1
= make_number (0);
268 start2
= make_number (0);
269 CHECK_NATNUM (start1
);
270 CHECK_NATNUM (start2
);
279 i1_byte
= string_char_to_byte (str1
, i1
);
280 i2_byte
= string_char_to_byte (str2
, i2
);
282 end1_char
= SCHARS (str1
);
283 if (! NILP (end1
) && end1_char
> XINT (end1
))
284 end1_char
= XINT (end1
);
286 end2_char
= SCHARS (str2
);
287 if (! NILP (end2
) && end2_char
> XINT (end2
))
288 end2_char
= XINT (end2
);
290 while (i1
< end1_char
&& i2
< end2_char
)
292 /* When we find a mismatch, we must compare the
293 characters, not just the bytes. */
296 if (STRING_MULTIBYTE (str1
))
297 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
300 c1
= SREF (str1
, i1
++);
301 c1
= unibyte_char_to_multibyte (c1
);
304 if (STRING_MULTIBYTE (str2
))
305 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
308 c2
= SREF (str2
, i2
++);
309 c2
= unibyte_char_to_multibyte (c2
);
315 if (! NILP (ignore_case
))
319 tem
= Fupcase (make_number (c1
));
321 tem
= Fupcase (make_number (c2
));
328 /* Note that I1 has already been incremented
329 past the character that we are comparing;
330 hence we don't add or subtract 1 here. */
332 return make_number (- i1
+ XINT (start1
));
334 return make_number (i1
- XINT (start1
));
338 return make_number (i1
- XINT (start1
) + 1);
340 return make_number (- i1
+ XINT (start1
) - 1);
345 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
346 doc
: /* Return t if first arg string is less than second in lexicographic order.
348 Symbols are also allowed; their print names are used instead. */)
350 register Lisp_Object s1
, s2
;
353 register int i1
, i1_byte
, i2
, i2_byte
;
356 s1
= SYMBOL_NAME (s1
);
358 s2
= SYMBOL_NAME (s2
);
362 i1
= i1_byte
= i2
= i2_byte
= 0;
365 if (end
> SCHARS (s2
))
370 /* When we find a mismatch, we must compare the
371 characters, not just the bytes. */
374 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
375 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
378 return c1
< c2
? Qt
: Qnil
;
380 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
383 static Lisp_Object
concat ();
394 return concat (2, args
, Lisp_String
, 0);
396 return concat (2, &s1
, Lisp_String
, 0);
397 #endif /* NO_ARG_ARRAY */
403 Lisp_Object s1
, s2
, s3
;
410 return concat (3, args
, Lisp_String
, 0);
412 return concat (3, &s1
, Lisp_String
, 0);
413 #endif /* NO_ARG_ARRAY */
416 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
417 doc
: /* Concatenate all the arguments and make the result a list.
418 The result is a list whose elements are the elements of all the arguments.
419 Each argument may be a list, vector or string.
420 The last argument is not copied, just used as the tail of the new list.
421 usage: (append &rest SEQUENCES) */)
426 return concat (nargs
, args
, Lisp_Cons
, 1);
429 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
430 doc
: /* Concatenate all the arguments and make the result a string.
431 The result is a string whose elements are the elements of all the arguments.
432 Each argument may be a string or a list or vector of characters (integers).
433 usage: (concat &rest SEQUENCES) */)
438 return concat (nargs
, args
, Lisp_String
, 0);
441 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
442 doc
: /* Concatenate all the arguments and make the result a vector.
443 The result is a vector whose elements are the elements of all the arguments.
444 Each argument may be a list, vector or string.
445 usage: (vconcat &rest SEQUENCES) */)
450 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
453 /* Return a copy of a sub char table ARG. The elements except for a
454 nested sub char table are not copied. */
456 copy_sub_char_table (arg
)
459 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
462 /* Copy all the contents. */
463 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
464 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
465 /* Recursively copy any sub char-tables in the ordinary slots. */
466 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
467 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
468 XCHAR_TABLE (copy
)->contents
[i
]
469 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
475 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
476 doc
: /* Return a copy of a list, vector, string or char-table.
477 The elements of a list or vector are not copied; they are shared
478 with the original. */)
482 if (NILP (arg
)) return arg
;
484 if (CHAR_TABLE_P (arg
))
489 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
490 /* Copy all the slots, including the extra ones. */
491 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
492 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
493 * sizeof (Lisp_Object
)));
495 /* Recursively copy any sub char tables in the ordinary slots
496 for multibyte characters. */
497 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
498 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
499 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
500 XCHAR_TABLE (copy
)->contents
[i
]
501 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
506 if (BOOL_VECTOR_P (arg
))
510 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
512 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
513 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
518 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
519 arg
= wrong_type_argument (Qsequencep
, arg
);
520 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
523 /* In string STR of length LEN, see if bytes before STR[I] combine
524 with bytes after STR[I] to form a single character. If so, return
525 the number of bytes after STR[I] which combine in this way.
526 Otherwize, return 0. */
529 count_combining (str
, len
, i
)
533 int j
= i
- 1, bytes
;
535 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
537 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
538 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
540 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
541 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
544 /* This structure holds information of an argument of `concat' that is
545 a string and has text properties to be copied. */
548 int argnum
; /* refer to ARGS (arguments of `concat') */
549 int from
; /* refer to ARGS[argnum] (argument string) */
550 int to
; /* refer to VAL (the target string) */
554 concat (nargs
, args
, target_type
, last_special
)
557 enum Lisp_Type target_type
;
561 register Lisp_Object tail
;
562 register Lisp_Object
this;
564 int toindex_byte
= 0;
565 register int result_len
;
566 register int result_len_byte
;
568 Lisp_Object last_tail
;
571 /* When we make a multibyte string, we can't copy text properties
572 while concatinating each string because the length of resulting
573 string can't be decided until we finish the whole concatination.
574 So, we record strings that have text properties to be copied
575 here, and copy the text properties after the concatination. */
576 struct textprop_rec
*textprops
= NULL
;
577 /* Number of elments in textprops. */
578 int num_textprops
= 0;
582 /* In append, the last arg isn't treated like the others */
583 if (last_special
&& nargs
> 0)
586 last_tail
= args
[nargs
];
591 /* Canonicalize each argument. */
592 for (argnum
= 0; argnum
< nargs
; argnum
++)
595 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
596 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
598 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
602 /* Compute total length in chars of arguments in RESULT_LEN.
603 If desired output is a string, also compute length in bytes
604 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
605 whether the result should be a multibyte string. */
609 for (argnum
= 0; argnum
< nargs
; argnum
++)
613 len
= XFASTINT (Flength (this));
614 if (target_type
== Lisp_String
)
616 /* We must count the number of bytes needed in the string
617 as well as the number of characters. */
623 for (i
= 0; i
< len
; i
++)
625 ch
= XVECTOR (this)->contents
[i
];
627 wrong_type_argument (Qintegerp
, ch
);
628 this_len_byte
= CHAR_BYTES (XINT (ch
));
629 result_len_byte
+= this_len_byte
;
630 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
633 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
634 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
635 else if (CONSP (this))
636 for (; CONSP (this); this = XCDR (this))
640 wrong_type_argument (Qintegerp
, ch
);
641 this_len_byte
= CHAR_BYTES (XINT (ch
));
642 result_len_byte
+= this_len_byte
;
643 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
646 else if (STRINGP (this))
648 if (STRING_MULTIBYTE (this))
651 result_len_byte
+= SBYTES (this);
654 result_len_byte
+= count_size_as_multibyte (SDATA (this),
662 if (! some_multibyte
)
663 result_len_byte
= result_len
;
665 /* Create the output object. */
666 if (target_type
== Lisp_Cons
)
667 val
= Fmake_list (make_number (result_len
), Qnil
);
668 else if (target_type
== Lisp_Vectorlike
)
669 val
= Fmake_vector (make_number (result_len
), Qnil
);
670 else if (some_multibyte
)
671 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
673 val
= make_uninit_string (result_len
);
675 /* In `append', if all but last arg are nil, return last arg. */
676 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
679 /* Copy the contents of the args into the result. */
681 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
683 toindex
= 0, toindex_byte
= 0;
688 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
690 for (argnum
= 0; argnum
< nargs
; argnum
++)
694 register unsigned int thisindex
= 0;
695 register unsigned int thisindex_byte
= 0;
699 thislen
= Flength (this), thisleni
= XINT (thislen
);
701 /* Between strings of the same kind, copy fast. */
702 if (STRINGP (this) && STRINGP (val
)
703 && STRING_MULTIBYTE (this) == some_multibyte
)
705 int thislen_byte
= SBYTES (this);
708 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
710 combined
= (some_multibyte
&& toindex_byte
> 0
711 ? count_combining (SDATA (val
),
712 toindex_byte
+ thislen_byte
,
715 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
717 textprops
[num_textprops
].argnum
= argnum
;
718 /* We ignore text properties on characters being combined. */
719 textprops
[num_textprops
].from
= combined
;
720 textprops
[num_textprops
++].to
= toindex
;
722 toindex_byte
+= thislen_byte
;
723 toindex
+= thisleni
- combined
;
724 STRING_SET_CHARS (val
, SCHARS (val
) - combined
);
726 /* Copy a single-byte string to a multibyte string. */
727 else if (STRINGP (this) && STRINGP (val
))
729 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
731 textprops
[num_textprops
].argnum
= argnum
;
732 textprops
[num_textprops
].from
= 0;
733 textprops
[num_textprops
++].to
= toindex
;
735 toindex_byte
+= copy_text (SDATA (this),
736 SDATA (val
) + toindex_byte
,
737 SCHARS (this), 0, 1);
741 /* Copy element by element. */
744 register Lisp_Object elt
;
746 /* Fetch next element of `this' arg into `elt', or break if
747 `this' is exhausted. */
748 if (NILP (this)) break;
750 elt
= XCAR (this), this = XCDR (this);
751 else if (thisindex
>= thisleni
)
753 else if (STRINGP (this))
756 if (STRING_MULTIBYTE (this))
758 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
761 XSETFASTINT (elt
, c
);
765 XSETFASTINT (elt
, SREF (this, thisindex
++));
767 && (XINT (elt
) >= 0240
768 || (XINT (elt
) >= 0200
769 && ! NILP (Vnonascii_translation_table
)))
770 && XINT (elt
) < 0400)
772 c
= unibyte_char_to_multibyte (XINT (elt
));
777 else if (BOOL_VECTOR_P (this))
780 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
781 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
788 elt
= XVECTOR (this)->contents
[thisindex
++];
790 /* Store this element into the result. */
797 else if (VECTORP (val
))
798 XVECTOR (val
)->contents
[toindex
++] = elt
;
802 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
806 += CHAR_STRING (XINT (elt
),
807 SDATA (val
) + toindex_byte
);
809 SSET (val
, toindex_byte
++, XINT (elt
));
812 && count_combining (SDATA (val
),
813 toindex_byte
, toindex_byte
- 1))
814 STRING_SET_CHARS (val
, SCHARS (val
) - 1);
819 /* If we have any multibyte characters,
820 we already decided to make a multibyte string. */
823 /* P exists as a variable
824 to avoid a bug on the Masscomp C compiler. */
825 unsigned char *p
= SDATA (val
) + toindex_byte
;
827 toindex_byte
+= CHAR_STRING (c
, p
);
834 XSETCDR (prev
, last_tail
);
836 if (num_textprops
> 0)
839 int last_to_end
= -1;
841 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
843 this = args
[textprops
[argnum
].argnum
];
844 props
= text_property_list (this,
846 make_number (SCHARS (this)),
848 /* If successive arguments have properites, be sure that the
849 value of `composition' property be the copy. */
850 if (last_to_end
== textprops
[argnum
].to
)
851 make_composition_value_copy (props
);
852 add_text_properties_from_list (val
, props
,
853 make_number (textprops
[argnum
].to
));
854 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
860 static Lisp_Object string_char_byte_cache_string
;
861 static int string_char_byte_cache_charpos
;
862 static int string_char_byte_cache_bytepos
;
865 clear_string_char_byte_cache ()
867 string_char_byte_cache_string
= Qnil
;
870 /* Return the character index corresponding to CHAR_INDEX in STRING. */
873 string_char_to_byte (string
, char_index
)
878 int best_below
, best_below_byte
;
879 int best_above
, best_above_byte
;
881 if (! STRING_MULTIBYTE (string
))
884 best_below
= best_below_byte
= 0;
885 best_above
= SCHARS (string
);
886 best_above_byte
= SBYTES (string
);
888 if (EQ (string
, string_char_byte_cache_string
))
890 if (string_char_byte_cache_charpos
< char_index
)
892 best_below
= string_char_byte_cache_charpos
;
893 best_below_byte
= string_char_byte_cache_bytepos
;
897 best_above
= string_char_byte_cache_charpos
;
898 best_above_byte
= string_char_byte_cache_bytepos
;
902 if (char_index
- best_below
< best_above
- char_index
)
904 while (best_below
< char_index
)
907 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
908 best_below
, best_below_byte
);
911 i_byte
= best_below_byte
;
915 while (best_above
> char_index
)
917 unsigned char *pend
= SDATA (string
) + best_above_byte
;
918 unsigned char *pbeg
= pend
- best_above_byte
;
919 unsigned char *p
= pend
- 1;
922 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
923 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
924 if (bytes
== pend
- p
)
925 best_above_byte
-= bytes
;
926 else if (bytes
> pend
- p
)
927 best_above_byte
-= (pend
- p
);
933 i_byte
= best_above_byte
;
936 string_char_byte_cache_bytepos
= i_byte
;
937 string_char_byte_cache_charpos
= i
;
938 string_char_byte_cache_string
= string
;
943 /* Return the character index corresponding to BYTE_INDEX in STRING. */
946 string_byte_to_char (string
, byte_index
)
951 int best_below
, best_below_byte
;
952 int best_above
, best_above_byte
;
954 if (! STRING_MULTIBYTE (string
))
957 best_below
= best_below_byte
= 0;
958 best_above
= SCHARS (string
);
959 best_above_byte
= SBYTES (string
);
961 if (EQ (string
, string_char_byte_cache_string
))
963 if (string_char_byte_cache_bytepos
< byte_index
)
965 best_below
= string_char_byte_cache_charpos
;
966 best_below_byte
= string_char_byte_cache_bytepos
;
970 best_above
= string_char_byte_cache_charpos
;
971 best_above_byte
= string_char_byte_cache_bytepos
;
975 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
977 while (best_below_byte
< byte_index
)
980 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
981 best_below
, best_below_byte
);
984 i_byte
= best_below_byte
;
988 while (best_above_byte
> byte_index
)
990 unsigned char *pend
= SDATA (string
) + best_above_byte
;
991 unsigned char *pbeg
= pend
- best_above_byte
;
992 unsigned char *p
= pend
- 1;
995 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
996 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
997 if (bytes
== pend
- p
)
998 best_above_byte
-= bytes
;
999 else if (bytes
> pend
- p
)
1000 best_above_byte
-= (pend
- p
);
1006 i_byte
= best_above_byte
;
1009 string_char_byte_cache_bytepos
= i_byte
;
1010 string_char_byte_cache_charpos
= i
;
1011 string_char_byte_cache_string
= string
;
1016 /* Convert STRING to a multibyte string.
1017 Single-byte characters 0240 through 0377 are converted
1018 by adding nonascii_insert_offset to each. */
1021 string_make_multibyte (string
)
1027 if (STRING_MULTIBYTE (string
))
1030 nbytes
= count_size_as_multibyte (SDATA (string
),
1032 /* If all the chars are ASCII, they won't need any more bytes
1033 once converted. In that case, we can return STRING itself. */
1034 if (nbytes
== SBYTES (string
))
1037 buf
= (unsigned char *) alloca (nbytes
);
1038 copy_text (SDATA (string
), buf
, SBYTES (string
),
1041 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1045 /* Convert STRING to a multibyte string without changing each
1046 character codes. Thus, characters 0200 trough 0237 are converted
1047 to eight-bit-control characters, and characters 0240 through 0377
1048 are converted eight-bit-graphic characters. */
1051 string_to_multibyte (string
)
1057 if (STRING_MULTIBYTE (string
))
1060 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1061 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1062 any more bytes once converted. */
1063 if (nbytes
== SBYTES (string
))
1064 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1066 buf
= (unsigned char *) alloca (nbytes
);
1067 bcopy (SDATA (string
), buf
, SBYTES (string
));
1068 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1070 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1074 /* Convert STRING to a single-byte string. */
1077 string_make_unibyte (string
)
1082 if (! STRING_MULTIBYTE (string
))
1085 buf
= (unsigned char *) alloca (SCHARS (string
));
1087 copy_text (SDATA (string
), buf
, SBYTES (string
),
1090 return make_unibyte_string (buf
, SCHARS (string
));
1093 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1095 doc
: /* Return the multibyte equivalent of STRING.
1096 The function `unibyte-char-to-multibyte' is used to convert
1097 each unibyte character to a multibyte character. */)
1101 CHECK_STRING (string
);
1103 return string_make_multibyte (string
);
1106 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1108 doc
: /* Return the unibyte equivalent of STRING.
1109 Multibyte character codes are converted to unibyte according to
1110 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1111 If the lookup in the translation table fails, this function takes just
1112 the low 8 bits of each character. */)
1116 CHECK_STRING (string
);
1118 return string_make_unibyte (string
);
1121 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1123 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1124 If STRING is unibyte, the result is STRING itself.
1125 Otherwise it is a newly created string, with no text properties.
1126 If STRING is multibyte and contains a character of charset
1127 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1128 corresponding single byte. */)
1132 CHECK_STRING (string
);
1134 if (STRING_MULTIBYTE (string
))
1136 int bytes
= SBYTES (string
);
1137 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1139 bcopy (SDATA (string
), str
, bytes
);
1140 bytes
= str_as_unibyte (str
, bytes
);
1141 string
= make_unibyte_string (str
, bytes
);
1147 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1149 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1150 If STRING is multibyte, the result is STRING itself.
1151 Otherwise it is a newly created string, with no text properties.
1152 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1153 part of a multibyte form), it is converted to the corresponding
1154 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1158 CHECK_STRING (string
);
1160 if (! STRING_MULTIBYTE (string
))
1162 Lisp_Object new_string
;
1165 parse_str_as_multibyte (SDATA (string
),
1168 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1169 bcopy (SDATA (string
), SDATA (new_string
),
1171 if (nbytes
!= SBYTES (string
))
1172 str_as_multibyte (SDATA (new_string
), nbytes
,
1173 SBYTES (string
), NULL
);
1174 string
= new_string
;
1175 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1180 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1182 doc
: /* Return a multibyte string with the same individual chars as STRING.
1183 If STRING is multibyte, the result is STRING itself.
1184 Otherwise it is a newly created string, with no text properties.
1185 Characters 0200 through 0237 are converted to eight-bit-control
1186 characters of the same character code. Characters 0240 through 0377
1187 are converted to eight-bit-control characters of the same character
1192 CHECK_STRING (string
);
1194 return string_to_multibyte (string
);
1198 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1199 doc
: /* Return a copy of ALIST.
1200 This is an alist which represents the same mapping from objects to objects,
1201 but does not share the alist structure with ALIST.
1202 The objects mapped (cars and cdrs of elements of the alist)
1203 are shared, however.
1204 Elements of ALIST that are not conses are also shared. */)
1208 register Lisp_Object tem
;
1213 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1214 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1216 register Lisp_Object car
;
1220 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1225 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1226 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1227 TO may be nil or omitted; then the substring runs to the end of STRING.
1228 FROM and TO start at 0. If either is negative, it counts from the end.
1230 This function allows vectors as well as strings. */)
1233 register Lisp_Object from
, to
;
1238 int from_char
, to_char
;
1239 int from_byte
= 0, to_byte
= 0;
1241 if (! (STRINGP (string
) || VECTORP (string
)))
1242 wrong_type_argument (Qarrayp
, string
);
1244 CHECK_NUMBER (from
);
1246 if (STRINGP (string
))
1248 size
= SCHARS (string
);
1249 size_byte
= SBYTES (string
);
1252 size
= XVECTOR (string
)->size
;
1257 to_byte
= size_byte
;
1263 to_char
= XINT (to
);
1267 if (STRINGP (string
))
1268 to_byte
= string_char_to_byte (string
, to_char
);
1271 from_char
= XINT (from
);
1274 if (STRINGP (string
))
1275 from_byte
= string_char_to_byte (string
, from_char
);
1277 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1278 args_out_of_range_3 (string
, make_number (from_char
),
1279 make_number (to_char
));
1281 if (STRINGP (string
))
1283 res
= make_specified_string (SDATA (string
) + from_byte
,
1284 to_char
- from_char
, to_byte
- from_byte
,
1285 STRING_MULTIBYTE (string
));
1286 copy_text_properties (make_number (from_char
), make_number (to_char
),
1287 string
, make_number (0), res
, Qnil
);
1290 res
= Fvector (to_char
- from_char
,
1291 XVECTOR (string
)->contents
+ from_char
);
1297 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1298 doc
: /* Return a substring of STRING, without text properties.
1299 It starts at index FROM and ending before TO.
1300 TO may be nil or omitted; then the substring runs to the end of STRING.
1301 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1302 If FROM or TO is negative, it counts from the end.
1304 With one argument, just copy STRING without its properties. */)
1307 register Lisp_Object from
, to
;
1309 int size
, size_byte
;
1310 int from_char
, to_char
;
1311 int from_byte
, to_byte
;
1313 CHECK_STRING (string
);
1315 size
= SCHARS (string
);
1316 size_byte
= SBYTES (string
);
1319 from_char
= from_byte
= 0;
1322 CHECK_NUMBER (from
);
1323 from_char
= XINT (from
);
1327 from_byte
= string_char_to_byte (string
, from_char
);
1333 to_byte
= size_byte
;
1339 to_char
= XINT (to
);
1343 to_byte
= string_char_to_byte (string
, to_char
);
1346 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1347 args_out_of_range_3 (string
, make_number (from_char
),
1348 make_number (to_char
));
1350 return make_specified_string (SDATA (string
) + from_byte
,
1351 to_char
- from_char
, to_byte
- from_byte
,
1352 STRING_MULTIBYTE (string
));
1355 /* Extract a substring of STRING, giving start and end positions
1356 both in characters and in bytes. */
1359 substring_both (string
, from
, from_byte
, to
, to_byte
)
1361 int from
, from_byte
, to
, to_byte
;
1367 if (! (STRINGP (string
) || VECTORP (string
)))
1368 wrong_type_argument (Qarrayp
, string
);
1370 if (STRINGP (string
))
1372 size
= SCHARS (string
);
1373 size_byte
= SBYTES (string
);
1376 size
= XVECTOR (string
)->size
;
1378 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1379 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1381 if (STRINGP (string
))
1383 res
= make_specified_string (SDATA (string
) + from_byte
,
1384 to
- from
, to_byte
- from_byte
,
1385 STRING_MULTIBYTE (string
));
1386 copy_text_properties (make_number (from
), make_number (to
),
1387 string
, make_number (0), res
, Qnil
);
1390 res
= Fvector (to
- from
,
1391 XVECTOR (string
)->contents
+ from
);
1396 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1397 doc
: /* Take cdr N times on LIST, returns the result. */)
1400 register Lisp_Object list
;
1402 register int i
, num
;
1405 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1409 wrong_type_argument (Qlistp
, list
);
1415 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1416 doc
: /* Return the Nth element of LIST.
1417 N counts from zero. If LIST is not that long, nil is returned. */)
1419 Lisp_Object n
, list
;
1421 return Fcar (Fnthcdr (n
, list
));
1424 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1425 doc
: /* Return element of SEQUENCE at index N. */)
1427 register Lisp_Object sequence
, n
;
1432 if (CONSP (sequence
) || NILP (sequence
))
1433 return Fcar (Fnthcdr (n
, sequence
));
1434 else if (STRINGP (sequence
) || VECTORP (sequence
)
1435 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1436 return Faref (sequence
, n
);
1438 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1442 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1443 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1444 The value is actually the tail of LIST whose car is ELT. */)
1446 register Lisp_Object elt
;
1449 register Lisp_Object tail
;
1450 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1452 register Lisp_Object tem
;
1454 wrong_type_argument (Qlistp
, list
);
1456 if (! NILP (Fequal (elt
, tem
)))
1463 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1464 doc
: /* Return non-nil if ELT is an element of LIST.
1465 Comparison done with EQ. The value is actually the tail of LIST
1466 whose car is ELT. */)
1468 Lisp_Object elt
, list
;
1472 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1476 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1480 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1487 if (!CONSP (list
) && !NILP (list
))
1488 list
= wrong_type_argument (Qlistp
, list
);
1493 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1494 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1495 The value is actually the element of LIST whose car is KEY.
1496 Elements of LIST that are not conses are ignored. */)
1498 Lisp_Object key
, list
;
1505 || (CONSP (XCAR (list
))
1506 && EQ (XCAR (XCAR (list
)), key
)))
1511 || (CONSP (XCAR (list
))
1512 && EQ (XCAR (XCAR (list
)), key
)))
1517 || (CONSP (XCAR (list
))
1518 && EQ (XCAR (XCAR (list
)), key
)))
1526 result
= XCAR (list
);
1527 else if (NILP (list
))
1530 result
= wrong_type_argument (Qlistp
, list
);
1535 /* Like Fassq but never report an error and do not allow quits.
1536 Use only on lists known never to be circular. */
1539 assq_no_quit (key
, list
)
1540 Lisp_Object key
, list
;
1543 && (!CONSP (XCAR (list
))
1544 || !EQ (XCAR (XCAR (list
)), key
)))
1547 return CONSP (list
) ? XCAR (list
) : Qnil
;
1550 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1551 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1552 The value is actually the element of LIST whose car equals KEY. */)
1554 Lisp_Object key
, list
;
1556 Lisp_Object result
, car
;
1561 || (CONSP (XCAR (list
))
1562 && (car
= XCAR (XCAR (list
)),
1563 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1568 || (CONSP (XCAR (list
))
1569 && (car
= XCAR (XCAR (list
)),
1570 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1575 || (CONSP (XCAR (list
))
1576 && (car
= XCAR (XCAR (list
)),
1577 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1585 result
= XCAR (list
);
1586 else if (NILP (list
))
1589 result
= wrong_type_argument (Qlistp
, list
);
1594 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1595 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1596 The value is actually the element of LIST whose cdr is KEY. */)
1598 register Lisp_Object key
;
1606 || (CONSP (XCAR (list
))
1607 && EQ (XCDR (XCAR (list
)), key
)))
1612 || (CONSP (XCAR (list
))
1613 && EQ (XCDR (XCAR (list
)), key
)))
1618 || (CONSP (XCAR (list
))
1619 && EQ (XCDR (XCAR (list
)), key
)))
1628 else if (CONSP (list
))
1629 result
= XCAR (list
);
1631 result
= wrong_type_argument (Qlistp
, list
);
1636 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1637 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1638 The value is actually the element of LIST whose cdr equals KEY. */)
1640 Lisp_Object key
, list
;
1642 Lisp_Object result
, cdr
;
1647 || (CONSP (XCAR (list
))
1648 && (cdr
= XCDR (XCAR (list
)),
1649 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1654 || (CONSP (XCAR (list
))
1655 && (cdr
= XCDR (XCAR (list
)),
1656 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1661 || (CONSP (XCAR (list
))
1662 && (cdr
= XCDR (XCAR (list
)),
1663 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1671 result
= XCAR (list
);
1672 else if (NILP (list
))
1675 result
= wrong_type_argument (Qlistp
, list
);
1680 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1681 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1682 The modified LIST is returned. Comparison is done with `eq'.
1683 If the first member of LIST is ELT, there is no way to remove it by side effect;
1684 therefore, write `(setq foo (delq element foo))'
1685 to be sure of changing the value of `foo'. */)
1687 register Lisp_Object elt
;
1690 register Lisp_Object tail
, prev
;
1691 register Lisp_Object tem
;
1695 while (!NILP (tail
))
1698 wrong_type_argument (Qlistp
, list
);
1705 Fsetcdr (prev
, XCDR (tail
));
1715 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1716 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1717 SEQ must be a list, a vector, or a string.
1718 The modified SEQ is returned. Comparison is done with `equal'.
1719 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1720 is not a side effect; it is simply using a different sequence.
1721 Therefore, write `(setq foo (delete element foo))'
1722 to be sure of changing the value of `foo'. */)
1724 Lisp_Object elt
, seq
;
1730 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1731 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1734 if (n
!= ASIZE (seq
))
1736 struct Lisp_Vector
*p
= allocate_vector (n
);
1738 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1739 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1740 p
->contents
[n
++] = AREF (seq
, i
);
1742 XSETVECTOR (seq
, p
);
1745 else if (STRINGP (seq
))
1747 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1750 for (i
= nchars
= nbytes
= ibyte
= 0;
1752 ++i
, ibyte
+= cbytes
)
1754 if (STRING_MULTIBYTE (seq
))
1756 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1757 SBYTES (seq
) - ibyte
);
1758 cbytes
= CHAR_BYTES (c
);
1766 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1773 if (nchars
!= SCHARS (seq
))
1777 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1778 if (!STRING_MULTIBYTE (seq
))
1779 STRING_SET_UNIBYTE (tem
);
1781 for (i
= nchars
= nbytes
= ibyte
= 0;
1783 ++i
, ibyte
+= cbytes
)
1785 if (STRING_MULTIBYTE (seq
))
1787 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1788 SBYTES (seq
) - ibyte
);
1789 cbytes
= CHAR_BYTES (c
);
1797 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1799 unsigned char *from
= SDATA (seq
) + ibyte
;
1800 unsigned char *to
= SDATA (tem
) + nbytes
;
1806 for (n
= cbytes
; n
--; )
1816 Lisp_Object tail
, prev
;
1818 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1821 wrong_type_argument (Qlistp
, seq
);
1823 if (!NILP (Fequal (elt
, XCAR (tail
))))
1828 Fsetcdr (prev
, XCDR (tail
));
1839 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1840 doc
: /* Reverse LIST by modifying cdr pointers.
1841 Returns the beginning of the reversed list. */)
1845 register Lisp_Object prev
, tail
, next
;
1847 if (NILP (list
)) return list
;
1850 while (!NILP (tail
))
1854 wrong_type_argument (Qlistp
, list
);
1856 Fsetcdr (tail
, prev
);
1863 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1864 doc
: /* Reverse LIST, copying. Returns the beginning of the reversed list.
1865 See also the function `nreverse', which is used more often. */)
1871 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1874 new = Fcons (XCAR (list
), new);
1877 wrong_type_argument (Qconsp
, list
);
1881 Lisp_Object
merge ();
1883 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1884 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1885 Returns the sorted list. LIST is modified by side effects.
1886 PREDICATE is called with two elements of LIST, and should return t
1887 if the first element is "less" than the second. */)
1889 Lisp_Object list
, predicate
;
1891 Lisp_Object front
, back
;
1892 register Lisp_Object len
, tem
;
1893 struct gcpro gcpro1
, gcpro2
;
1894 register int length
;
1897 len
= Flength (list
);
1898 length
= XINT (len
);
1902 XSETINT (len
, (length
/ 2) - 1);
1903 tem
= Fnthcdr (len
, list
);
1905 Fsetcdr (tem
, Qnil
);
1907 GCPRO2 (front
, back
);
1908 front
= Fsort (front
, predicate
);
1909 back
= Fsort (back
, predicate
);
1911 return merge (front
, back
, predicate
);
1915 merge (org_l1
, org_l2
, pred
)
1916 Lisp_Object org_l1
, org_l2
;
1920 register Lisp_Object tail
;
1922 register Lisp_Object l1
, l2
;
1923 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1930 /* It is sufficient to protect org_l1 and org_l2.
1931 When l1 and l2 are updated, we copy the new values
1932 back into the org_ vars. */
1933 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1953 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1969 Fsetcdr (tail
, tem
);
1975 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1976 doc
: /* Extract a value from a property list.
1977 PLIST is a property list, which is a list of the form
1978 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1979 corresponding to the given PROP, or nil if PROP is not
1980 one of the properties on the list. */)
1988 CONSP (tail
) && CONSP (XCDR (tail
));
1989 tail
= XCDR (XCDR (tail
)))
1991 if (EQ (prop
, XCAR (tail
)))
1992 return XCAR (XCDR (tail
));
1994 /* This function can be called asynchronously
1995 (setup_coding_system). Don't QUIT in that case. */
1996 if (!interrupt_input_blocked
)
2001 wrong_type_argument (Qlistp
, prop
);
2006 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2007 doc
: /* Return the value of SYMBOL's PROPNAME property.
2008 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2010 Lisp_Object symbol
, propname
;
2012 CHECK_SYMBOL (symbol
);
2013 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2016 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2017 doc
: /* Change value in PLIST of PROP to VAL.
2018 PLIST is a property list, which is a list of the form
2019 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2020 If PROP is already a property on the list, its value is set to VAL,
2021 otherwise the new PROP VAL pair is added. The new plist is returned;
2022 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2023 The PLIST is modified by side effects. */)
2026 register Lisp_Object prop
;
2029 register Lisp_Object tail
, prev
;
2030 Lisp_Object newcell
;
2032 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2033 tail
= XCDR (XCDR (tail
)))
2035 if (EQ (prop
, XCAR (tail
)))
2037 Fsetcar (XCDR (tail
), val
);
2044 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2048 Fsetcdr (XCDR (prev
), newcell
);
2052 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2053 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2054 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2055 (symbol
, propname
, value
)
2056 Lisp_Object symbol
, propname
, value
;
2058 CHECK_SYMBOL (symbol
);
2059 XSYMBOL (symbol
)->plist
2060 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2064 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2065 doc
: /* Extract a value from a property list, comparing with `equal'.
2066 PLIST is a property list, which is a list of the form
2067 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2068 corresponding to the given PROP, or nil if PROP is not
2069 one of the properties on the list. */)
2077 CONSP (tail
) && CONSP (XCDR (tail
));
2078 tail
= XCDR (XCDR (tail
)))
2080 if (! NILP (Fequal (prop
, XCAR (tail
))))
2081 return XCAR (XCDR (tail
));
2087 wrong_type_argument (Qlistp
, prop
);
2092 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2093 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2094 PLIST is a property list, which is a list of the form
2095 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2096 If PROP is already a property on the list, its value is set to VAL,
2097 otherwise the new PROP VAL pair is added. The new plist is returned;
2098 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2099 The PLIST is modified by side effects. */)
2102 register Lisp_Object prop
;
2105 register Lisp_Object tail
, prev
;
2106 Lisp_Object newcell
;
2108 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2109 tail
= XCDR (XCDR (tail
)))
2111 if (! NILP (Fequal (prop
, XCAR (tail
))))
2113 Fsetcar (XCDR (tail
), val
);
2120 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2124 Fsetcdr (XCDR (prev
), newcell
);
2128 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2129 doc
: /* Return t if two Lisp objects have similar structure and contents.
2130 They must have the same data type.
2131 Conses are compared by comparing the cars and the cdrs.
2132 Vectors and strings are compared element by element.
2133 Numbers are compared by value, but integers cannot equal floats.
2134 (Use `=' if you want integers and floats to be able to be equal.)
2135 Symbols must match exactly. */)
2137 register Lisp_Object o1
, o2
;
2139 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2143 internal_equal (o1
, o2
, depth
)
2144 register Lisp_Object o1
, o2
;
2148 error ("Stack overflow in equal");
2154 if (XTYPE (o1
) != XTYPE (o2
))
2160 return (extract_float (o1
) == extract_float (o2
));
2163 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2170 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2174 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2176 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2179 o1
= XOVERLAY (o1
)->plist
;
2180 o2
= XOVERLAY (o2
)->plist
;
2185 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2186 && (XMARKER (o1
)->buffer
== 0
2187 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2191 case Lisp_Vectorlike
:
2193 register int i
, size
;
2194 size
= XVECTOR (o1
)->size
;
2195 /* Pseudovectors have the type encoded in the size field, so this test
2196 actually checks that the objects have the same type as well as the
2198 if (XVECTOR (o2
)->size
!= size
)
2200 /* Boolvectors are compared much like strings. */
2201 if (BOOL_VECTOR_P (o1
))
2204 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2206 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2208 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2213 if (WINDOW_CONFIGURATIONP (o1
))
2214 return compare_window_configurations (o1
, o2
, 0);
2216 /* Aside from them, only true vectors, char-tables, and compiled
2217 functions are sensible to compare, so eliminate the others now. */
2218 if (size
& PSEUDOVECTOR_FLAG
)
2220 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2222 size
&= PSEUDOVECTOR_SIZE_MASK
;
2224 for (i
= 0; i
< size
; i
++)
2227 v1
= XVECTOR (o1
)->contents
[i
];
2228 v2
= XVECTOR (o2
)->contents
[i
];
2229 if (!internal_equal (v1
, v2
, depth
+ 1))
2237 if (SCHARS (o1
) != SCHARS (o2
))
2239 if (SBYTES (o1
) != SBYTES (o2
))
2241 if (bcmp (SDATA (o1
), SDATA (o2
),
2248 case Lisp_Type_Limit
:
2255 extern Lisp_Object
Fmake_char_internal ();
2257 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2258 doc
: /* Store each element of ARRAY with ITEM.
2259 ARRAY is a vector, string, char-table, or bool-vector. */)
2261 Lisp_Object array
, item
;
2263 register int size
, index
, charval
;
2265 if (VECTORP (array
))
2267 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2268 size
= XVECTOR (array
)->size
;
2269 for (index
= 0; index
< size
; index
++)
2272 else if (CHAR_TABLE_P (array
))
2274 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2275 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2276 for (index
= 0; index
< size
; index
++)
2278 XCHAR_TABLE (array
)->defalt
= Qnil
;
2280 else if (STRINGP (array
))
2282 register unsigned char *p
= SDATA (array
);
2283 CHECK_NUMBER (item
);
2284 charval
= XINT (item
);
2285 size
= SCHARS (array
);
2286 if (STRING_MULTIBYTE (array
))
2288 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2289 int len
= CHAR_STRING (charval
, str
);
2290 int size_byte
= SBYTES (array
);
2291 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2294 if (size
!= size_byte
)
2297 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2298 if (len
!= this_len
)
2299 error ("Attempt to change byte length of a string");
2302 for (i
= 0; i
< size_byte
; i
++)
2303 *p
++ = str
[i
% len
];
2306 for (index
= 0; index
< size
; index
++)
2309 else if (BOOL_VECTOR_P (array
))
2311 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2313 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2315 charval
= (! NILP (item
) ? -1 : 0);
2316 for (index
= 0; index
< size_in_chars
; index
++)
2321 array
= wrong_type_argument (Qarrayp
, array
);
2327 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2329 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2331 Lisp_Object char_table
;
2333 CHECK_CHAR_TABLE (char_table
);
2335 return XCHAR_TABLE (char_table
)->purpose
;
2338 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2340 doc
: /* Return the parent char-table of CHAR-TABLE.
2341 The value is either nil or another char-table.
2342 If CHAR-TABLE holds nil for a given character,
2343 then the actual applicable value is inherited from the parent char-table
2344 \(or from its parents, if necessary). */)
2346 Lisp_Object char_table
;
2348 CHECK_CHAR_TABLE (char_table
);
2350 return XCHAR_TABLE (char_table
)->parent
;
2353 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2355 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2356 PARENT must be either nil or another char-table. */)
2357 (char_table
, parent
)
2358 Lisp_Object char_table
, parent
;
2362 CHECK_CHAR_TABLE (char_table
);
2366 CHECK_CHAR_TABLE (parent
);
2368 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2369 if (EQ (temp
, char_table
))
2370 error ("Attempt to make a chartable be its own parent");
2373 XCHAR_TABLE (char_table
)->parent
= parent
;
2378 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2380 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2382 Lisp_Object char_table
, n
;
2384 CHECK_CHAR_TABLE (char_table
);
2387 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2388 args_out_of_range (char_table
, n
);
2390 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2393 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2394 Sset_char_table_extra_slot
,
2396 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2397 (char_table
, n
, value
)
2398 Lisp_Object char_table
, n
, value
;
2400 CHECK_CHAR_TABLE (char_table
);
2403 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2404 args_out_of_range (char_table
, n
);
2406 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2409 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2411 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2412 RANGE should be nil (for the default value)
2413 a vector which identifies a character set or a row of a character set,
2414 a character set name, or a character code. */)
2416 Lisp_Object char_table
, range
;
2418 CHECK_CHAR_TABLE (char_table
);
2420 if (EQ (range
, Qnil
))
2421 return XCHAR_TABLE (char_table
)->defalt
;
2422 else if (INTEGERP (range
))
2423 return Faref (char_table
, range
);
2424 else if (SYMBOLP (range
))
2426 Lisp_Object charset_info
;
2428 charset_info
= Fget (range
, Qcharset
);
2429 CHECK_VECTOR (charset_info
);
2431 return Faref (char_table
,
2432 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2435 else if (VECTORP (range
))
2437 if (XVECTOR (range
)->size
== 1)
2438 return Faref (char_table
,
2439 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2442 int size
= XVECTOR (range
)->size
;
2443 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2444 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2445 size
<= 1 ? Qnil
: val
[1],
2446 size
<= 2 ? Qnil
: val
[2]);
2447 return Faref (char_table
, ch
);
2451 error ("Invalid RANGE argument to `char-table-range'");
2455 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2457 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2458 RANGE should be t (for all characters), nil (for the default value)
2459 a vector which identifies a character set or a row of a character set,
2460 a coding system, or a character code. */)
2461 (char_table
, range
, value
)
2462 Lisp_Object char_table
, range
, value
;
2466 CHECK_CHAR_TABLE (char_table
);
2469 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2470 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2471 else if (EQ (range
, Qnil
))
2472 XCHAR_TABLE (char_table
)->defalt
= value
;
2473 else if (SYMBOLP (range
))
2475 Lisp_Object charset_info
;
2477 charset_info
= Fget (range
, Qcharset
);
2478 CHECK_VECTOR (charset_info
);
2480 return Faset (char_table
,
2481 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2485 else if (INTEGERP (range
))
2486 Faset (char_table
, range
, value
);
2487 else if (VECTORP (range
))
2489 if (XVECTOR (range
)->size
== 1)
2490 return Faset (char_table
,
2491 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2495 int size
= XVECTOR (range
)->size
;
2496 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2497 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2498 size
<= 1 ? Qnil
: val
[1],
2499 size
<= 2 ? Qnil
: val
[2]);
2500 return Faset (char_table
, ch
, value
);
2504 error ("Invalid RANGE argument to `set-char-table-range'");
2509 DEFUN ("set-char-table-default", Fset_char_table_default
,
2510 Sset_char_table_default
, 3, 3, 0,
2511 doc
: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
2512 The generic character specifies the group of characters.
2513 See also the documentation of make-char. */)
2514 (char_table
, ch
, value
)
2515 Lisp_Object char_table
, ch
, value
;
2517 int c
, charset
, code1
, code2
;
2520 CHECK_CHAR_TABLE (char_table
);
2524 SPLIT_CHAR (c
, charset
, code1
, code2
);
2526 /* Since we may want to set the default value for a character set
2527 not yet defined, we check only if the character set is in the
2528 valid range or not, instead of it is already defined or not. */
2529 if (! CHARSET_VALID_P (charset
))
2530 invalid_character (c
);
2532 if (charset
== CHARSET_ASCII
)
2533 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2535 /* Even if C is not a generic char, we had better behave as if a
2536 generic char is specified. */
2537 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2539 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2542 if (SUB_CHAR_TABLE_P (temp
))
2543 XCHAR_TABLE (temp
)->defalt
= value
;
2545 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2548 if (SUB_CHAR_TABLE_P (temp
))
2551 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2552 = make_sub_char_table (temp
));
2553 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2554 if (SUB_CHAR_TABLE_P (temp
))
2555 XCHAR_TABLE (temp
)->defalt
= value
;
2557 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2561 /* Look up the element in TABLE at index CH,
2562 and return it as an integer.
2563 If the element is nil, return CH itself.
2564 (Actually we do that for any non-integer.) */
2567 char_table_translate (table
, ch
)
2572 value
= Faref (table
, make_number (ch
));
2573 if (! INTEGERP (value
))
2575 return XINT (value
);
2579 optimize_sub_char_table (table
, chars
)
2587 from
= 33, to
= 127;
2589 from
= 32, to
= 128;
2591 if (!SUB_CHAR_TABLE_P (*table
))
2593 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2594 for (; from
< to
; from
++)
2595 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2600 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2601 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2609 CHECK_CHAR_TABLE (table
);
2611 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2613 elt
= XCHAR_TABLE (table
)->contents
[i
];
2614 if (!SUB_CHAR_TABLE_P (elt
))
2616 dim
= CHARSET_DIMENSION (i
- 128);
2618 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2619 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2620 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2626 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2627 character or group of characters that share a value.
2628 DEPTH is the current depth in the originally specified
2629 chartable, and INDICES contains the vector indices
2630 for the levels our callers have descended.
2632 ARG is passed to C_FUNCTION when that is called. */
2635 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2636 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2637 Lisp_Object function
, subtable
, arg
, *indices
;
2644 /* At first, handle ASCII and 8-bit European characters. */
2645 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2647 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2649 (*c_function
) (arg
, make_number (i
), elt
);
2651 call2 (function
, make_number (i
), elt
);
2653 #if 0 /* If the char table has entries for higher characters,
2654 we should report them. */
2655 if (NILP (current_buffer
->enable_multibyte_characters
))
2658 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2662 int charset
= XFASTINT (indices
[0]) - 128;
2665 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2666 if (CHARSET_CHARS (charset
) == 94)
2675 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2676 XSETFASTINT (indices
[depth
], i
);
2677 charset
= XFASTINT (indices
[0]) - 128;
2679 && (!CHARSET_DEFINED_P (charset
)
2680 || charset
== CHARSET_8_BIT_CONTROL
2681 || charset
== CHARSET_8_BIT_GRAPHIC
))
2684 if (SUB_CHAR_TABLE_P (elt
))
2687 error ("Too deep char table");
2688 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2695 elt
= XCHAR_TABLE (subtable
)->defalt
;
2696 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2697 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2698 c
= MAKE_CHAR (charset
, c1
, c2
);
2700 (*c_function
) (arg
, make_number (c
), elt
);
2702 call2 (function
, make_number (c
), elt
);
2707 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2709 void_call2 (a
, b
, c
)
2710 Lisp_Object a
, b
, c
;
2715 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2717 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2718 FUNCTION is called with two arguments--a key and a value.
2719 The key is always a possible IDX argument to `aref'. */)
2720 (function
, char_table
)
2721 Lisp_Object function
, char_table
;
2723 /* The depth of char table is at most 3. */
2724 Lisp_Object indices
[3];
2726 CHECK_CHAR_TABLE (char_table
);
2728 /* When Lisp_Object is represented as a union, `call2' cannot directly
2729 be passed to map_char_table because it returns a Lisp_Object rather
2730 than returning nothing.
2731 Casting leads to crashes on some architectures. -stef */
2732 map_char_table (void_call2
, Qnil
, char_table
, function
, 0, indices
);
2736 /* Return a value for character C in char-table TABLE. Store the
2737 actual index for that value in *IDX. Ignore the default value of
2741 char_table_ref_and_index (table
, c
, idx
)
2745 int charset
, c1
, c2
;
2748 if (SINGLE_BYTE_CHAR_P (c
))
2751 return XCHAR_TABLE (table
)->contents
[c
];
2753 SPLIT_CHAR (c
, charset
, c1
, c2
);
2754 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2755 *idx
= MAKE_CHAR (charset
, 0, 0);
2756 if (!SUB_CHAR_TABLE_P (elt
))
2758 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2759 return XCHAR_TABLE (elt
)->defalt
;
2760 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2761 *idx
= MAKE_CHAR (charset
, c1
, 0);
2762 if (!SUB_CHAR_TABLE_P (elt
))
2764 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2765 return XCHAR_TABLE (elt
)->defalt
;
2767 return XCHAR_TABLE (elt
)->contents
[c2
];
2777 Lisp_Object args
[2];
2780 return Fnconc (2, args
);
2782 return Fnconc (2, &s1
);
2783 #endif /* NO_ARG_ARRAY */
2786 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2787 doc
: /* Concatenate any number of lists by altering them.
2788 Only the last argument is not altered, and need not be a list.
2789 usage: (nconc &rest LISTS) */)
2794 register int argnum
;
2795 register Lisp_Object tail
, tem
, val
;
2799 for (argnum
= 0; argnum
< nargs
; argnum
++)
2802 if (NILP (tem
)) continue;
2807 if (argnum
+ 1 == nargs
) break;
2810 tem
= wrong_type_argument (Qlistp
, tem
);
2819 tem
= args
[argnum
+ 1];
2820 Fsetcdr (tail
, tem
);
2822 args
[argnum
+ 1] = tail
;
2828 /* This is the guts of all mapping functions.
2829 Apply FN to each element of SEQ, one by one,
2830 storing the results into elements of VALS, a C vector of Lisp_Objects.
2831 LENI is the length of VALS, which should also be the length of SEQ. */
2834 mapcar1 (leni
, vals
, fn
, seq
)
2837 Lisp_Object fn
, seq
;
2839 register Lisp_Object tail
;
2842 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2846 /* Don't let vals contain any garbage when GC happens. */
2847 for (i
= 0; i
< leni
; i
++)
2850 GCPRO3 (dummy
, fn
, seq
);
2852 gcpro1
.nvars
= leni
;
2856 /* We need not explicitly protect `tail' because it is used only on lists, and
2857 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2861 for (i
= 0; i
< leni
; i
++)
2863 dummy
= XVECTOR (seq
)->contents
[i
];
2864 dummy
= call1 (fn
, dummy
);
2869 else if (BOOL_VECTOR_P (seq
))
2871 for (i
= 0; i
< leni
; i
++)
2874 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2875 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2880 dummy
= call1 (fn
, dummy
);
2885 else if (STRINGP (seq
))
2889 for (i
= 0, i_byte
= 0; i
< leni
;)
2894 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2895 XSETFASTINT (dummy
, c
);
2896 dummy
= call1 (fn
, dummy
);
2898 vals
[i_before
] = dummy
;
2901 else /* Must be a list, since Flength did not get an error */
2904 for (i
= 0; i
< leni
; i
++)
2906 dummy
= call1 (fn
, Fcar (tail
));
2916 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2917 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2918 In between each pair of results, stick in SEPARATOR. Thus, " " as
2919 SEPARATOR results in spaces between the values returned by FUNCTION.
2920 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2921 (function
, sequence
, separator
)
2922 Lisp_Object function
, sequence
, separator
;
2927 register Lisp_Object
*args
;
2929 struct gcpro gcpro1
;
2931 len
= Flength (sequence
);
2933 nargs
= leni
+ leni
- 1;
2934 if (nargs
< 0) return build_string ("");
2936 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2939 mapcar1 (leni
, args
, function
, sequence
);
2942 for (i
= leni
- 1; i
>= 0; i
--)
2943 args
[i
+ i
] = args
[i
];
2945 for (i
= 1; i
< nargs
; i
+= 2)
2946 args
[i
] = separator
;
2948 return Fconcat (nargs
, args
);
2951 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2952 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2953 The result is a list just as long as SEQUENCE.
2954 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2955 (function
, sequence
)
2956 Lisp_Object function
, sequence
;
2958 register Lisp_Object len
;
2960 register Lisp_Object
*args
;
2962 len
= Flength (sequence
);
2963 leni
= XFASTINT (len
);
2964 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2966 mapcar1 (leni
, args
, function
, sequence
);
2968 return Flist (leni
, args
);
2971 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2972 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2973 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2974 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2975 (function
, sequence
)
2976 Lisp_Object function
, sequence
;
2980 leni
= XFASTINT (Flength (sequence
));
2981 mapcar1 (leni
, 0, function
, sequence
);
2986 /* Anything that calls this function must protect from GC! */
2988 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2989 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2990 Takes one argument, which is the string to display to ask the question.
2991 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2992 No confirmation of the answer is requested; a single character is enough.
2993 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2994 the bindings in `query-replace-map'; see the documentation of that variable
2995 for more information. In this case, the useful bindings are `act', `skip',
2996 `recenter', and `quit'.\)
2998 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2999 is nil and `use-dialog-box' is non-nil. */)
3003 register Lisp_Object obj
, key
, def
, map
;
3004 register int answer
;
3005 Lisp_Object xprompt
;
3006 Lisp_Object args
[2];
3007 struct gcpro gcpro1
, gcpro2
;
3008 int count
= SPECPDL_INDEX ();
3010 specbind (Qcursor_in_echo_area
, Qt
);
3012 map
= Fsymbol_value (intern ("query-replace-map"));
3014 CHECK_STRING (prompt
);
3016 GCPRO2 (prompt
, xprompt
);
3018 #ifdef HAVE_X_WINDOWS
3019 if (display_hourglass_p
)
3020 cancel_hourglass ();
3027 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3031 Lisp_Object pane
, menu
;
3032 redisplay_preserve_echo_area (3);
3033 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3034 Fcons (Fcons (build_string ("No"), Qnil
),
3036 menu
= Fcons (prompt
, pane
);
3037 obj
= Fx_popup_dialog (Qt
, menu
);
3038 answer
= !NILP (obj
);
3041 #endif /* HAVE_MENUS */
3042 cursor_in_echo_area
= 1;
3043 choose_minibuf_frame ();
3046 Lisp_Object pargs
[3];
3048 /* Colorize prompt according to `minibuffer-prompt' face. */
3049 pargs
[0] = build_string ("%s(y or n) ");
3050 pargs
[1] = intern ("face");
3051 pargs
[2] = intern ("minibuffer-prompt");
3052 args
[0] = Fpropertize (3, pargs
);
3057 if (minibuffer_auto_raise
)
3059 Lisp_Object mini_frame
;
3061 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3063 Fraise_frame (mini_frame
);
3066 obj
= read_filtered_event (1, 0, 0, 0);
3067 cursor_in_echo_area
= 0;
3068 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3071 key
= Fmake_vector (make_number (1), obj
);
3072 def
= Flookup_key (map
, key
, Qt
);
3074 if (EQ (def
, intern ("skip")))
3079 else if (EQ (def
, intern ("act")))
3084 else if (EQ (def
, intern ("recenter")))
3090 else if (EQ (def
, intern ("quit")))
3092 /* We want to exit this command for exit-prefix,
3093 and this is the only way to do it. */
3094 else if (EQ (def
, intern ("exit-prefix")))
3099 /* If we don't clear this, then the next call to read_char will
3100 return quit_char again, and we'll enter an infinite loop. */
3105 if (EQ (xprompt
, prompt
))
3107 args
[0] = build_string ("Please answer y or n. ");
3109 xprompt
= Fconcat (2, args
);
3114 if (! noninteractive
)
3116 cursor_in_echo_area
= -1;
3117 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3121 unbind_to (count
, Qnil
);
3122 return answer
? Qt
: Qnil
;
3125 /* This is how C code calls `yes-or-no-p' and allows the user
3128 Anything that calls this function must protect from GC! */
3131 do_yes_or_no_p (prompt
)
3134 return call1 (intern ("yes-or-no-p"), prompt
);
3137 /* Anything that calls this function must protect from GC! */
3139 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3140 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3141 Takes one argument, which is the string to display to ask the question.
3142 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3143 The user must confirm the answer with RET,
3144 and can edit it until it has been confirmed.
3146 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3147 is nil, and `use-dialog-box' is non-nil. */)
3151 register Lisp_Object ans
;
3152 Lisp_Object args
[2];
3153 struct gcpro gcpro1
;
3155 CHECK_STRING (prompt
);
3158 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3162 Lisp_Object pane
, menu
, obj
;
3163 redisplay_preserve_echo_area (4);
3164 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3165 Fcons (Fcons (build_string ("No"), Qnil
),
3168 menu
= Fcons (prompt
, pane
);
3169 obj
= Fx_popup_dialog (Qt
, menu
);
3173 #endif /* HAVE_MENUS */
3176 args
[1] = build_string ("(yes or no) ");
3177 prompt
= Fconcat (2, args
);
3183 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3184 Qyes_or_no_p_history
, Qnil
,
3186 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3191 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3199 message ("Please answer yes or no.");
3200 Fsleep_for (make_number (2), Qnil
);
3204 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3205 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3207 Each of the three load averages is multiplied by 100, then converted
3210 When USE-FLOATS is non-nil, floats will be used instead of integers.
3211 These floats are not multiplied by 100.
3213 If the 5-minute or 15-minute load averages are not available, return a
3214 shortened list, containing only those averages which are available. */)
3216 Lisp_Object use_floats
;
3219 int loads
= getloadavg (load_ave
, 3);
3220 Lisp_Object ret
= Qnil
;
3223 error ("load-average not implemented for this operating system");
3227 Lisp_Object load
= (NILP (use_floats
) ?
3228 make_number ((int) (100.0 * load_ave
[loads
]))
3229 : make_float (load_ave
[loads
]));
3230 ret
= Fcons (load
, ret
);
3236 Lisp_Object Vfeatures
, Qsubfeatures
;
3237 extern Lisp_Object Vafter_load_alist
;
3239 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3240 doc
: /* Returns t if FEATURE is present in this Emacs.
3242 Use this to conditionalize execution of lisp code based on the
3243 presence or absence of emacs or environment extensions.
3244 Use `provide' to declare that a feature is available. This function
3245 looks at the value of the variable `features'. The optional argument
3246 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3247 (feature
, subfeature
)
3248 Lisp_Object feature
, subfeature
;
3250 register Lisp_Object tem
;
3251 CHECK_SYMBOL (feature
);
3252 tem
= Fmemq (feature
, Vfeatures
);
3253 if (!NILP (tem
) && !NILP (subfeature
))
3254 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3255 return (NILP (tem
)) ? Qnil
: Qt
;
3258 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3259 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3260 The optional argument SUBFEATURES should be a list of symbols listing
3261 particular subfeatures supported in this version of FEATURE. */)
3262 (feature
, subfeatures
)
3263 Lisp_Object feature
, subfeatures
;
3265 register Lisp_Object tem
;
3266 CHECK_SYMBOL (feature
);
3267 CHECK_LIST (subfeatures
);
3268 if (!NILP (Vautoload_queue
))
3269 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3270 tem
= Fmemq (feature
, Vfeatures
);
3272 Vfeatures
= Fcons (feature
, Vfeatures
);
3273 if (!NILP (subfeatures
))
3274 Fput (feature
, Qsubfeatures
, subfeatures
);
3275 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3277 /* Run any load-hooks for this file. */
3278 tem
= Fassq (feature
, Vafter_load_alist
);
3280 Fprogn (XCDR (tem
));
3285 /* `require' and its subroutines. */
3287 /* List of features currently being require'd, innermost first. */
3289 Lisp_Object require_nesting_list
;
3292 require_unwind (old_value
)
3293 Lisp_Object old_value
;
3295 return require_nesting_list
= old_value
;
3298 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3299 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3300 If FEATURE is not a member of the list `features', then the feature
3301 is not loaded; so load the file FILENAME.
3302 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3303 and `load' will try to load this name appended with the suffix `.elc',
3304 `.el' or the unmodified name, in that order.
3305 If the optional third argument NOERROR is non-nil,
3306 then return nil if the file is not found instead of signaling an error.
3307 Normally the return value is FEATURE.
3308 The normal messages at start and end of loading FILENAME are suppressed. */)
3309 (feature
, filename
, noerror
)
3310 Lisp_Object feature
, filename
, noerror
;
3312 register Lisp_Object tem
;
3313 struct gcpro gcpro1
, gcpro2
;
3315 CHECK_SYMBOL (feature
);
3317 tem
= Fmemq (feature
, Vfeatures
);
3321 int count
= SPECPDL_INDEX ();
3324 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3326 /* This is to make sure that loadup.el gives a clear picture
3327 of what files are preloaded and when. */
3328 if (! NILP (Vpurify_flag
))
3329 error ("(require %s) while preparing to dump",
3330 SDATA (SYMBOL_NAME (feature
)));
3332 /* A certain amount of recursive `require' is legitimate,
3333 but if we require the same feature recursively 3 times,
3335 tem
= require_nesting_list
;
3336 while (! NILP (tem
))
3338 if (! NILP (Fequal (feature
, XCAR (tem
))))
3343 error ("Recursive `require' for feature `%s'",
3344 SDATA (SYMBOL_NAME (feature
)));
3346 /* Update the list for any nested `require's that occur. */
3347 record_unwind_protect (require_unwind
, require_nesting_list
);
3348 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3350 /* Value saved here is to be restored into Vautoload_queue */
3351 record_unwind_protect (un_autoload
, Vautoload_queue
);
3352 Vautoload_queue
= Qt
;
3354 /* Load the file. */
3355 GCPRO2 (feature
, filename
);
3356 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3357 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3360 /* If load failed entirely, return nil. */
3362 return unbind_to (count
, Qnil
);
3364 tem
= Fmemq (feature
, Vfeatures
);
3366 error ("Required feature `%s' was not provided",
3367 SDATA (SYMBOL_NAME (feature
)));
3369 /* Once loading finishes, don't undo it. */
3370 Vautoload_queue
= Qt
;
3371 feature
= unbind_to (count
, feature
);
3377 /* Primitives for work of the "widget" library.
3378 In an ideal world, this section would not have been necessary.
3379 However, lisp function calls being as slow as they are, it turns
3380 out that some functions in the widget library (wid-edit.el) are the
3381 bottleneck of Widget operation. Here is their translation to C,
3382 for the sole reason of efficiency. */
3384 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3385 doc
: /* Return non-nil if PLIST has the property PROP.
3386 PLIST is a property list, which is a list of the form
3387 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3388 Unlike `plist-get', this allows you to distinguish between a missing
3389 property and a property with the value nil.
3390 The value is actually the tail of PLIST whose car is PROP. */)
3392 Lisp_Object plist
, prop
;
3394 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3397 plist
= XCDR (plist
);
3398 plist
= CDR (plist
);
3403 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3404 doc
: /* In WIDGET, set PROPERTY to VALUE.
3405 The value can later be retrieved with `widget-get'. */)
3406 (widget
, property
, value
)
3407 Lisp_Object widget
, property
, value
;
3409 CHECK_CONS (widget
);
3410 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3414 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3415 doc
: /* In WIDGET, get the value of PROPERTY.
3416 The value could either be specified when the widget was created, or
3417 later with `widget-put'. */)
3419 Lisp_Object widget
, property
;
3427 CHECK_CONS (widget
);
3428 tmp
= Fplist_member (XCDR (widget
), property
);
3434 tmp
= XCAR (widget
);
3437 widget
= Fget (tmp
, Qwidget_type
);
3441 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3442 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3443 ARGS are passed as extra arguments to the function.
3444 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3449 /* This function can GC. */
3450 Lisp_Object newargs
[3];
3451 struct gcpro gcpro1
, gcpro2
;
3454 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3455 newargs
[1] = args
[0];
3456 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3457 GCPRO2 (newargs
[0], newargs
[2]);
3458 result
= Fapply (3, newargs
);
3463 #ifdef HAVE_LANGINFO_CODESET
3464 #include <langinfo.h>
3467 DEFUN ("langinfo", Flanginfo
, Slanginfo
, 1, 1, 0,
3468 doc
: /* Access locale data ITEM, if available.
3470 ITEM may be one of the following:
3471 `codeset', returning the character set as a string (locale item CODESET);
3472 `days', returning a 7-element vector of day names (locale items DAY_n);
3473 `months', returning a 12-element vector of month names (locale items MON_n);
3474 `paper', returning a list (WIDTH, HEIGHT) for the default paper size,
3475 where the width and height are in mm (locale items PAPER_WIDTH,
3478 If the system can't provide such information through a call to
3479 nl_langinfo(3), return nil.
3481 See also Info node `(libc)Locales'.
3483 The data read from the system are decoded using `locale-coding-system'. */)
3488 #ifdef HAVE_LANGINFO_CODESET
3490 if (EQ (item
, Qcodeset
))
3492 str
= nl_langinfo (CODESET
);
3493 return build_string (str
);
3496 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3498 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3499 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3501 synchronize_system_time_locale ();
3502 for (i
= 0; i
< 7; i
++)
3504 str
= nl_langinfo (days
[i
]);
3505 val
= make_unibyte_string (str
, strlen (str
));
3506 /* Fixme: Is this coding system necessarily right, even if
3507 it is consistent with CODESET? If not, what to do? */
3508 Faset (v
, make_number (i
),
3509 code_convert_string_norecord (val
, Vlocale_coding_system
,
3516 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3518 struct Lisp_Vector
*p
= allocate_vector (12);
3519 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3520 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3522 synchronize_system_time_locale ();
3523 for (i
= 0; i
< 12; i
++)
3525 str
= nl_langinfo (months
[i
]);
3526 val
= make_unibyte_string (str
, strlen (str
));
3528 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3530 XSETVECTOR (val
, p
);
3534 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3535 but is in the locale files. This could be used by ps-print. */
3537 else if (EQ (item
, Qpaper
))
3539 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3540 make_number (nl_langinfo (PAPER_HEIGHT
)));
3542 #endif /* PAPER_WIDTH */
3543 #endif /* HAVE_LANGINFO_CODESET*/
3547 /* base64 encode/decode functions (RFC 2045).
3548 Based on code from GNU recode. */
3550 #define MIME_LINE_LENGTH 76
3552 #define IS_ASCII(Character) \
3554 #define IS_BASE64(Character) \
3555 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3556 #define IS_BASE64_IGNORABLE(Character) \
3557 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3558 || (Character) == '\f' || (Character) == '\r')
3560 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3561 character or return retval if there are no characters left to
3563 #define READ_QUADRUPLET_BYTE(retval) \
3568 if (nchars_return) \
3569 *nchars_return = nchars; \
3574 while (IS_BASE64_IGNORABLE (c))
3576 /* Don't use alloca for regions larger than this, lest we overflow
3578 #define MAX_ALLOCA 16*1024
3580 /* Table of characters coding the 64 values. */
3581 static char base64_value_to_char
[64] =
3583 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3584 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3585 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3586 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3587 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3588 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3589 '8', '9', '+', '/' /* 60-63 */
3592 /* Table of base64 values for first 128 characters. */
3593 static short base64_char_to_value
[128] =
3595 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3596 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3597 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3598 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3599 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3600 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3601 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3602 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3603 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3604 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3605 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3606 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3607 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3610 /* The following diagram shows the logical steps by which three octets
3611 get transformed into four base64 characters.
3613 .--------. .--------. .--------.
3614 |aaaaaabb| |bbbbcccc| |ccdddddd|
3615 `--------' `--------' `--------'
3617 .--------+--------+--------+--------.
3618 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3619 `--------+--------+--------+--------'
3621 .--------+--------+--------+--------.
3622 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3623 `--------+--------+--------+--------'
3625 The octets are divided into 6 bit chunks, which are then encoded into
3626 base64 characters. */
3629 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3630 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3632 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3634 doc
: /* Base64-encode the region between BEG and END.
3635 Return the length of the encoded text.
3636 Optional third argument NO-LINE-BREAK means do not break long lines
3637 into shorter lines. */)
3638 (beg
, end
, no_line_break
)
3639 Lisp_Object beg
, end
, no_line_break
;
3642 int allength
, length
;
3643 int ibeg
, iend
, encoded_length
;
3646 validate_region (&beg
, &end
);
3648 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3649 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3650 move_gap_both (XFASTINT (beg
), ibeg
);
3652 /* We need to allocate enough room for encoding the text.
3653 We need 33 1/3% more space, plus a newline every 76
3654 characters, and then we round up. */
3655 length
= iend
- ibeg
;
3656 allength
= length
+ length
/3 + 1;
3657 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3659 if (allength
<= MAX_ALLOCA
)
3660 encoded
= (char *) alloca (allength
);
3662 encoded
= (char *) xmalloc (allength
);
3663 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3664 NILP (no_line_break
),
3665 !NILP (current_buffer
->enable_multibyte_characters
));
3666 if (encoded_length
> allength
)
3669 if (encoded_length
< 0)
3671 /* The encoding wasn't possible. */
3672 if (length
> MAX_ALLOCA
)
3674 error ("Multibyte character in data for base64 encoding");
3677 /* Now we have encoded the region, so we insert the new contents
3678 and delete the old. (Insert first in order to preserve markers.) */
3679 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3680 insert (encoded
, encoded_length
);
3681 if (allength
> MAX_ALLOCA
)
3683 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3685 /* If point was outside of the region, restore it exactly; else just
3686 move to the beginning of the region. */
3687 if (old_pos
>= XFASTINT (end
))
3688 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3689 else if (old_pos
> XFASTINT (beg
))
3690 old_pos
= XFASTINT (beg
);
3693 /* We return the length of the encoded text. */
3694 return make_number (encoded_length
);
3697 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3699 doc
: /* Base64-encode STRING and return the result.
3700 Optional second argument NO-LINE-BREAK means do not break long lines
3701 into shorter lines. */)
3702 (string
, no_line_break
)
3703 Lisp_Object string
, no_line_break
;
3705 int allength
, length
, encoded_length
;
3707 Lisp_Object encoded_string
;
3709 CHECK_STRING (string
);
3711 /* We need to allocate enough room for encoding the text.
3712 We need 33 1/3% more space, plus a newline every 76
3713 characters, and then we round up. */
3714 length
= SBYTES (string
);
3715 allength
= length
+ length
/3 + 1;
3716 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3718 /* We need to allocate enough room for decoding the text. */
3719 if (allength
<= MAX_ALLOCA
)
3720 encoded
= (char *) alloca (allength
);
3722 encoded
= (char *) xmalloc (allength
);
3724 encoded_length
= base64_encode_1 (SDATA (string
),
3725 encoded
, length
, NILP (no_line_break
),
3726 STRING_MULTIBYTE (string
));
3727 if (encoded_length
> allength
)
3730 if (encoded_length
< 0)
3732 /* The encoding wasn't possible. */
3733 if (length
> MAX_ALLOCA
)
3735 error ("Multibyte character in data for base64 encoding");
3738 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3739 if (allength
> MAX_ALLOCA
)
3742 return encoded_string
;
3746 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3753 int counter
= 0, i
= 0;
3763 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3771 /* Wrap line every 76 characters. */
3775 if (counter
< MIME_LINE_LENGTH
/ 4)
3784 /* Process first byte of a triplet. */
3786 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3787 value
= (0x03 & c
) << 4;
3789 /* Process second byte of a triplet. */
3793 *e
++ = base64_value_to_char
[value
];
3801 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3809 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3810 value
= (0x0f & c
) << 2;
3812 /* Process third byte of a triplet. */
3816 *e
++ = base64_value_to_char
[value
];
3823 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3831 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3832 *e
++ = base64_value_to_char
[0x3f & c
];
3839 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3841 doc
: /* Base64-decode the region between BEG and END.
3842 Return the length of the decoded text.
3843 If the region can't be decoded, signal an error and don't modify the buffer. */)
3845 Lisp_Object beg
, end
;
3847 int ibeg
, iend
, length
, allength
;
3852 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3854 validate_region (&beg
, &end
);
3856 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3857 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3859 length
= iend
- ibeg
;
3861 /* We need to allocate enough room for decoding the text. If we are
3862 working on a multibyte buffer, each decoded code may occupy at
3864 allength
= multibyte
? length
* 2 : length
;
3865 if (allength
<= MAX_ALLOCA
)
3866 decoded
= (char *) alloca (allength
);
3868 decoded
= (char *) xmalloc (allength
);
3870 move_gap_both (XFASTINT (beg
), ibeg
);
3871 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3872 multibyte
, &inserted_chars
);
3873 if (decoded_length
> allength
)
3876 if (decoded_length
< 0)
3878 /* The decoding wasn't possible. */
3879 if (allength
> MAX_ALLOCA
)
3881 error ("Invalid base64 data");
3884 /* Now we have decoded the region, so we insert the new contents
3885 and delete the old. (Insert first in order to preserve markers.) */
3886 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3887 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3888 if (allength
> MAX_ALLOCA
)
3890 /* Delete the original text. */
3891 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3892 iend
+ decoded_length
, 1);
3894 /* If point was outside of the region, restore it exactly; else just
3895 move to the beginning of the region. */
3896 if (old_pos
>= XFASTINT (end
))
3897 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3898 else if (old_pos
> XFASTINT (beg
))
3899 old_pos
= XFASTINT (beg
);
3900 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3902 return make_number (inserted_chars
);
3905 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3907 doc
: /* Base64-decode STRING and return the result. */)
3912 int length
, decoded_length
;
3913 Lisp_Object decoded_string
;
3915 CHECK_STRING (string
);
3917 length
= SBYTES (string
);
3918 /* We need to allocate enough room for decoding the text. */
3919 if (length
<= MAX_ALLOCA
)
3920 decoded
= (char *) alloca (length
);
3922 decoded
= (char *) xmalloc (length
);
3924 /* The decoded result should be unibyte. */
3925 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3927 if (decoded_length
> length
)
3929 else if (decoded_length
>= 0)
3930 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3932 decoded_string
= Qnil
;
3934 if (length
> MAX_ALLOCA
)
3936 if (!STRINGP (decoded_string
))
3937 error ("Invalid base64 data");
3939 return decoded_string
;
3942 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3943 MULTIBYTE is nonzero, the decoded result should be in multibyte
3944 form. If NCHARS_RETRUN is not NULL, store the number of produced
3945 characters in *NCHARS_RETURN. */
3948 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3958 unsigned long value
;
3963 /* Process first byte of a quadruplet. */
3965 READ_QUADRUPLET_BYTE (e
-to
);
3969 value
= base64_char_to_value
[c
] << 18;
3971 /* Process second byte of a quadruplet. */
3973 READ_QUADRUPLET_BYTE (-1);
3977 value
|= base64_char_to_value
[c
] << 12;
3979 c
= (unsigned char) (value
>> 16);
3981 e
+= CHAR_STRING (c
, e
);
3986 /* Process third byte of a quadruplet. */
3988 READ_QUADRUPLET_BYTE (-1);
3992 READ_QUADRUPLET_BYTE (-1);
4001 value
|= base64_char_to_value
[c
] << 6;
4003 c
= (unsigned char) (0xff & value
>> 8);
4005 e
+= CHAR_STRING (c
, e
);
4010 /* Process fourth byte of a quadruplet. */
4012 READ_QUADRUPLET_BYTE (-1);
4019 value
|= base64_char_to_value
[c
];
4021 c
= (unsigned char) (0xff & value
);
4023 e
+= CHAR_STRING (c
, e
);
4032 /***********************************************************************
4034 ***** Hash Tables *****
4036 ***********************************************************************/
4038 /* Implemented by gerd@gnu.org. This hash table implementation was
4039 inspired by CMUCL hash tables. */
4043 1. For small tables, association lists are probably faster than
4044 hash tables because they have lower overhead.
4046 For uses of hash tables where the O(1) behavior of table
4047 operations is not a requirement, it might therefore be a good idea
4048 not to hash. Instead, we could just do a linear search in the
4049 key_and_value vector of the hash table. This could be done
4050 if a `:linear-search t' argument is given to make-hash-table. */
4053 /* The list of all weak hash tables. Don't staticpro this one. */
4055 Lisp_Object Vweak_hash_tables
;
4057 /* Various symbols. */
4059 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4060 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4061 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4063 /* Function prototypes. */
4065 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4066 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4067 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4068 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4069 Lisp_Object
, unsigned));
4070 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4071 Lisp_Object
, unsigned));
4072 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4073 unsigned, Lisp_Object
, unsigned));
4074 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4075 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4076 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4077 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4079 static unsigned sxhash_string
P_ ((unsigned char *, int));
4080 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4081 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4082 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4083 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4087 /***********************************************************************
4089 ***********************************************************************/
4091 /* If OBJ is a Lisp hash table, return a pointer to its struct
4092 Lisp_Hash_Table. Otherwise, signal an error. */
4094 static struct Lisp_Hash_Table
*
4095 check_hash_table (obj
)
4098 CHECK_HASH_TABLE (obj
);
4099 return XHASH_TABLE (obj
);
4103 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4107 next_almost_prime (n
)
4120 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4121 which USED[I] is non-zero. If found at index I in ARGS, set
4122 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4123 -1. This function is used to extract a keyword/argument pair from
4124 a DEFUN parameter list. */
4127 get_key_arg (key
, nargs
, args
, used
)
4135 for (i
= 0; i
< nargs
- 1; ++i
)
4136 if (!used
[i
] && EQ (args
[i
], key
))
4151 /* Return a Lisp vector which has the same contents as VEC but has
4152 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4153 vector that are not copied from VEC are set to INIT. */
4156 larger_vector (vec
, new_size
, init
)
4161 struct Lisp_Vector
*v
;
4164 xassert (VECTORP (vec
));
4165 old_size
= XVECTOR (vec
)->size
;
4166 xassert (new_size
>= old_size
);
4168 v
= allocate_vector (new_size
);
4169 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4170 old_size
* sizeof *v
->contents
);
4171 for (i
= old_size
; i
< new_size
; ++i
)
4172 v
->contents
[i
] = init
;
4173 XSETVECTOR (vec
, v
);
4178 /***********************************************************************
4180 ***********************************************************************/
4182 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4183 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4184 KEY2 are the same. */
4187 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4188 struct Lisp_Hash_Table
*h
;
4189 Lisp_Object key1
, key2
;
4190 unsigned hash1
, hash2
;
4192 return (FLOATP (key1
)
4194 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4198 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4199 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4200 KEY2 are the same. */
4203 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4204 struct Lisp_Hash_Table
*h
;
4205 Lisp_Object key1
, key2
;
4206 unsigned hash1
, hash2
;
4208 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4212 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4213 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4214 if KEY1 and KEY2 are the same. */
4217 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4218 struct Lisp_Hash_Table
*h
;
4219 Lisp_Object key1
, key2
;
4220 unsigned hash1
, hash2
;
4224 Lisp_Object args
[3];
4226 args
[0] = h
->user_cmp_function
;
4229 return !NILP (Ffuncall (3, args
));
4236 /* Value is a hash code for KEY for use in hash table H which uses
4237 `eq' to compare keys. The hash code returned is guaranteed to fit
4238 in a Lisp integer. */
4242 struct Lisp_Hash_Table
*h
;
4245 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4246 xassert ((hash
& ~VALMASK
) == 0);
4251 /* Value is a hash code for KEY for use in hash table H which uses
4252 `eql' to compare keys. The hash code returned is guaranteed to fit
4253 in a Lisp integer. */
4257 struct Lisp_Hash_Table
*h
;
4262 hash
= sxhash (key
, 0);
4264 hash
= XUINT (key
) ^ XGCTYPE (key
);
4265 xassert ((hash
& ~VALMASK
) == 0);
4270 /* Value is a hash code for KEY for use in hash table H which uses
4271 `equal' to compare keys. The hash code returned is guaranteed to fit
4272 in a Lisp integer. */
4275 hashfn_equal (h
, key
)
4276 struct Lisp_Hash_Table
*h
;
4279 unsigned hash
= sxhash (key
, 0);
4280 xassert ((hash
& ~VALMASK
) == 0);
4285 /* Value is a hash code for KEY for use in hash table H which uses as
4286 user-defined function to compare keys. The hash code returned is
4287 guaranteed to fit in a Lisp integer. */
4290 hashfn_user_defined (h
, key
)
4291 struct Lisp_Hash_Table
*h
;
4294 Lisp_Object args
[2], hash
;
4296 args
[0] = h
->user_hash_function
;
4298 hash
= Ffuncall (2, args
);
4299 if (!INTEGERP (hash
))
4301 list2 (build_string ("Invalid hash code returned from \
4302 user-supplied hash function"),
4304 return XUINT (hash
);
4308 /* Create and initialize a new hash table.
4310 TEST specifies the test the hash table will use to compare keys.
4311 It must be either one of the predefined tests `eq', `eql' or
4312 `equal' or a symbol denoting a user-defined test named TEST with
4313 test and hash functions USER_TEST and USER_HASH.
4315 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4317 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4318 new size when it becomes full is computed by adding REHASH_SIZE to
4319 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4320 table's new size is computed by multiplying its old size with
4323 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4324 be resized when the ratio of (number of entries in the table) /
4325 (table size) is >= REHASH_THRESHOLD.
4327 WEAK specifies the weakness of the table. If non-nil, it must be
4328 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4331 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4332 user_test
, user_hash
)
4333 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4334 Lisp_Object user_test
, user_hash
;
4336 struct Lisp_Hash_Table
*h
;
4338 int index_size
, i
, sz
;
4340 /* Preconditions. */
4341 xassert (SYMBOLP (test
));
4342 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4343 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4344 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4345 xassert (FLOATP (rehash_threshold
)
4346 && XFLOATINT (rehash_threshold
) > 0
4347 && XFLOATINT (rehash_threshold
) <= 1.0);
4349 if (XFASTINT (size
) == 0)
4350 size
= make_number (1);
4352 /* Allocate a table and initialize it. */
4353 h
= allocate_hash_table ();
4355 /* Initialize hash table slots. */
4356 sz
= XFASTINT (size
);
4359 if (EQ (test
, Qeql
))
4361 h
->cmpfn
= cmpfn_eql
;
4362 h
->hashfn
= hashfn_eql
;
4364 else if (EQ (test
, Qeq
))
4367 h
->hashfn
= hashfn_eq
;
4369 else if (EQ (test
, Qequal
))
4371 h
->cmpfn
= cmpfn_equal
;
4372 h
->hashfn
= hashfn_equal
;
4376 h
->user_cmp_function
= user_test
;
4377 h
->user_hash_function
= user_hash
;
4378 h
->cmpfn
= cmpfn_user_defined
;
4379 h
->hashfn
= hashfn_user_defined
;
4383 h
->rehash_threshold
= rehash_threshold
;
4384 h
->rehash_size
= rehash_size
;
4385 h
->count
= make_number (0);
4386 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4387 h
->hash
= Fmake_vector (size
, Qnil
);
4388 h
->next
= Fmake_vector (size
, Qnil
);
4389 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4390 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4391 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4393 /* Set up the free list. */
4394 for (i
= 0; i
< sz
- 1; ++i
)
4395 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4396 h
->next_free
= make_number (0);
4398 XSET_HASH_TABLE (table
, h
);
4399 xassert (HASH_TABLE_P (table
));
4400 xassert (XHASH_TABLE (table
) == h
);
4402 /* Maybe add this hash table to the list of all weak hash tables. */
4404 h
->next_weak
= Qnil
;
4407 h
->next_weak
= Vweak_hash_tables
;
4408 Vweak_hash_tables
= table
;
4415 /* Return a copy of hash table H1. Keys and values are not copied,
4416 only the table itself is. */
4419 copy_hash_table (h1
)
4420 struct Lisp_Hash_Table
*h1
;
4423 struct Lisp_Hash_Table
*h2
;
4424 struct Lisp_Vector
*next
;
4426 h2
= allocate_hash_table ();
4427 next
= h2
->vec_next
;
4428 bcopy (h1
, h2
, sizeof *h2
);
4429 h2
->vec_next
= next
;
4430 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4431 h2
->hash
= Fcopy_sequence (h1
->hash
);
4432 h2
->next
= Fcopy_sequence (h1
->next
);
4433 h2
->index
= Fcopy_sequence (h1
->index
);
4434 XSET_HASH_TABLE (table
, h2
);
4436 /* Maybe add this hash table to the list of all weak hash tables. */
4437 if (!NILP (h2
->weak
))
4439 h2
->next_weak
= Vweak_hash_tables
;
4440 Vweak_hash_tables
= table
;
4447 /* Resize hash table H if it's too full. If H cannot be resized
4448 because it's already too large, throw an error. */
4451 maybe_resize_hash_table (h
)
4452 struct Lisp_Hash_Table
*h
;
4454 if (NILP (h
->next_free
))
4456 int old_size
= HASH_TABLE_SIZE (h
);
4457 int i
, new_size
, index_size
;
4459 if (INTEGERP (h
->rehash_size
))
4460 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4462 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4463 new_size
= max (old_size
+ 1, new_size
);
4464 index_size
= next_almost_prime ((int)
4466 / XFLOATINT (h
->rehash_threshold
)));
4467 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4468 error ("Hash table too large to resize");
4470 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4471 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4472 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4473 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4475 /* Update the free list. Do it so that new entries are added at
4476 the end of the free list. This makes some operations like
4478 for (i
= old_size
; i
< new_size
- 1; ++i
)
4479 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4481 if (!NILP (h
->next_free
))
4483 Lisp_Object last
, next
;
4485 last
= h
->next_free
;
4486 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4490 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4493 XSETFASTINT (h
->next_free
, old_size
);
4496 for (i
= 0; i
< old_size
; ++i
)
4497 if (!NILP (HASH_HASH (h
, i
)))
4499 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4500 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4501 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4502 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4508 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4509 the hash code of KEY. Value is the index of the entry in H
4510 matching KEY, or -1 if not found. */
4513 hash_lookup (h
, key
, hash
)
4514 struct Lisp_Hash_Table
*h
;
4519 int start_of_bucket
;
4522 hash_code
= h
->hashfn (h
, key
);
4526 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4527 idx
= HASH_INDEX (h
, start_of_bucket
);
4529 /* We need not gcpro idx since it's either an integer or nil. */
4532 int i
= XFASTINT (idx
);
4533 if (EQ (key
, HASH_KEY (h
, i
))
4535 && h
->cmpfn (h
, key
, hash_code
,
4536 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4538 idx
= HASH_NEXT (h
, i
);
4541 return NILP (idx
) ? -1 : XFASTINT (idx
);
4545 /* Put an entry into hash table H that associates KEY with VALUE.
4546 HASH is a previously computed hash code of KEY.
4547 Value is the index of the entry in H matching KEY. */
4550 hash_put (h
, key
, value
, hash
)
4551 struct Lisp_Hash_Table
*h
;
4552 Lisp_Object key
, value
;
4555 int start_of_bucket
, i
;
4557 xassert ((hash
& ~VALMASK
) == 0);
4559 /* Increment count after resizing because resizing may fail. */
4560 maybe_resize_hash_table (h
);
4561 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4563 /* Store key/value in the key_and_value vector. */
4564 i
= XFASTINT (h
->next_free
);
4565 h
->next_free
= HASH_NEXT (h
, i
);
4566 HASH_KEY (h
, i
) = key
;
4567 HASH_VALUE (h
, i
) = value
;
4569 /* Remember its hash code. */
4570 HASH_HASH (h
, i
) = make_number (hash
);
4572 /* Add new entry to its collision chain. */
4573 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4574 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4575 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4580 /* Remove the entry matching KEY from hash table H, if there is one. */
4583 hash_remove (h
, key
)
4584 struct Lisp_Hash_Table
*h
;
4588 int start_of_bucket
;
4589 Lisp_Object idx
, prev
;
4591 hash_code
= h
->hashfn (h
, key
);
4592 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4593 idx
= HASH_INDEX (h
, start_of_bucket
);
4596 /* We need not gcpro idx, prev since they're either integers or nil. */
4599 int i
= XFASTINT (idx
);
4601 if (EQ (key
, HASH_KEY (h
, i
))
4603 && h
->cmpfn (h
, key
, hash_code
,
4604 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4606 /* Take entry out of collision chain. */
4608 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4610 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4612 /* Clear slots in key_and_value and add the slots to
4614 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4615 HASH_NEXT (h
, i
) = h
->next_free
;
4616 h
->next_free
= make_number (i
);
4617 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4618 xassert (XINT (h
->count
) >= 0);
4624 idx
= HASH_NEXT (h
, i
);
4630 /* Clear hash table H. */
4634 struct Lisp_Hash_Table
*h
;
4636 if (XFASTINT (h
->count
) > 0)
4638 int i
, size
= HASH_TABLE_SIZE (h
);
4640 for (i
= 0; i
< size
; ++i
)
4642 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4643 HASH_KEY (h
, i
) = Qnil
;
4644 HASH_VALUE (h
, i
) = Qnil
;
4645 HASH_HASH (h
, i
) = Qnil
;
4648 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4649 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4651 h
->next_free
= make_number (0);
4652 h
->count
= make_number (0);
4658 /************************************************************************
4660 ************************************************************************/
4662 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4663 entries from the table that don't survive the current GC.
4664 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4665 non-zero if anything was marked. */
4668 sweep_weak_table (h
, remove_entries_p
)
4669 struct Lisp_Hash_Table
*h
;
4670 int remove_entries_p
;
4672 int bucket
, n
, marked
;
4674 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4677 for (bucket
= 0; bucket
< n
; ++bucket
)
4679 Lisp_Object idx
, next
, prev
;
4681 /* Follow collision chain, removing entries that
4682 don't survive this garbage collection. */
4684 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4686 int i
= XFASTINT (idx
);
4687 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4688 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4691 if (EQ (h
->weak
, Qkey
))
4692 remove_p
= !key_known_to_survive_p
;
4693 else if (EQ (h
->weak
, Qvalue
))
4694 remove_p
= !value_known_to_survive_p
;
4695 else if (EQ (h
->weak
, Qkey_or_value
))
4696 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4697 else if (EQ (h
->weak
, Qkey_and_value
))
4698 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4702 next
= HASH_NEXT (h
, i
);
4704 if (remove_entries_p
)
4708 /* Take out of collision chain. */
4710 HASH_INDEX (h
, bucket
) = next
;
4712 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4714 /* Add to free list. */
4715 HASH_NEXT (h
, i
) = h
->next_free
;
4718 /* Clear key, value, and hash. */
4719 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4720 HASH_HASH (h
, i
) = Qnil
;
4722 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4729 /* Make sure key and value survive. */
4730 if (!key_known_to_survive_p
)
4732 mark_object (&HASH_KEY (h
, i
));
4736 if (!value_known_to_survive_p
)
4738 mark_object (&HASH_VALUE (h
, i
));
4749 /* Remove elements from weak hash tables that don't survive the
4750 current garbage collection. Remove weak tables that don't survive
4751 from Vweak_hash_tables. Called from gc_sweep. */
4754 sweep_weak_hash_tables ()
4756 Lisp_Object table
, used
, next
;
4757 struct Lisp_Hash_Table
*h
;
4760 /* Mark all keys and values that are in use. Keep on marking until
4761 there is no more change. This is necessary for cases like
4762 value-weak table A containing an entry X -> Y, where Y is used in a
4763 key-weak table B, Z -> Y. If B comes after A in the list of weak
4764 tables, X -> Y might be removed from A, although when looking at B
4765 one finds that it shouldn't. */
4769 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4771 h
= XHASH_TABLE (table
);
4772 if (h
->size
& ARRAY_MARK_FLAG
)
4773 marked
|= sweep_weak_table (h
, 0);
4778 /* Remove tables and entries that aren't used. */
4779 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4781 h
= XHASH_TABLE (table
);
4782 next
= h
->next_weak
;
4784 if (h
->size
& ARRAY_MARK_FLAG
)
4786 /* TABLE is marked as used. Sweep its contents. */
4787 if (XFASTINT (h
->count
) > 0)
4788 sweep_weak_table (h
, 1);
4790 /* Add table to the list of used weak hash tables. */
4791 h
->next_weak
= used
;
4796 Vweak_hash_tables
= used
;
4801 /***********************************************************************
4802 Hash Code Computation
4803 ***********************************************************************/
4805 /* Maximum depth up to which to dive into Lisp structures. */
4807 #define SXHASH_MAX_DEPTH 3
4809 /* Maximum length up to which to take list and vector elements into
4812 #define SXHASH_MAX_LEN 7
4814 /* Combine two integers X and Y for hashing. */
4816 #define SXHASH_COMBINE(X, Y) \
4817 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4821 /* Return a hash for string PTR which has length LEN. The hash
4822 code returned is guaranteed to fit in a Lisp integer. */
4825 sxhash_string (ptr
, len
)
4829 unsigned char *p
= ptr
;
4830 unsigned char *end
= p
+ len
;
4839 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4842 return hash
& VALMASK
;
4846 /* Return a hash for list LIST. DEPTH is the current depth in the
4847 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4850 sxhash_list (list
, depth
)
4857 if (depth
< SXHASH_MAX_DEPTH
)
4859 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4860 list
= XCDR (list
), ++i
)
4862 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4863 hash
= SXHASH_COMBINE (hash
, hash2
);
4870 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4871 the Lisp structure. */
4874 sxhash_vector (vec
, depth
)
4878 unsigned hash
= XVECTOR (vec
)->size
;
4881 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4882 for (i
= 0; i
< n
; ++i
)
4884 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4885 hash
= SXHASH_COMBINE (hash
, hash2
);
4892 /* Return a hash for bool-vector VECTOR. */
4895 sxhash_bool_vector (vec
)
4898 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4901 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4902 for (i
= 0; i
< n
; ++i
)
4903 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4909 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4910 structure. Value is an unsigned integer clipped to VALMASK. */
4919 if (depth
> SXHASH_MAX_DEPTH
)
4922 switch (XTYPE (obj
))
4929 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4930 SCHARS (SYMBOL_NAME (obj
)));
4938 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4941 /* This can be everything from a vector to an overlay. */
4942 case Lisp_Vectorlike
:
4944 /* According to the CL HyperSpec, two arrays are equal only if
4945 they are `eq', except for strings and bit-vectors. In
4946 Emacs, this works differently. We have to compare element
4948 hash
= sxhash_vector (obj
, depth
);
4949 else if (BOOL_VECTOR_P (obj
))
4950 hash
= sxhash_bool_vector (obj
);
4952 /* Others are `equal' if they are `eq', so let's take their
4958 hash
= sxhash_list (obj
, depth
);
4963 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4964 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4965 for (hash
= 0; p
< e
; ++p
)
4966 hash
= SXHASH_COMBINE (hash
, *p
);
4974 return hash
& VALMASK
;
4979 /***********************************************************************
4981 ***********************************************************************/
4984 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4985 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4989 unsigned hash
= sxhash (obj
, 0);;
4990 return make_number (hash
);
4994 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4995 doc
: /* Create and return a new hash table.
4997 Arguments are specified as keyword/argument pairs. The following
4998 arguments are defined:
5000 :test TEST -- TEST must be a symbol that specifies how to compare
5001 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5002 `equal'. User-supplied test and hash functions can be specified via
5003 `define-hash-table-test'.
5005 :size SIZE -- A hint as to how many elements will be put in the table.
5008 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5009 fills up. If REHASH-SIZE is an integer, add that many space. If it
5010 is a float, it must be > 1.0, and the new size is computed by
5011 multiplying the old size with that factor. Default is 1.5.
5013 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5014 Resize the hash table when ratio of the number of entries in the
5015 table. Default is 0.8.
5017 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5018 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5019 returned is a weak table. Key/value pairs are removed from a weak
5020 hash table when there are no non-weak references pointing to their
5021 key, value, one of key or value, or both key and value, depending on
5022 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5025 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5030 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5031 Lisp_Object user_test
, user_hash
;
5035 /* The vector `used' is used to keep track of arguments that
5036 have been consumed. */
5037 used
= (char *) alloca (nargs
* sizeof *used
);
5038 bzero (used
, nargs
* sizeof *used
);
5040 /* See if there's a `:test TEST' among the arguments. */
5041 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5042 test
= i
< 0 ? Qeql
: args
[i
];
5043 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5045 /* See if it is a user-defined test. */
5048 prop
= Fget (test
, Qhash_table_test
);
5049 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5050 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5052 user_test
= XCAR (prop
);
5053 user_hash
= XCAR (XCDR (prop
));
5056 user_test
= user_hash
= Qnil
;
5058 /* See if there's a `:size SIZE' argument. */
5059 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5060 size
= i
< 0 ? Qnil
: args
[i
];
5062 size
= make_number (DEFAULT_HASH_SIZE
);
5063 else if (!INTEGERP (size
) || XINT (size
) < 0)
5065 list2 (build_string ("Invalid hash table size"),
5068 /* Look for `:rehash-size SIZE'. */
5069 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5070 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5071 if (!NUMBERP (rehash_size
)
5072 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5073 || XFLOATINT (rehash_size
) <= 1.0)
5075 list2 (build_string ("Invalid hash table rehash size"),
5078 /* Look for `:rehash-threshold THRESHOLD'. */
5079 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5080 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5081 if (!FLOATP (rehash_threshold
)
5082 || XFLOATINT (rehash_threshold
) <= 0.0
5083 || XFLOATINT (rehash_threshold
) > 1.0)
5085 list2 (build_string ("Invalid hash table rehash threshold"),
5088 /* Look for `:weakness WEAK'. */
5089 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5090 weak
= i
< 0 ? Qnil
: args
[i
];
5092 weak
= Qkey_and_value
;
5095 && !EQ (weak
, Qvalue
)
5096 && !EQ (weak
, Qkey_or_value
)
5097 && !EQ (weak
, Qkey_and_value
))
5098 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5101 /* Now, all args should have been used up, or there's a problem. */
5102 for (i
= 0; i
< nargs
; ++i
)
5105 list2 (build_string ("Invalid argument list"), args
[i
]));
5107 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5108 user_test
, user_hash
);
5112 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5113 doc
: /* Return a copy of hash table TABLE. */)
5117 return copy_hash_table (check_hash_table (table
));
5121 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5122 doc
: /* Return the number of elements in TABLE. */)
5126 return check_hash_table (table
)->count
;
5130 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5131 Shash_table_rehash_size
, 1, 1, 0,
5132 doc
: /* Return the current rehash size of TABLE. */)
5136 return check_hash_table (table
)->rehash_size
;
5140 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5141 Shash_table_rehash_threshold
, 1, 1, 0,
5142 doc
: /* Return the current rehash threshold of TABLE. */)
5146 return check_hash_table (table
)->rehash_threshold
;
5150 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5151 doc
: /* Return the size of TABLE.
5152 The size can be used as an argument to `make-hash-table' to create
5153 a hash table than can hold as many elements of TABLE holds
5154 without need for resizing. */)
5158 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5159 return make_number (HASH_TABLE_SIZE (h
));
5163 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5164 doc
: /* Return the test TABLE uses. */)
5168 return check_hash_table (table
)->test
;
5172 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5174 doc
: /* Return the weakness of TABLE. */)
5178 return check_hash_table (table
)->weak
;
5182 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5183 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5187 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5191 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5192 doc
: /* Clear hash table TABLE. */)
5196 hash_clear (check_hash_table (table
));
5201 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5202 doc
: /* Look up KEY in TABLE and return its associated value.
5203 If KEY is not found, return DFLT which defaults to nil. */)
5205 Lisp_Object key
, table
, dflt
;
5207 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5208 int i
= hash_lookup (h
, key
, NULL
);
5209 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5213 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5214 doc
: /* Associate KEY with VALUE in hash table TABLE.
5215 If KEY is already present in table, replace its current value with
5218 Lisp_Object key
, value
, table
;
5220 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5224 i
= hash_lookup (h
, key
, &hash
);
5226 HASH_VALUE (h
, i
) = value
;
5228 hash_put (h
, key
, value
, hash
);
5234 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5235 doc
: /* Remove KEY from TABLE. */)
5237 Lisp_Object key
, table
;
5239 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5240 hash_remove (h
, key
);
5245 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5246 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5247 FUNCTION is called with 2 arguments KEY and VALUE. */)
5249 Lisp_Object function
, table
;
5251 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5252 Lisp_Object args
[3];
5255 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5256 if (!NILP (HASH_HASH (h
, i
)))
5259 args
[1] = HASH_KEY (h
, i
);
5260 args
[2] = HASH_VALUE (h
, i
);
5268 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5269 Sdefine_hash_table_test
, 3, 3, 0,
5270 doc
: /* Define a new hash table test with name NAME, a symbol.
5272 In hash tables created with NAME specified as test, use TEST to
5273 compare keys, and HASH for computing hash codes of keys.
5275 TEST must be a function taking two arguments and returning non-nil if
5276 both arguments are the same. HASH must be a function taking one
5277 argument and return an integer that is the hash code of the argument.
5278 Hash code computation should use the whole value range of integers,
5279 including negative integers. */)
5281 Lisp_Object name
, test
, hash
;
5283 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5288 /************************************************************************
5290 ************************************************************************/
5295 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5296 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5298 A message digest is a cryptographic checksum of a document, and the
5299 algorithm to calculate it is defined in RFC 1321.
5301 The two optional arguments START and END are character positions
5302 specifying for which part of OBJECT the message digest should be
5303 computed. If nil or omitted, the digest is computed for the whole
5306 The MD5 message digest is computed from the result of encoding the
5307 text in a coding system, not directly from the internal Emacs form of
5308 the text. The optional fourth argument CODING-SYSTEM specifies which
5309 coding system to encode the text with. It should be the same coding
5310 system that you used or will use when actually writing the text into a
5313 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5314 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5315 system would be chosen by default for writing this text into a file.
5317 If OBJECT is a string, the most preferred coding system (see the
5318 command `prefer-coding-system') is used.
5320 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5321 guesswork fails. Normally, an error is signaled in such case. */)
5322 (object
, start
, end
, coding_system
, noerror
)
5323 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5325 unsigned char digest
[16];
5326 unsigned char value
[33];
5330 int start_char
= 0, end_char
= 0;
5331 int start_byte
= 0, end_byte
= 0;
5333 register struct buffer
*bp
;
5336 if (STRINGP (object
))
5338 if (NILP (coding_system
))
5340 /* Decide the coding-system to encode the data with. */
5342 if (STRING_MULTIBYTE (object
))
5343 /* use default, we can't guess correct value */
5344 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5346 coding_system
= Qraw_text
;
5349 if (NILP (Fcoding_system_p (coding_system
)))
5351 /* Invalid coding system. */
5353 if (!NILP (noerror
))
5354 coding_system
= Qraw_text
;
5357 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5360 if (STRING_MULTIBYTE (object
))
5361 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5363 size
= SCHARS (object
);
5364 size_byte
= SBYTES (object
);
5368 CHECK_NUMBER (start
);
5370 start_char
= XINT (start
);
5375 start_byte
= string_char_to_byte (object
, start_char
);
5381 end_byte
= size_byte
;
5387 end_char
= XINT (end
);
5392 end_byte
= string_char_to_byte (object
, end_char
);
5395 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5396 args_out_of_range_3 (object
, make_number (start_char
),
5397 make_number (end_char
));
5401 CHECK_BUFFER (object
);
5403 bp
= XBUFFER (object
);
5409 CHECK_NUMBER_COERCE_MARKER (start
);
5417 CHECK_NUMBER_COERCE_MARKER (end
);
5422 temp
= b
, b
= e
, e
= temp
;
5424 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5425 args_out_of_range (start
, end
);
5427 if (NILP (coding_system
))
5429 /* Decide the coding-system to encode the data with.
5430 See fileio.c:Fwrite-region */
5432 if (!NILP (Vcoding_system_for_write
))
5433 coding_system
= Vcoding_system_for_write
;
5436 int force_raw_text
= 0;
5438 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5439 if (NILP (coding_system
)
5440 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5442 coding_system
= Qnil
;
5443 if (NILP (current_buffer
->enable_multibyte_characters
))
5447 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5449 /* Check file-coding-system-alist. */
5450 Lisp_Object args
[4], val
;
5452 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5453 args
[3] = Fbuffer_file_name(object
);
5454 val
= Ffind_operation_coding_system (4, args
);
5455 if (CONSP (val
) && !NILP (XCDR (val
)))
5456 coding_system
= XCDR (val
);
5459 if (NILP (coding_system
)
5460 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5462 /* If we still have not decided a coding system, use the
5463 default value of buffer-file-coding-system. */
5464 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5468 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5469 /* Confirm that VAL can surely encode the current region. */
5470 coding_system
= call4 (Vselect_safe_coding_system_function
,
5471 make_number (b
), make_number (e
),
5472 coding_system
, Qnil
);
5475 coding_system
= Qraw_text
;
5478 if (NILP (Fcoding_system_p (coding_system
)))
5480 /* Invalid coding system. */
5482 if (!NILP (noerror
))
5483 coding_system
= Qraw_text
;
5486 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5490 object
= make_buffer_string (b
, e
, 0);
5492 if (STRING_MULTIBYTE (object
))
5493 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5496 md5_buffer (SDATA (object
) + start_byte
,
5497 SBYTES (object
) - (size_byte
- end_byte
),
5500 for (i
= 0; i
< 16; i
++)
5501 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5504 return make_string (value
, 32);
5511 /* Hash table stuff. */
5512 Qhash_table_p
= intern ("hash-table-p");
5513 staticpro (&Qhash_table_p
);
5514 Qeq
= intern ("eq");
5516 Qeql
= intern ("eql");
5518 Qequal
= intern ("equal");
5519 staticpro (&Qequal
);
5520 QCtest
= intern (":test");
5521 staticpro (&QCtest
);
5522 QCsize
= intern (":size");
5523 staticpro (&QCsize
);
5524 QCrehash_size
= intern (":rehash-size");
5525 staticpro (&QCrehash_size
);
5526 QCrehash_threshold
= intern (":rehash-threshold");
5527 staticpro (&QCrehash_threshold
);
5528 QCweakness
= intern (":weakness");
5529 staticpro (&QCweakness
);
5530 Qkey
= intern ("key");
5532 Qvalue
= intern ("value");
5533 staticpro (&Qvalue
);
5534 Qhash_table_test
= intern ("hash-table-test");
5535 staticpro (&Qhash_table_test
);
5536 Qkey_or_value
= intern ("key-or-value");
5537 staticpro (&Qkey_or_value
);
5538 Qkey_and_value
= intern ("key-and-value");
5539 staticpro (&Qkey_and_value
);
5542 defsubr (&Smake_hash_table
);
5543 defsubr (&Scopy_hash_table
);
5544 defsubr (&Shash_table_count
);
5545 defsubr (&Shash_table_rehash_size
);
5546 defsubr (&Shash_table_rehash_threshold
);
5547 defsubr (&Shash_table_size
);
5548 defsubr (&Shash_table_test
);
5549 defsubr (&Shash_table_weakness
);
5550 defsubr (&Shash_table_p
);
5551 defsubr (&Sclrhash
);
5552 defsubr (&Sgethash
);
5553 defsubr (&Sputhash
);
5554 defsubr (&Sremhash
);
5555 defsubr (&Smaphash
);
5556 defsubr (&Sdefine_hash_table_test
);
5558 Qstring_lessp
= intern ("string-lessp");
5559 staticpro (&Qstring_lessp
);
5560 Qprovide
= intern ("provide");
5561 staticpro (&Qprovide
);
5562 Qrequire
= intern ("require");
5563 staticpro (&Qrequire
);
5564 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5565 staticpro (&Qyes_or_no_p_history
);
5566 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5567 staticpro (&Qcursor_in_echo_area
);
5568 Qwidget_type
= intern ("widget-type");
5569 staticpro (&Qwidget_type
);
5571 staticpro (&string_char_byte_cache_string
);
5572 string_char_byte_cache_string
= Qnil
;
5574 require_nesting_list
= Qnil
;
5575 staticpro (&require_nesting_list
);
5577 Fset (Qyes_or_no_p_history
, Qnil
);
5579 DEFVAR_LISP ("features", &Vfeatures
,
5580 doc
: /* A list of symbols which are the features of the executing emacs.
5581 Used by `featurep' and `require', and altered by `provide'. */);
5583 Qsubfeatures
= intern ("subfeatures");
5584 staticpro (&Qsubfeatures
);
5586 #ifdef HAVE_LANGINFO_CODESET
5587 Qcodeset
= intern ("codeset");
5588 staticpro (&Qcodeset
);
5589 Qdays
= intern ("days");
5591 Qmonths
= intern ("months");
5592 staticpro (&Qmonths
);
5593 Qpaper
= intern ("paper");
5594 staticpro (&Qpaper
);
5595 #endif /* HAVE_LANGINFO_CODESET */
5597 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5598 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5599 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5600 invoked by mouse clicks and mouse menu items. */);
5603 defsubr (&Sidentity
);
5606 defsubr (&Ssafe_length
);
5607 defsubr (&Sstring_bytes
);
5608 defsubr (&Sstring_equal
);
5609 defsubr (&Scompare_strings
);
5610 defsubr (&Sstring_lessp
);
5613 defsubr (&Svconcat
);
5614 defsubr (&Scopy_sequence
);
5615 defsubr (&Sstring_make_multibyte
);
5616 defsubr (&Sstring_make_unibyte
);
5617 defsubr (&Sstring_as_multibyte
);
5618 defsubr (&Sstring_as_unibyte
);
5619 defsubr (&Sstring_to_multibyte
);
5620 defsubr (&Scopy_alist
);
5621 defsubr (&Ssubstring
);
5622 defsubr (&Ssubstring_no_properties
);
5634 defsubr (&Snreverse
);
5635 defsubr (&Sreverse
);
5637 defsubr (&Splist_get
);
5639 defsubr (&Splist_put
);
5641 defsubr (&Slax_plist_get
);
5642 defsubr (&Slax_plist_put
);
5644 defsubr (&Sfillarray
);
5645 defsubr (&Schar_table_subtype
);
5646 defsubr (&Schar_table_parent
);
5647 defsubr (&Sset_char_table_parent
);
5648 defsubr (&Schar_table_extra_slot
);
5649 defsubr (&Sset_char_table_extra_slot
);
5650 defsubr (&Schar_table_range
);
5651 defsubr (&Sset_char_table_range
);
5652 defsubr (&Sset_char_table_default
);
5653 defsubr (&Soptimize_char_table
);
5654 defsubr (&Smap_char_table
);
5658 defsubr (&Smapconcat
);
5659 defsubr (&Sy_or_n_p
);
5660 defsubr (&Syes_or_no_p
);
5661 defsubr (&Sload_average
);
5662 defsubr (&Sfeaturep
);
5663 defsubr (&Srequire
);
5664 defsubr (&Sprovide
);
5665 defsubr (&Splist_member
);
5666 defsubr (&Swidget_put
);
5667 defsubr (&Swidget_get
);
5668 defsubr (&Swidget_apply
);
5669 defsubr (&Sbase64_encode_region
);
5670 defsubr (&Sbase64_decode_region
);
5671 defsubr (&Sbase64_encode_string
);
5672 defsubr (&Sbase64_decode_string
);
5674 defsubr (&Slanginfo
);
5681 Vweak_hash_tables
= Qnil
;