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. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
40 #include "intervals.h"
43 #include "blockinput.h"
44 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
49 #define NULL ((POINTER_TYPE *)0)
52 /* Nonzero enables use of dialog boxes for questions
53 asked by mouse commands. */
56 extern int minibuffer_auto_raise
;
57 extern Lisp_Object minibuf_window
;
58 extern Lisp_Object Vlocale_coding_system
;
60 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
61 Lisp_Object Qyes_or_no_p_history
;
62 Lisp_Object Qcursor_in_echo_area
;
63 Lisp_Object Qwidget_type
;
64 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
66 extern Lisp_Object Qinput_method_function
;
68 static int internal_equal ();
70 extern long get_random ();
71 extern void seed_random ();
77 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
78 doc
: /* Return the argument unchanged. */)
85 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
86 doc
: /* Return a pseudo-random number.
87 All integers representable in Lisp are equally likely.
88 On most systems, this is 28 bits' worth.
89 With positive integer argument N, return random number in interval [0,N).
90 With argument t, set the random number seed from the current time and pid. */)
95 Lisp_Object lispy_val
;
96 unsigned long denominator
;
99 seed_random (getpid () + time (NULL
));
100 if (NATNUMP (n
) && XFASTINT (n
) != 0)
102 /* Try to take our random number from the higher bits of VAL,
103 not the lower, since (says Gentzel) the low bits of `random'
104 are less random than the higher ones. We do this by using the
105 quotient rather than the remainder. At the high end of the RNG
106 it's possible to get a quotient larger than n; discarding
107 these values eliminates the bias that would otherwise appear
108 when using a large n. */
109 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
111 val
= get_random () / denominator
;
112 while (val
>= XFASTINT (n
));
116 XSETINT (lispy_val
, val
);
120 /* Random data-structure functions */
122 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
123 doc
: /* Return the length of vector, list or string SEQUENCE.
124 A byte-code function object is also allowed.
125 If the string contains multibyte characters, this is not necessarily
126 the number of bytes in the string; it is the number of characters.
127 To get the number of bytes, use `string-bytes'. */)
129 register Lisp_Object sequence
;
131 register Lisp_Object val
;
135 if (STRINGP (sequence
))
136 XSETFASTINT (val
, SCHARS (sequence
));
137 else if (VECTORP (sequence
))
138 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
139 else if (CHAR_TABLE_P (sequence
))
140 XSETFASTINT (val
, MAX_CHAR
);
141 else if (BOOL_VECTOR_P (sequence
))
142 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
143 else if (COMPILEDP (sequence
))
144 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
145 else if (CONSP (sequence
))
148 while (CONSP (sequence
))
150 sequence
= XCDR (sequence
);
153 if (!CONSP (sequence
))
156 sequence
= XCDR (sequence
);
161 if (!NILP (sequence
))
162 wrong_type_argument (Qlistp
, sequence
);
164 val
= make_number (i
);
166 else if (NILP (sequence
))
167 XSETFASTINT (val
, 0);
170 sequence
= wrong_type_argument (Qsequencep
, sequence
);
176 /* This does not check for quits. That is safe
177 since it must terminate. */
179 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
180 doc
: /* Return the length of a list, but avoid error or infinite loop.
181 This function never gets an error. If LIST is not really a list,
182 it returns 0. If LIST is circular, it returns a finite value
183 which is at least the number of distinct elements. */)
187 Lisp_Object tail
, halftail
, length
;
190 /* halftail is used to detect circular lists. */
192 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
194 if (EQ (tail
, halftail
) && len
!= 0)
198 halftail
= XCDR (halftail
);
201 XSETINT (length
, len
);
205 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
206 doc
: /* Return the number of bytes in STRING.
207 If STRING is a multibyte string, this is greater than the length of STRING. */)
211 CHECK_STRING (string
);
212 return make_number (SBYTES (string
));
215 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
216 doc
: /* Return t if two strings have identical contents.
217 Case is significant, but text properties are ignored.
218 Symbols are also allowed; their print names are used instead. */)
220 register Lisp_Object s1
, s2
;
223 s1
= SYMBOL_NAME (s1
);
225 s2
= SYMBOL_NAME (s2
);
229 if (SCHARS (s1
) != SCHARS (s2
)
230 || SBYTES (s1
) != SBYTES (s2
)
231 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
236 DEFUN ("compare-strings", Fcompare_strings
,
237 Scompare_strings
, 6, 7, 0,
238 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
239 In string STR1, skip the first START1 characters and stop at END1.
240 In string STR2, skip the first START2 characters and stop at END2.
241 END1 and END2 default to the full lengths of the respective strings.
243 Case is significant in this comparison if IGNORE-CASE is nil.
244 Unibyte strings are converted to multibyte for comparison.
246 The value is t if the strings (or specified portions) match.
247 If string STR1 is less, the value is a negative number N;
248 - 1 - N is the number of characters that match at the beginning.
249 If string STR1 is greater, the value is a positive number N;
250 N - 1 is the number of characters that match at the beginning. */)
251 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
252 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
254 register int end1_char
, end2_char
;
255 register int i1
, i1_byte
, i2
, i2_byte
;
260 start1
= make_number (0);
262 start2
= make_number (0);
263 CHECK_NATNUM (start1
);
264 CHECK_NATNUM (start2
);
273 i1_byte
= string_char_to_byte (str1
, i1
);
274 i2_byte
= string_char_to_byte (str2
, i2
);
276 end1_char
= SCHARS (str1
);
277 if (! NILP (end1
) && end1_char
> XINT (end1
))
278 end1_char
= XINT (end1
);
280 end2_char
= SCHARS (str2
);
281 if (! NILP (end2
) && end2_char
> XINT (end2
))
282 end2_char
= XINT (end2
);
284 while (i1
< end1_char
&& i2
< end2_char
)
286 /* When we find a mismatch, we must compare the
287 characters, not just the bytes. */
290 if (STRING_MULTIBYTE (str1
))
291 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
294 c1
= SREF (str1
, i1
++);
295 c1
= unibyte_char_to_multibyte (c1
);
298 if (STRING_MULTIBYTE (str2
))
299 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
302 c2
= SREF (str2
, i2
++);
303 c2
= unibyte_char_to_multibyte (c2
);
309 if (! NILP (ignore_case
))
313 tem
= Fupcase (make_number (c1
));
315 tem
= Fupcase (make_number (c2
));
322 /* Note that I1 has already been incremented
323 past the character that we are comparing;
324 hence we don't add or subtract 1 here. */
326 return make_number (- i1
+ XINT (start1
));
328 return make_number (i1
- XINT (start1
));
332 return make_number (i1
- XINT (start1
) + 1);
334 return make_number (- i1
+ XINT (start1
) - 1);
339 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
340 doc
: /* Return t if first arg string is less than second in lexicographic order.
342 Symbols are also allowed; their print names are used instead. */)
344 register Lisp_Object s1
, s2
;
347 register int i1
, i1_byte
, i2
, i2_byte
;
350 s1
= SYMBOL_NAME (s1
);
352 s2
= SYMBOL_NAME (s2
);
356 i1
= i1_byte
= i2
= i2_byte
= 0;
359 if (end
> SCHARS (s2
))
364 /* When we find a mismatch, we must compare the
365 characters, not just the bytes. */
368 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
369 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
372 return c1
< c2
? Qt
: Qnil
;
374 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
377 static Lisp_Object
concat ();
388 return concat (2, args
, Lisp_String
, 0);
390 return concat (2, &s1
, Lisp_String
, 0);
391 #endif /* NO_ARG_ARRAY */
397 Lisp_Object s1
, s2
, s3
;
404 return concat (3, args
, Lisp_String
, 0);
406 return concat (3, &s1
, Lisp_String
, 0);
407 #endif /* NO_ARG_ARRAY */
410 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
411 doc
: /* Concatenate all the arguments and make the result a list.
412 The result is a list whose elements are the elements of all the arguments.
413 Each argument may be a list, vector or string.
414 The last argument is not copied, just used as the tail of the new list.
415 usage: (append &rest SEQUENCES) */)
420 return concat (nargs
, args
, Lisp_Cons
, 1);
423 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
424 doc
: /* Concatenate all the arguments and make the result a string.
425 The result is a string whose elements are the elements of all the arguments.
426 Each argument may be a string or a list or vector of characters (integers).
427 usage: (concat &rest SEQUENCES) */)
432 return concat (nargs
, args
, Lisp_String
, 0);
435 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
436 doc
: /* Concatenate all the arguments and make the result a vector.
437 The result is a vector whose elements are the elements of all the arguments.
438 Each argument may be a list, vector or string.
439 usage: (vconcat &rest SEQUENCES) */)
444 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
447 /* Return a copy of a sub char table ARG. The elements except for a
448 nested sub char table are not copied. */
450 copy_sub_char_table (arg
)
453 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
456 /* Copy all the contents. */
457 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
458 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
459 /* Recursively copy any sub char-tables in the ordinary slots. */
460 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
461 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
462 XCHAR_TABLE (copy
)->contents
[i
]
463 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
469 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
470 doc
: /* Return a copy of a list, vector, string or char-table.
471 The elements of a list or vector are not copied; they are shared
472 with the original. */)
476 if (NILP (arg
)) return arg
;
478 if (CHAR_TABLE_P (arg
))
483 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
484 /* Copy all the slots, including the extra ones. */
485 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
486 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
487 * sizeof (Lisp_Object
)));
489 /* Recursively copy any sub char tables in the ordinary slots
490 for multibyte characters. */
491 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
492 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
493 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
494 XCHAR_TABLE (copy
)->contents
[i
]
495 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
500 if (BOOL_VECTOR_P (arg
))
504 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
506 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
507 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
512 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
513 arg
= wrong_type_argument (Qsequencep
, arg
);
514 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
517 /* In string STR of length LEN, see if bytes before STR[I] combine
518 with bytes after STR[I] to form a single character. If so, return
519 the number of bytes after STR[I] which combine in this way.
520 Otherwize, return 0. */
523 count_combining (str
, len
, i
)
527 int j
= i
- 1, bytes
;
529 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
531 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
532 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
534 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
535 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
538 /* This structure holds information of an argument of `concat' that is
539 a string and has text properties to be copied. */
542 int argnum
; /* refer to ARGS (arguments of `concat') */
543 int from
; /* refer to ARGS[argnum] (argument string) */
544 int to
; /* refer to VAL (the target string) */
548 concat (nargs
, args
, target_type
, last_special
)
551 enum Lisp_Type target_type
;
555 register Lisp_Object tail
;
556 register Lisp_Object
this;
558 int toindex_byte
= 0;
559 register int result_len
;
560 register int result_len_byte
;
562 Lisp_Object last_tail
;
565 /* When we make a multibyte string, we can't copy text properties
566 while concatinating each string because the length of resulting
567 string can't be decided until we finish the whole concatination.
568 So, we record strings that have text properties to be copied
569 here, and copy the text properties after the concatination. */
570 struct textprop_rec
*textprops
= NULL
;
571 /* Number of elments in textprops. */
572 int num_textprops
= 0;
576 /* In append, the last arg isn't treated like the others */
577 if (last_special
&& nargs
> 0)
580 last_tail
= args
[nargs
];
585 /* Canonicalize each argument. */
586 for (argnum
= 0; argnum
< nargs
; argnum
++)
589 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
590 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
592 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
596 /* Compute total length in chars of arguments in RESULT_LEN.
597 If desired output is a string, also compute length in bytes
598 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
599 whether the result should be a multibyte string. */
603 for (argnum
= 0; argnum
< nargs
; argnum
++)
607 len
= XFASTINT (Flength (this));
608 if (target_type
== Lisp_String
)
610 /* We must count the number of bytes needed in the string
611 as well as the number of characters. */
617 for (i
= 0; i
< len
; i
++)
619 ch
= XVECTOR (this)->contents
[i
];
621 wrong_type_argument (Qintegerp
, ch
);
622 this_len_byte
= CHAR_BYTES (XINT (ch
));
623 result_len_byte
+= this_len_byte
;
624 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
627 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
628 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
629 else if (CONSP (this))
630 for (; CONSP (this); this = XCDR (this))
634 wrong_type_argument (Qintegerp
, ch
);
635 this_len_byte
= CHAR_BYTES (XINT (ch
));
636 result_len_byte
+= this_len_byte
;
637 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
640 else if (STRINGP (this))
642 if (STRING_MULTIBYTE (this))
645 result_len_byte
+= SBYTES (this);
648 result_len_byte
+= count_size_as_multibyte (SDATA (this),
656 if (! some_multibyte
)
657 result_len_byte
= result_len
;
659 /* Create the output object. */
660 if (target_type
== Lisp_Cons
)
661 val
= Fmake_list (make_number (result_len
), Qnil
);
662 else if (target_type
== Lisp_Vectorlike
)
663 val
= Fmake_vector (make_number (result_len
), Qnil
);
664 else if (some_multibyte
)
665 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
667 val
= make_uninit_string (result_len
);
669 /* In `append', if all but last arg are nil, return last arg. */
670 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
673 /* Copy the contents of the args into the result. */
675 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
677 toindex
= 0, toindex_byte
= 0;
682 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
684 for (argnum
= 0; argnum
< nargs
; argnum
++)
688 register unsigned int thisindex
= 0;
689 register unsigned int thisindex_byte
= 0;
693 thislen
= Flength (this), thisleni
= XINT (thislen
);
695 /* Between strings of the same kind, copy fast. */
696 if (STRINGP (this) && STRINGP (val
)
697 && STRING_MULTIBYTE (this) == some_multibyte
)
699 int thislen_byte
= SBYTES (this);
702 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
704 combined
= (some_multibyte
&& toindex_byte
> 0
705 ? count_combining (SDATA (val
),
706 toindex_byte
+ thislen_byte
,
709 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
711 textprops
[num_textprops
].argnum
= argnum
;
712 /* We ignore text properties on characters being combined. */
713 textprops
[num_textprops
].from
= combined
;
714 textprops
[num_textprops
++].to
= toindex
;
716 toindex_byte
+= thislen_byte
;
717 toindex
+= thisleni
- combined
;
718 STRING_SET_CHARS (val
, SCHARS (val
) - combined
);
720 /* Copy a single-byte string to a multibyte string. */
721 else if (STRINGP (this) && STRINGP (val
))
723 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
725 textprops
[num_textprops
].argnum
= argnum
;
726 textprops
[num_textprops
].from
= 0;
727 textprops
[num_textprops
++].to
= toindex
;
729 toindex_byte
+= copy_text (SDATA (this),
730 SDATA (val
) + toindex_byte
,
731 SCHARS (this), 0, 1);
735 /* Copy element by element. */
738 register Lisp_Object elt
;
740 /* Fetch next element of `this' arg into `elt', or break if
741 `this' is exhausted. */
742 if (NILP (this)) break;
744 elt
= XCAR (this), this = XCDR (this);
745 else if (thisindex
>= thisleni
)
747 else if (STRINGP (this))
750 if (STRING_MULTIBYTE (this))
752 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
755 XSETFASTINT (elt
, c
);
759 XSETFASTINT (elt
, SREF (this, thisindex
++));
761 && (XINT (elt
) >= 0240
762 || (XINT (elt
) >= 0200
763 && ! NILP (Vnonascii_translation_table
)))
764 && XINT (elt
) < 0400)
766 c
= unibyte_char_to_multibyte (XINT (elt
));
771 else if (BOOL_VECTOR_P (this))
774 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
775 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
782 elt
= XVECTOR (this)->contents
[thisindex
++];
784 /* Store this element into the result. */
791 else if (VECTORP (val
))
792 XVECTOR (val
)->contents
[toindex
++] = elt
;
796 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
800 += CHAR_STRING (XINT (elt
),
801 SDATA (val
) + toindex_byte
);
803 SSET (val
, toindex_byte
++, XINT (elt
));
806 && count_combining (SDATA (val
),
807 toindex_byte
, toindex_byte
- 1))
808 STRING_SET_CHARS (val
, SCHARS (val
) - 1);
813 /* If we have any multibyte characters,
814 we already decided to make a multibyte string. */
817 /* P exists as a variable
818 to avoid a bug on the Masscomp C compiler. */
819 unsigned char *p
= SDATA (val
) + toindex_byte
;
821 toindex_byte
+= CHAR_STRING (c
, p
);
828 XSETCDR (prev
, last_tail
);
830 if (num_textprops
> 0)
833 int last_to_end
= -1;
835 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
837 this = args
[textprops
[argnum
].argnum
];
838 props
= text_property_list (this,
840 make_number (SCHARS (this)),
842 /* If successive arguments have properites, be sure that the
843 value of `composition' property be the copy. */
844 if (last_to_end
== textprops
[argnum
].to
)
845 make_composition_value_copy (props
);
846 add_text_properties_from_list (val
, props
,
847 make_number (textprops
[argnum
].to
));
848 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
854 static Lisp_Object string_char_byte_cache_string
;
855 static int string_char_byte_cache_charpos
;
856 static int string_char_byte_cache_bytepos
;
859 clear_string_char_byte_cache ()
861 string_char_byte_cache_string
= Qnil
;
864 /* Return the character index corresponding to CHAR_INDEX in STRING. */
867 string_char_to_byte (string
, char_index
)
872 int best_below
, best_below_byte
;
873 int best_above
, best_above_byte
;
875 if (! STRING_MULTIBYTE (string
))
878 best_below
= best_below_byte
= 0;
879 best_above
= SCHARS (string
);
880 best_above_byte
= SBYTES (string
);
882 if (EQ (string
, string_char_byte_cache_string
))
884 if (string_char_byte_cache_charpos
< char_index
)
886 best_below
= string_char_byte_cache_charpos
;
887 best_below_byte
= string_char_byte_cache_bytepos
;
891 best_above
= string_char_byte_cache_charpos
;
892 best_above_byte
= string_char_byte_cache_bytepos
;
896 if (char_index
- best_below
< best_above
- char_index
)
898 while (best_below
< char_index
)
901 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
902 best_below
, best_below_byte
);
905 i_byte
= best_below_byte
;
909 while (best_above
> char_index
)
911 unsigned char *pend
= SDATA (string
) + best_above_byte
;
912 unsigned char *pbeg
= pend
- best_above_byte
;
913 unsigned char *p
= pend
- 1;
916 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
917 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
918 if (bytes
== pend
- p
)
919 best_above_byte
-= bytes
;
920 else if (bytes
> pend
- p
)
921 best_above_byte
-= (pend
- p
);
927 i_byte
= best_above_byte
;
930 string_char_byte_cache_bytepos
= i_byte
;
931 string_char_byte_cache_charpos
= i
;
932 string_char_byte_cache_string
= string
;
937 /* Return the character index corresponding to BYTE_INDEX in STRING. */
940 string_byte_to_char (string
, byte_index
)
945 int best_below
, best_below_byte
;
946 int best_above
, best_above_byte
;
948 if (! STRING_MULTIBYTE (string
))
951 best_below
= best_below_byte
= 0;
952 best_above
= SCHARS (string
);
953 best_above_byte
= SBYTES (string
);
955 if (EQ (string
, string_char_byte_cache_string
))
957 if (string_char_byte_cache_bytepos
< byte_index
)
959 best_below
= string_char_byte_cache_charpos
;
960 best_below_byte
= string_char_byte_cache_bytepos
;
964 best_above
= string_char_byte_cache_charpos
;
965 best_above_byte
= string_char_byte_cache_bytepos
;
969 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
971 while (best_below_byte
< byte_index
)
974 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
975 best_below
, best_below_byte
);
978 i_byte
= best_below_byte
;
982 while (best_above_byte
> byte_index
)
984 unsigned char *pend
= SDATA (string
) + best_above_byte
;
985 unsigned char *pbeg
= pend
- best_above_byte
;
986 unsigned char *p
= pend
- 1;
989 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
990 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
991 if (bytes
== pend
- p
)
992 best_above_byte
-= bytes
;
993 else if (bytes
> pend
- p
)
994 best_above_byte
-= (pend
- p
);
1000 i_byte
= best_above_byte
;
1003 string_char_byte_cache_bytepos
= i_byte
;
1004 string_char_byte_cache_charpos
= i
;
1005 string_char_byte_cache_string
= string
;
1010 /* Convert STRING to a multibyte string.
1011 Single-byte characters 0240 through 0377 are converted
1012 by adding nonascii_insert_offset to each. */
1015 string_make_multibyte (string
)
1021 if (STRING_MULTIBYTE (string
))
1024 nbytes
= count_size_as_multibyte (SDATA (string
),
1026 /* If all the chars are ASCII, they won't need any more bytes
1027 once converted. In that case, we can return STRING itself. */
1028 if (nbytes
== SBYTES (string
))
1031 buf
= (unsigned char *) alloca (nbytes
);
1032 copy_text (SDATA (string
), buf
, SBYTES (string
),
1035 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1039 /* Convert STRING to a multibyte string without changing each
1040 character codes. Thus, characters 0200 trough 0237 are converted
1041 to eight-bit-control characters, and characters 0240 through 0377
1042 are converted eight-bit-graphic characters. */
1045 string_to_multibyte (string
)
1052 if (STRING_MULTIBYTE (string
))
1055 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1056 /* If all the chars are ASCII, they won't need any more bytes
1057 once converted. In that case, we can return STRING itself. */
1058 if (nbytes
== SBYTES (string
))
1061 buf
= (unsigned char *) alloca (nbytes
);
1062 bcopy (SDATA (string
), buf
, SBYTES (string
));
1063 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1065 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1069 /* Convert STRING to a single-byte string. */
1072 string_make_unibyte (string
)
1077 if (! STRING_MULTIBYTE (string
))
1080 buf
= (unsigned char *) alloca (SCHARS (string
));
1082 copy_text (SDATA (string
), buf
, SBYTES (string
),
1085 return make_unibyte_string (buf
, SCHARS (string
));
1088 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1090 doc
: /* Return the multibyte equivalent of STRING.
1091 The function `unibyte-char-to-multibyte' is used to convert
1092 each unibyte character to a multibyte character. */)
1096 CHECK_STRING (string
);
1098 return string_make_multibyte (string
);
1101 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1103 doc
: /* Return the unibyte equivalent of STRING.
1104 Multibyte character codes are converted to unibyte according to
1105 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1106 If the lookup in the translation table fails, this function takes just
1107 the low 8 bits of each character. */)
1111 CHECK_STRING (string
);
1113 return string_make_unibyte (string
);
1116 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1118 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1119 If STRING is unibyte, the result is STRING itself.
1120 Otherwise it is a newly created string, with no text properties.
1121 If STRING is multibyte and contains a character of charset
1122 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1123 corresponding single byte. */)
1127 CHECK_STRING (string
);
1129 if (STRING_MULTIBYTE (string
))
1131 int bytes
= SBYTES (string
);
1132 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1134 bcopy (SDATA (string
), str
, bytes
);
1135 bytes
= str_as_unibyte (str
, bytes
);
1136 string
= make_unibyte_string (str
, bytes
);
1142 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1144 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1145 If STRING is multibyte, the result is STRING itself.
1146 Otherwise it is a newly created string, with no text properties.
1147 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1148 part of a multibyte form), it is converted to the corresponding
1149 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1153 CHECK_STRING (string
);
1155 if (! STRING_MULTIBYTE (string
))
1157 Lisp_Object new_string
;
1160 parse_str_as_multibyte (SDATA (string
),
1163 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1164 bcopy (SDATA (string
), SDATA (new_string
),
1166 if (nbytes
!= SBYTES (string
))
1167 str_as_multibyte (SDATA (new_string
), nbytes
,
1168 SBYTES (string
), NULL
);
1169 string
= new_string
;
1170 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1175 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1177 doc
: /* Return a multibyte string with the same individual chars as STRING.
1178 If STRING is multibyte, the result is STRING itself.
1179 Otherwise it is a newly created string, with no text properties.
1180 Characters 0200 through 0237 are converted to eight-bit-control
1181 characters of the same character code. Characters 0240 through 0377
1182 are converted to eight-bit-control characters of the same character
1187 CHECK_STRING (string
);
1189 return string_to_multibyte (string
);
1193 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1194 doc
: /* Return a copy of ALIST.
1195 This is an alist which represents the same mapping from objects to objects,
1196 but does not share the alist structure with ALIST.
1197 The objects mapped (cars and cdrs of elements of the alist)
1198 are shared, however.
1199 Elements of ALIST that are not conses are also shared. */)
1203 register Lisp_Object tem
;
1208 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1209 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1211 register Lisp_Object car
;
1215 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1220 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1221 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1222 TO may be nil or omitted; then the substring runs to the end of STRING.
1223 FROM and TO start at 0. If either is negative, it counts from the end.
1225 This function allows vectors as well as strings. */)
1228 register Lisp_Object from
, to
;
1233 int from_char
, to_char
;
1234 int from_byte
= 0, to_byte
= 0;
1236 if (! (STRINGP (string
) || VECTORP (string
)))
1237 wrong_type_argument (Qarrayp
, string
);
1239 CHECK_NUMBER (from
);
1241 if (STRINGP (string
))
1243 size
= SCHARS (string
);
1244 size_byte
= SBYTES (string
);
1247 size
= XVECTOR (string
)->size
;
1252 to_byte
= size_byte
;
1258 to_char
= XINT (to
);
1262 if (STRINGP (string
))
1263 to_byte
= string_char_to_byte (string
, to_char
);
1266 from_char
= XINT (from
);
1269 if (STRINGP (string
))
1270 from_byte
= string_char_to_byte (string
, from_char
);
1272 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1273 args_out_of_range_3 (string
, make_number (from_char
),
1274 make_number (to_char
));
1276 if (STRINGP (string
))
1278 res
= make_specified_string (SDATA (string
) + from_byte
,
1279 to_char
- from_char
, to_byte
- from_byte
,
1280 STRING_MULTIBYTE (string
));
1281 copy_text_properties (make_number (from_char
), make_number (to_char
),
1282 string
, make_number (0), res
, Qnil
);
1285 res
= Fvector (to_char
- from_char
,
1286 XVECTOR (string
)->contents
+ from_char
);
1292 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1293 doc
: /* Return a substring of STRING, without text properties.
1294 It starts at index FROM and ending before TO.
1295 TO may be nil or omitted; then the substring runs to the end of STRING.
1296 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1297 If FROM or TO is negative, it counts from the end.
1299 With one argument, just copy STRING without its properties. */)
1302 register Lisp_Object from
, to
;
1304 int size
, size_byte
;
1305 int from_char
, to_char
;
1306 int from_byte
, to_byte
;
1308 CHECK_STRING (string
);
1310 size
= SCHARS (string
);
1311 size_byte
= SBYTES (string
);
1314 from_char
= from_byte
= 0;
1317 CHECK_NUMBER (from
);
1318 from_char
= XINT (from
);
1322 from_byte
= string_char_to_byte (string
, from_char
);
1328 to_byte
= size_byte
;
1334 to_char
= XINT (to
);
1338 to_byte
= string_char_to_byte (string
, to_char
);
1341 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1342 args_out_of_range_3 (string
, make_number (from_char
),
1343 make_number (to_char
));
1345 return make_specified_string (SDATA (string
) + from_byte
,
1346 to_char
- from_char
, to_byte
- from_byte
,
1347 STRING_MULTIBYTE (string
));
1350 /* Extract a substring of STRING, giving start and end positions
1351 both in characters and in bytes. */
1354 substring_both (string
, from
, from_byte
, to
, to_byte
)
1356 int from
, from_byte
, to
, to_byte
;
1362 if (! (STRINGP (string
) || VECTORP (string
)))
1363 wrong_type_argument (Qarrayp
, string
);
1365 if (STRINGP (string
))
1367 size
= SCHARS (string
);
1368 size_byte
= SBYTES (string
);
1371 size
= XVECTOR (string
)->size
;
1373 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1374 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1376 if (STRINGP (string
))
1378 res
= make_specified_string (SDATA (string
) + from_byte
,
1379 to
- from
, to_byte
- from_byte
,
1380 STRING_MULTIBYTE (string
));
1381 copy_text_properties (make_number (from
), make_number (to
),
1382 string
, make_number (0), res
, Qnil
);
1385 res
= Fvector (to
- from
,
1386 XVECTOR (string
)->contents
+ from
);
1391 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1392 doc
: /* Take cdr N times on LIST, returns the result. */)
1395 register Lisp_Object list
;
1397 register int i
, num
;
1400 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1404 wrong_type_argument (Qlistp
, list
);
1410 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1411 doc
: /* Return the Nth element of LIST.
1412 N counts from zero. If LIST is not that long, nil is returned. */)
1414 Lisp_Object n
, list
;
1416 return Fcar (Fnthcdr (n
, list
));
1419 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1420 doc
: /* Return element of SEQUENCE at index N. */)
1422 register Lisp_Object sequence
, n
;
1427 if (CONSP (sequence
) || NILP (sequence
))
1428 return Fcar (Fnthcdr (n
, sequence
));
1429 else if (STRINGP (sequence
) || VECTORP (sequence
)
1430 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1431 return Faref (sequence
, n
);
1433 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1437 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1438 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1439 The value is actually the tail of LIST whose car is ELT. */)
1441 register Lisp_Object elt
;
1444 register Lisp_Object tail
;
1445 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1447 register Lisp_Object tem
;
1449 wrong_type_argument (Qlistp
, list
);
1451 if (! NILP (Fequal (elt
, tem
)))
1458 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1459 doc
: /* Return non-nil if ELT is an element of LIST.
1460 Comparison done with EQ. The value is actually the tail of LIST
1461 whose car is ELT. */)
1463 Lisp_Object elt
, list
;
1467 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1471 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1475 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1482 if (!CONSP (list
) && !NILP (list
))
1483 list
= wrong_type_argument (Qlistp
, list
);
1488 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1489 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1490 The value is actually the element of LIST whose car is KEY.
1491 Elements of LIST that are not conses are ignored. */)
1493 Lisp_Object key
, list
;
1500 || (CONSP (XCAR (list
))
1501 && EQ (XCAR (XCAR (list
)), key
)))
1506 || (CONSP (XCAR (list
))
1507 && EQ (XCAR (XCAR (list
)), key
)))
1512 || (CONSP (XCAR (list
))
1513 && EQ (XCAR (XCAR (list
)), key
)))
1521 result
= XCAR (list
);
1522 else if (NILP (list
))
1525 result
= wrong_type_argument (Qlistp
, list
);
1530 /* Like Fassq but never report an error and do not allow quits.
1531 Use only on lists known never to be circular. */
1534 assq_no_quit (key
, list
)
1535 Lisp_Object key
, list
;
1538 && (!CONSP (XCAR (list
))
1539 || !EQ (XCAR (XCAR (list
)), key
)))
1542 return CONSP (list
) ? XCAR (list
) : Qnil
;
1545 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1546 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1547 The value is actually the element of LIST whose car equals KEY. */)
1549 Lisp_Object key
, list
;
1551 Lisp_Object result
, car
;
1556 || (CONSP (XCAR (list
))
1557 && (car
= XCAR (XCAR (list
)),
1558 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1563 || (CONSP (XCAR (list
))
1564 && (car
= XCAR (XCAR (list
)),
1565 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1570 || (CONSP (XCAR (list
))
1571 && (car
= XCAR (XCAR (list
)),
1572 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1580 result
= XCAR (list
);
1581 else if (NILP (list
))
1584 result
= wrong_type_argument (Qlistp
, list
);
1589 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1590 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1591 The value is actually the element of LIST whose cdr is KEY. */)
1593 register Lisp_Object key
;
1601 || (CONSP (XCAR (list
))
1602 && EQ (XCDR (XCAR (list
)), key
)))
1607 || (CONSP (XCAR (list
))
1608 && EQ (XCDR (XCAR (list
)), key
)))
1613 || (CONSP (XCAR (list
))
1614 && EQ (XCDR (XCAR (list
)), key
)))
1623 else if (CONSP (list
))
1624 result
= XCAR (list
);
1626 result
= wrong_type_argument (Qlistp
, list
);
1631 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1632 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1633 The value is actually the element of LIST whose cdr equals KEY. */)
1635 Lisp_Object key
, list
;
1637 Lisp_Object result
, cdr
;
1642 || (CONSP (XCAR (list
))
1643 && (cdr
= XCDR (XCAR (list
)),
1644 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1649 || (CONSP (XCAR (list
))
1650 && (cdr
= XCDR (XCAR (list
)),
1651 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1656 || (CONSP (XCAR (list
))
1657 && (cdr
= XCDR (XCAR (list
)),
1658 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1666 result
= XCAR (list
);
1667 else if (NILP (list
))
1670 result
= wrong_type_argument (Qlistp
, list
);
1675 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1676 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1677 The modified LIST is returned. Comparison is done with `eq'.
1678 If the first member of LIST is ELT, there is no way to remove it by side effect;
1679 therefore, write `(setq foo (delq element foo))'
1680 to be sure of changing the value of `foo'. */)
1682 register Lisp_Object elt
;
1685 register Lisp_Object tail
, prev
;
1686 register Lisp_Object tem
;
1690 while (!NILP (tail
))
1693 wrong_type_argument (Qlistp
, list
);
1700 Fsetcdr (prev
, XCDR (tail
));
1710 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1711 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1712 SEQ must be a list, a vector, or a string.
1713 The modified SEQ is returned. Comparison is done with `equal'.
1714 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1715 is not a side effect; it is simply using a different sequence.
1716 Therefore, write `(setq foo (delete element foo))'
1717 to be sure of changing the value of `foo'. */)
1719 Lisp_Object elt
, seq
;
1725 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1726 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1729 if (n
!= ASIZE (seq
))
1731 struct Lisp_Vector
*p
= allocate_vector (n
);
1733 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1734 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1735 p
->contents
[n
++] = AREF (seq
, i
);
1737 XSETVECTOR (seq
, p
);
1740 else if (STRINGP (seq
))
1742 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1745 for (i
= nchars
= nbytes
= ibyte
= 0;
1747 ++i
, ibyte
+= cbytes
)
1749 if (STRING_MULTIBYTE (seq
))
1751 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1752 SBYTES (seq
) - ibyte
);
1753 cbytes
= CHAR_BYTES (c
);
1761 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1768 if (nchars
!= SCHARS (seq
))
1772 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1773 if (!STRING_MULTIBYTE (seq
))
1774 STRING_SET_UNIBYTE (tem
);
1776 for (i
= nchars
= nbytes
= ibyte
= 0;
1778 ++i
, ibyte
+= cbytes
)
1780 if (STRING_MULTIBYTE (seq
))
1782 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1783 SBYTES (seq
) - ibyte
);
1784 cbytes
= CHAR_BYTES (c
);
1792 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1794 unsigned char *from
= SDATA (seq
) + ibyte
;
1795 unsigned char *to
= SDATA (tem
) + nbytes
;
1801 for (n
= cbytes
; n
--; )
1811 Lisp_Object tail
, prev
;
1813 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1816 wrong_type_argument (Qlistp
, seq
);
1818 if (!NILP (Fequal (elt
, XCAR (tail
))))
1823 Fsetcdr (prev
, XCDR (tail
));
1834 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1835 doc
: /* Reverse LIST by modifying cdr pointers.
1836 Returns the beginning of the reversed list. */)
1840 register Lisp_Object prev
, tail
, next
;
1842 if (NILP (list
)) return list
;
1845 while (!NILP (tail
))
1849 wrong_type_argument (Qlistp
, list
);
1851 Fsetcdr (tail
, prev
);
1858 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1859 doc
: /* Reverse LIST, copying. Returns the beginning of the reversed list.
1860 See also the function `nreverse', which is used more often. */)
1866 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1869 new = Fcons (XCAR (list
), new);
1872 wrong_type_argument (Qconsp
, list
);
1876 Lisp_Object
merge ();
1878 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1879 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1880 Returns the sorted list. LIST is modified by side effects.
1881 PREDICATE is called with two elements of LIST, and should return t
1882 if the first element is "less" than the second. */)
1884 Lisp_Object list
, predicate
;
1886 Lisp_Object front
, back
;
1887 register Lisp_Object len
, tem
;
1888 struct gcpro gcpro1
, gcpro2
;
1889 register int length
;
1892 len
= Flength (list
);
1893 length
= XINT (len
);
1897 XSETINT (len
, (length
/ 2) - 1);
1898 tem
= Fnthcdr (len
, list
);
1900 Fsetcdr (tem
, Qnil
);
1902 GCPRO2 (front
, back
);
1903 front
= Fsort (front
, predicate
);
1904 back
= Fsort (back
, predicate
);
1906 return merge (front
, back
, predicate
);
1910 merge (org_l1
, org_l2
, pred
)
1911 Lisp_Object org_l1
, org_l2
;
1915 register Lisp_Object tail
;
1917 register Lisp_Object l1
, l2
;
1918 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1925 /* It is sufficient to protect org_l1 and org_l2.
1926 When l1 and l2 are updated, we copy the new values
1927 back into the org_ vars. */
1928 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1948 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1964 Fsetcdr (tail
, tem
);
1970 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1971 doc
: /* Extract a value from a property list.
1972 PLIST is a property list, which is a list of the form
1973 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1974 corresponding to the given PROP, or nil if PROP is not
1975 one of the properties on the list. */)
1983 CONSP (tail
) && CONSP (XCDR (tail
));
1984 tail
= XCDR (XCDR (tail
)))
1986 if (EQ (prop
, XCAR (tail
)))
1987 return XCAR (XCDR (tail
));
1989 /* This function can be called asynchronously
1990 (setup_coding_system). Don't QUIT in that case. */
1991 if (!interrupt_input_blocked
)
1996 wrong_type_argument (Qlistp
, prop
);
2001 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2002 doc
: /* Return the value of SYMBOL's PROPNAME property.
2003 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2005 Lisp_Object symbol
, propname
;
2007 CHECK_SYMBOL (symbol
);
2008 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2011 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2012 doc
: /* Change value in PLIST of PROP to VAL.
2013 PLIST is a property list, which is a list of the form
2014 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2015 If PROP is already a property on the list, its value is set to VAL,
2016 otherwise the new PROP VAL pair is added. The new plist is returned;
2017 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2018 The PLIST is modified by side effects. */)
2021 register Lisp_Object prop
;
2024 register Lisp_Object tail
, prev
;
2025 Lisp_Object newcell
;
2027 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2028 tail
= XCDR (XCDR (tail
)))
2030 if (EQ (prop
, XCAR (tail
)))
2032 Fsetcar (XCDR (tail
), val
);
2039 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2043 Fsetcdr (XCDR (prev
), newcell
);
2047 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2048 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2049 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2050 (symbol
, propname
, value
)
2051 Lisp_Object symbol
, propname
, value
;
2053 CHECK_SYMBOL (symbol
);
2054 XSYMBOL (symbol
)->plist
2055 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2059 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2060 doc
: /* Extract a value from a property list, comparing with `equal'.
2061 PLIST is a property list, which is a list of the form
2062 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2063 corresponding to the given PROP, or nil if PROP is not
2064 one of the properties on the list. */)
2072 CONSP (tail
) && CONSP (XCDR (tail
));
2073 tail
= XCDR (XCDR (tail
)))
2075 if (! NILP (Fequal (prop
, XCAR (tail
))))
2076 return XCAR (XCDR (tail
));
2082 wrong_type_argument (Qlistp
, prop
);
2087 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2088 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2089 PLIST is a property list, which is a list of the form
2090 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2091 If PROP is already a property on the list, its value is set to VAL,
2092 otherwise the new PROP VAL pair is added. The new plist is returned;
2093 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2094 The PLIST is modified by side effects. */)
2097 register Lisp_Object prop
;
2100 register Lisp_Object tail
, prev
;
2101 Lisp_Object newcell
;
2103 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2104 tail
= XCDR (XCDR (tail
)))
2106 if (! NILP (Fequal (prop
, XCAR (tail
))))
2108 Fsetcar (XCDR (tail
), val
);
2115 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2119 Fsetcdr (XCDR (prev
), newcell
);
2123 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2124 doc
: /* Return t if two Lisp objects have similar structure and contents.
2125 They must have the same data type.
2126 Conses are compared by comparing the cars and the cdrs.
2127 Vectors and strings are compared element by element.
2128 Numbers are compared by value, but integers cannot equal floats.
2129 (Use `=' if you want integers and floats to be able to be equal.)
2130 Symbols must match exactly. */)
2132 register Lisp_Object o1
, o2
;
2134 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2138 internal_equal (o1
, o2
, depth
)
2139 register Lisp_Object o1
, o2
;
2143 error ("Stack overflow in equal");
2149 if (XTYPE (o1
) != XTYPE (o2
))
2155 return (extract_float (o1
) == extract_float (o2
));
2158 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2165 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2169 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2171 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2174 o1
= XOVERLAY (o1
)->plist
;
2175 o2
= XOVERLAY (o2
)->plist
;
2180 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2181 && (XMARKER (o1
)->buffer
== 0
2182 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2186 case Lisp_Vectorlike
:
2188 register int i
, size
;
2189 size
= XVECTOR (o1
)->size
;
2190 /* Pseudovectors have the type encoded in the size field, so this test
2191 actually checks that the objects have the same type as well as the
2193 if (XVECTOR (o2
)->size
!= size
)
2195 /* Boolvectors are compared much like strings. */
2196 if (BOOL_VECTOR_P (o1
))
2199 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2201 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2203 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2208 if (WINDOW_CONFIGURATIONP (o1
))
2209 return compare_window_configurations (o1
, o2
, 0);
2211 /* Aside from them, only true vectors, char-tables, and compiled
2212 functions are sensible to compare, so eliminate the others now. */
2213 if (size
& PSEUDOVECTOR_FLAG
)
2215 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2217 size
&= PSEUDOVECTOR_SIZE_MASK
;
2219 for (i
= 0; i
< size
; i
++)
2222 v1
= XVECTOR (o1
)->contents
[i
];
2223 v2
= XVECTOR (o2
)->contents
[i
];
2224 if (!internal_equal (v1
, v2
, depth
+ 1))
2232 if (SCHARS (o1
) != SCHARS (o2
))
2234 if (SBYTES (o1
) != SBYTES (o2
))
2236 if (bcmp (SDATA (o1
), SDATA (o2
),
2243 case Lisp_Type_Limit
:
2250 extern Lisp_Object
Fmake_char_internal ();
2252 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2253 doc
: /* Store each element of ARRAY with ITEM.
2254 ARRAY is a vector, string, char-table, or bool-vector. */)
2256 Lisp_Object array
, item
;
2258 register int size
, index
, charval
;
2260 if (VECTORP (array
))
2262 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2263 size
= XVECTOR (array
)->size
;
2264 for (index
= 0; index
< size
; index
++)
2267 else if (CHAR_TABLE_P (array
))
2269 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2270 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2271 for (index
= 0; index
< size
; index
++)
2273 XCHAR_TABLE (array
)->defalt
= Qnil
;
2275 else if (STRINGP (array
))
2277 register unsigned char *p
= SDATA (array
);
2278 CHECK_NUMBER (item
);
2279 charval
= XINT (item
);
2280 size
= SCHARS (array
);
2281 if (STRING_MULTIBYTE (array
))
2283 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2284 int len
= CHAR_STRING (charval
, str
);
2285 int size_byte
= SBYTES (array
);
2286 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2289 if (size
!= size_byte
)
2292 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2293 if (len
!= this_len
)
2294 error ("Attempt to change byte length of a string");
2297 for (i
= 0; i
< size_byte
; i
++)
2298 *p
++ = str
[i
% len
];
2301 for (index
= 0; index
< size
; index
++)
2304 else if (BOOL_VECTOR_P (array
))
2306 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2308 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2310 charval
= (! NILP (item
) ? -1 : 0);
2311 for (index
= 0; index
< size_in_chars
; index
++)
2316 array
= wrong_type_argument (Qarrayp
, array
);
2322 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2324 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2326 Lisp_Object char_table
;
2328 CHECK_CHAR_TABLE (char_table
);
2330 return XCHAR_TABLE (char_table
)->purpose
;
2333 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2335 doc
: /* Return the parent char-table of CHAR-TABLE.
2336 The value is either nil or another char-table.
2337 If CHAR-TABLE holds nil for a given character,
2338 then the actual applicable value is inherited from the parent char-table
2339 \(or from its parents, if necessary). */)
2341 Lisp_Object char_table
;
2343 CHECK_CHAR_TABLE (char_table
);
2345 return XCHAR_TABLE (char_table
)->parent
;
2348 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2350 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2351 PARENT must be either nil or another char-table. */)
2352 (char_table
, parent
)
2353 Lisp_Object char_table
, parent
;
2357 CHECK_CHAR_TABLE (char_table
);
2361 CHECK_CHAR_TABLE (parent
);
2363 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2364 if (EQ (temp
, char_table
))
2365 error ("Attempt to make a chartable be its own parent");
2368 XCHAR_TABLE (char_table
)->parent
= parent
;
2373 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2375 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2377 Lisp_Object char_table
, n
;
2379 CHECK_CHAR_TABLE (char_table
);
2382 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2383 args_out_of_range (char_table
, n
);
2385 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2388 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2389 Sset_char_table_extra_slot
,
2391 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2392 (char_table
, n
, value
)
2393 Lisp_Object char_table
, n
, value
;
2395 CHECK_CHAR_TABLE (char_table
);
2398 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2399 args_out_of_range (char_table
, n
);
2401 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2404 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2406 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2407 RANGE should be nil (for the default value)
2408 a vector which identifies a character set or a row of a character set,
2409 a character set name, or a character code. */)
2411 Lisp_Object char_table
, range
;
2413 CHECK_CHAR_TABLE (char_table
);
2415 if (EQ (range
, Qnil
))
2416 return XCHAR_TABLE (char_table
)->defalt
;
2417 else if (INTEGERP (range
))
2418 return Faref (char_table
, range
);
2419 else if (SYMBOLP (range
))
2421 Lisp_Object charset_info
;
2423 charset_info
= Fget (range
, Qcharset
);
2424 CHECK_VECTOR (charset_info
);
2426 return Faref (char_table
,
2427 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2430 else if (VECTORP (range
))
2432 if (XVECTOR (range
)->size
== 1)
2433 return Faref (char_table
,
2434 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2437 int size
= XVECTOR (range
)->size
;
2438 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2439 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2440 size
<= 1 ? Qnil
: val
[1],
2441 size
<= 2 ? Qnil
: val
[2]);
2442 return Faref (char_table
, ch
);
2446 error ("Invalid RANGE argument to `char-table-range'");
2450 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2452 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2453 RANGE should be t (for all characters), nil (for the default value)
2454 a vector which identifies a character set or a row of a character set,
2455 a coding system, or a character code. */)
2456 (char_table
, range
, value
)
2457 Lisp_Object char_table
, range
, value
;
2461 CHECK_CHAR_TABLE (char_table
);
2464 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2465 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2466 else if (EQ (range
, Qnil
))
2467 XCHAR_TABLE (char_table
)->defalt
= value
;
2468 else if (SYMBOLP (range
))
2470 Lisp_Object charset_info
;
2472 charset_info
= Fget (range
, Qcharset
);
2473 CHECK_VECTOR (charset_info
);
2475 return Faset (char_table
,
2476 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2480 else if (INTEGERP (range
))
2481 Faset (char_table
, range
, value
);
2482 else if (VECTORP (range
))
2484 if (XVECTOR (range
)->size
== 1)
2485 return Faset (char_table
,
2486 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2490 int size
= XVECTOR (range
)->size
;
2491 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2492 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2493 size
<= 1 ? Qnil
: val
[1],
2494 size
<= 2 ? Qnil
: val
[2]);
2495 return Faset (char_table
, ch
, value
);
2499 error ("Invalid RANGE argument to `set-char-table-range'");
2504 DEFUN ("set-char-table-default", Fset_char_table_default
,
2505 Sset_char_table_default
, 3, 3, 0,
2506 doc
: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
2507 The generic character specifies the group of characters.
2508 See also the documentation of make-char. */)
2509 (char_table
, ch
, value
)
2510 Lisp_Object char_table
, ch
, value
;
2512 int c
, charset
, code1
, code2
;
2515 CHECK_CHAR_TABLE (char_table
);
2519 SPLIT_CHAR (c
, charset
, code1
, code2
);
2521 /* Since we may want to set the default value for a character set
2522 not yet defined, we check only if the character set is in the
2523 valid range or not, instead of it is already defined or not. */
2524 if (! CHARSET_VALID_P (charset
))
2525 invalid_character (c
);
2527 if (charset
== CHARSET_ASCII
)
2528 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2530 /* Even if C is not a generic char, we had better behave as if a
2531 generic char is specified. */
2532 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2534 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2537 if (SUB_CHAR_TABLE_P (temp
))
2538 XCHAR_TABLE (temp
)->defalt
= value
;
2540 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2543 if (SUB_CHAR_TABLE_P (temp
))
2546 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2547 = make_sub_char_table (temp
));
2548 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2549 if (SUB_CHAR_TABLE_P (temp
))
2550 XCHAR_TABLE (temp
)->defalt
= value
;
2552 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2556 /* Look up the element in TABLE at index CH,
2557 and return it as an integer.
2558 If the element is nil, return CH itself.
2559 (Actually we do that for any non-integer.) */
2562 char_table_translate (table
, ch
)
2567 value
= Faref (table
, make_number (ch
));
2568 if (! INTEGERP (value
))
2570 return XINT (value
);
2574 optimize_sub_char_table (table
, chars
)
2582 from
= 33, to
= 127;
2584 from
= 32, to
= 128;
2586 if (!SUB_CHAR_TABLE_P (*table
))
2588 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2589 for (; from
< to
; from
++)
2590 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2595 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2596 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2604 CHECK_CHAR_TABLE (table
);
2606 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2608 elt
= XCHAR_TABLE (table
)->contents
[i
];
2609 if (!SUB_CHAR_TABLE_P (elt
))
2611 dim
= CHARSET_DIMENSION (i
- 128);
2613 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2614 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2615 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2621 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2622 character or group of characters that share a value.
2623 DEPTH is the current depth in the originally specified
2624 chartable, and INDICES contains the vector indices
2625 for the levels our callers have descended.
2627 ARG is passed to C_FUNCTION when that is called. */
2630 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2631 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2632 Lisp_Object function
, subtable
, arg
, *indices
;
2639 /* At first, handle ASCII and 8-bit European characters. */
2640 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2642 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2644 (*c_function
) (arg
, make_number (i
), elt
);
2646 call2 (function
, make_number (i
), elt
);
2648 #if 0 /* If the char table has entries for higher characters,
2649 we should report them. */
2650 if (NILP (current_buffer
->enable_multibyte_characters
))
2653 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2657 int charset
= XFASTINT (indices
[0]) - 128;
2660 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2661 if (CHARSET_CHARS (charset
) == 94)
2670 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2671 XSETFASTINT (indices
[depth
], i
);
2672 charset
= XFASTINT (indices
[0]) - 128;
2674 && (!CHARSET_DEFINED_P (charset
)
2675 || charset
== CHARSET_8_BIT_CONTROL
2676 || charset
== CHARSET_8_BIT_GRAPHIC
))
2679 if (SUB_CHAR_TABLE_P (elt
))
2682 error ("Too deep char table");
2683 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2690 elt
= XCHAR_TABLE (subtable
)->defalt
;
2691 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2692 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2693 c
= MAKE_CHAR (charset
, c1
, c2
);
2695 (*c_function
) (arg
, make_number (c
), elt
);
2697 call2 (function
, make_number (c
), elt
);
2702 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2704 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2705 FUNCTION is called with two arguments--a key and a value.
2706 The key is always a possible IDX argument to `aref'. */)
2707 (function
, char_table
)
2708 Lisp_Object function
, char_table
;
2710 /* The depth of char table is at most 3. */
2711 Lisp_Object indices
[3];
2713 CHECK_CHAR_TABLE (char_table
);
2715 map_char_table ((POINTER_TYPE
*) call2
, Qnil
, char_table
, function
, 0, indices
);
2719 /* Return a value for character C in char-table TABLE. Store the
2720 actual index for that value in *IDX. Ignore the default value of
2724 char_table_ref_and_index (table
, c
, idx
)
2728 int charset
, c1
, c2
;
2731 if (SINGLE_BYTE_CHAR_P (c
))
2734 return XCHAR_TABLE (table
)->contents
[c
];
2736 SPLIT_CHAR (c
, charset
, c1
, c2
);
2737 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2738 *idx
= MAKE_CHAR (charset
, 0, 0);
2739 if (!SUB_CHAR_TABLE_P (elt
))
2741 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2742 return XCHAR_TABLE (elt
)->defalt
;
2743 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2744 *idx
= MAKE_CHAR (charset
, c1
, 0);
2745 if (!SUB_CHAR_TABLE_P (elt
))
2747 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2748 return XCHAR_TABLE (elt
)->defalt
;
2750 return XCHAR_TABLE (elt
)->contents
[c2
];
2760 Lisp_Object args
[2];
2763 return Fnconc (2, args
);
2765 return Fnconc (2, &s1
);
2766 #endif /* NO_ARG_ARRAY */
2769 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2770 doc
: /* Concatenate any number of lists by altering them.
2771 Only the last argument is not altered, and need not be a list.
2772 usage: (nconc &rest LISTS) */)
2777 register int argnum
;
2778 register Lisp_Object tail
, tem
, val
;
2782 for (argnum
= 0; argnum
< nargs
; argnum
++)
2785 if (NILP (tem
)) continue;
2790 if (argnum
+ 1 == nargs
) break;
2793 tem
= wrong_type_argument (Qlistp
, tem
);
2802 tem
= args
[argnum
+ 1];
2803 Fsetcdr (tail
, tem
);
2805 args
[argnum
+ 1] = tail
;
2811 /* This is the guts of all mapping functions.
2812 Apply FN to each element of SEQ, one by one,
2813 storing the results into elements of VALS, a C vector of Lisp_Objects.
2814 LENI is the length of VALS, which should also be the length of SEQ. */
2817 mapcar1 (leni
, vals
, fn
, seq
)
2820 Lisp_Object fn
, seq
;
2822 register Lisp_Object tail
;
2825 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2829 /* Don't let vals contain any garbage when GC happens. */
2830 for (i
= 0; i
< leni
; i
++)
2833 GCPRO3 (dummy
, fn
, seq
);
2835 gcpro1
.nvars
= leni
;
2839 /* We need not explicitly protect `tail' because it is used only on lists, and
2840 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2844 for (i
= 0; i
< leni
; i
++)
2846 dummy
= XVECTOR (seq
)->contents
[i
];
2847 dummy
= call1 (fn
, dummy
);
2852 else if (BOOL_VECTOR_P (seq
))
2854 for (i
= 0; i
< leni
; i
++)
2857 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2858 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2863 dummy
= call1 (fn
, dummy
);
2868 else if (STRINGP (seq
))
2872 for (i
= 0, i_byte
= 0; i
< leni
;)
2877 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2878 XSETFASTINT (dummy
, c
);
2879 dummy
= call1 (fn
, dummy
);
2881 vals
[i_before
] = dummy
;
2884 else /* Must be a list, since Flength did not get an error */
2887 for (i
= 0; i
< leni
; i
++)
2889 dummy
= call1 (fn
, Fcar (tail
));
2899 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2900 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2901 In between each pair of results, stick in SEPARATOR. Thus, " " as
2902 SEPARATOR results in spaces between the values returned by FUNCTION.
2903 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2904 (function
, sequence
, separator
)
2905 Lisp_Object function
, sequence
, separator
;
2910 register Lisp_Object
*args
;
2912 struct gcpro gcpro1
;
2914 len
= Flength (sequence
);
2916 nargs
= leni
+ leni
- 1;
2917 if (nargs
< 0) return build_string ("");
2919 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2922 mapcar1 (leni
, args
, function
, sequence
);
2925 for (i
= leni
- 1; i
>= 0; i
--)
2926 args
[i
+ i
] = args
[i
];
2928 for (i
= 1; i
< nargs
; i
+= 2)
2929 args
[i
] = separator
;
2931 return Fconcat (nargs
, args
);
2934 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2935 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2936 The result is a list just as long as SEQUENCE.
2937 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2938 (function
, sequence
)
2939 Lisp_Object function
, sequence
;
2941 register Lisp_Object len
;
2943 register Lisp_Object
*args
;
2945 len
= Flength (sequence
);
2946 leni
= XFASTINT (len
);
2947 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2949 mapcar1 (leni
, args
, function
, sequence
);
2951 return Flist (leni
, args
);
2954 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2955 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2956 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2957 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2958 (function
, sequence
)
2959 Lisp_Object function
, sequence
;
2963 leni
= XFASTINT (Flength (sequence
));
2964 mapcar1 (leni
, 0, function
, sequence
);
2969 /* Anything that calls this function must protect from GC! */
2971 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2972 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2973 Takes one argument, which is the string to display to ask the question.
2974 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2975 No confirmation of the answer is requested; a single character is enough.
2976 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2977 the bindings in `query-replace-map'; see the documentation of that variable
2978 for more information. In this case, the useful bindings are `act', `skip',
2979 `recenter', and `quit'.\)
2981 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2982 is nil and `use-dialog-box' is non-nil. */)
2986 register Lisp_Object obj
, key
, def
, map
;
2987 register int answer
;
2988 Lisp_Object xprompt
;
2989 Lisp_Object args
[2];
2990 struct gcpro gcpro1
, gcpro2
;
2991 int count
= SPECPDL_INDEX ();
2993 specbind (Qcursor_in_echo_area
, Qt
);
2995 map
= Fsymbol_value (intern ("query-replace-map"));
2997 CHECK_STRING (prompt
);
2999 GCPRO2 (prompt
, xprompt
);
3001 #ifdef HAVE_X_WINDOWS
3002 if (display_hourglass_p
)
3003 cancel_hourglass ();
3010 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3014 Lisp_Object pane
, menu
;
3015 redisplay_preserve_echo_area (3);
3016 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3017 Fcons (Fcons (build_string ("No"), Qnil
),
3019 menu
= Fcons (prompt
, pane
);
3020 obj
= Fx_popup_dialog (Qt
, menu
);
3021 answer
= !NILP (obj
);
3024 #endif /* HAVE_MENUS */
3025 cursor_in_echo_area
= 1;
3026 choose_minibuf_frame ();
3029 Lisp_Object pargs
[3];
3031 /* Colorize prompt according to `minibuffer-prompt' face. */
3032 pargs
[0] = build_string ("%s(y or n) ");
3033 pargs
[1] = intern ("face");
3034 pargs
[2] = intern ("minibuffer-prompt");
3035 args
[0] = Fpropertize (3, pargs
);
3040 if (minibuffer_auto_raise
)
3042 Lisp_Object mini_frame
;
3044 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3046 Fraise_frame (mini_frame
);
3049 obj
= read_filtered_event (1, 0, 0, 0);
3050 cursor_in_echo_area
= 0;
3051 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3054 key
= Fmake_vector (make_number (1), obj
);
3055 def
= Flookup_key (map
, key
, Qt
);
3057 if (EQ (def
, intern ("skip")))
3062 else if (EQ (def
, intern ("act")))
3067 else if (EQ (def
, intern ("recenter")))
3073 else if (EQ (def
, intern ("quit")))
3075 /* We want to exit this command for exit-prefix,
3076 and this is the only way to do it. */
3077 else if (EQ (def
, intern ("exit-prefix")))
3082 /* If we don't clear this, then the next call to read_char will
3083 return quit_char again, and we'll enter an infinite loop. */
3088 if (EQ (xprompt
, prompt
))
3090 args
[0] = build_string ("Please answer y or n. ");
3092 xprompt
= Fconcat (2, args
);
3097 if (! noninteractive
)
3099 cursor_in_echo_area
= -1;
3100 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3104 unbind_to (count
, Qnil
);
3105 return answer
? Qt
: Qnil
;
3108 /* This is how C code calls `yes-or-no-p' and allows the user
3111 Anything that calls this function must protect from GC! */
3114 do_yes_or_no_p (prompt
)
3117 return call1 (intern ("yes-or-no-p"), prompt
);
3120 /* Anything that calls this function must protect from GC! */
3122 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3123 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3124 Takes one argument, which is the string to display to ask the question.
3125 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3126 The user must confirm the answer with RET,
3127 and can edit it until it has been confirmed.
3129 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3130 is nil, and `use-dialog-box' is non-nil. */)
3134 register Lisp_Object ans
;
3135 Lisp_Object args
[2];
3136 struct gcpro gcpro1
;
3138 CHECK_STRING (prompt
);
3141 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3145 Lisp_Object pane
, menu
, obj
;
3146 redisplay_preserve_echo_area (4);
3147 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3148 Fcons (Fcons (build_string ("No"), Qnil
),
3151 menu
= Fcons (prompt
, pane
);
3152 obj
= Fx_popup_dialog (Qt
, menu
);
3156 #endif /* HAVE_MENUS */
3159 args
[1] = build_string ("(yes or no) ");
3160 prompt
= Fconcat (2, args
);
3166 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3167 Qyes_or_no_p_history
, Qnil
,
3169 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3174 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3182 message ("Please answer yes or no.");
3183 Fsleep_for (make_number (2), Qnil
);
3187 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3188 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3190 Each of the three load averages is multiplied by 100, then converted
3193 When USE-FLOATS is non-nil, floats will be used instead of integers.
3194 These floats are not multiplied by 100.
3196 If the 5-minute or 15-minute load averages are not available, return a
3197 shortened list, containing only those averages which are available. */)
3199 Lisp_Object use_floats
;
3202 int loads
= getloadavg (load_ave
, 3);
3203 Lisp_Object ret
= Qnil
;
3206 error ("load-average not implemented for this operating system");
3210 Lisp_Object load
= (NILP (use_floats
) ?
3211 make_number ((int) (100.0 * load_ave
[loads
]))
3212 : make_float (load_ave
[loads
]));
3213 ret
= Fcons (load
, ret
);
3219 Lisp_Object Vfeatures
, Qsubfeatures
;
3220 extern Lisp_Object Vafter_load_alist
;
3222 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3223 doc
: /* Returns t if FEATURE is present in this Emacs.
3225 Use this to conditionalize execution of lisp code based on the
3226 presence or absence of emacs or environment extensions.
3227 Use `provide' to declare that a feature is available. This function
3228 looks at the value of the variable `features'. The optional argument
3229 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3230 (feature
, subfeature
)
3231 Lisp_Object feature
, subfeature
;
3233 register Lisp_Object tem
;
3234 CHECK_SYMBOL (feature
);
3235 tem
= Fmemq (feature
, Vfeatures
);
3236 if (!NILP (tem
) && !NILP (subfeature
))
3237 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3238 return (NILP (tem
)) ? Qnil
: Qt
;
3241 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3242 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3243 The optional argument SUBFEATURES should be a list of symbols listing
3244 particular subfeatures supported in this version of FEATURE. */)
3245 (feature
, subfeatures
)
3246 Lisp_Object feature
, subfeatures
;
3248 register Lisp_Object tem
;
3249 CHECK_SYMBOL (feature
);
3250 CHECK_LIST (subfeatures
);
3251 if (!NILP (Vautoload_queue
))
3252 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3253 tem
= Fmemq (feature
, Vfeatures
);
3255 Vfeatures
= Fcons (feature
, Vfeatures
);
3256 if (!NILP (subfeatures
))
3257 Fput (feature
, Qsubfeatures
, subfeatures
);
3258 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3260 /* Run any load-hooks for this file. */
3261 tem
= Fassq (feature
, Vafter_load_alist
);
3263 Fprogn (XCDR (tem
));
3268 /* `require' and its subroutines. */
3270 /* List of features currently being require'd, innermost first. */
3272 Lisp_Object require_nesting_list
;
3275 require_unwind (old_value
)
3276 Lisp_Object old_value
;
3278 return require_nesting_list
= old_value
;
3281 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3282 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3283 If FEATURE is not a member of the list `features', then the feature
3284 is not loaded; so load the file FILENAME.
3285 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3286 and `load' will try to load this name appended with the suffix `.elc',
3287 `.el' or the unmodified name, in that order.
3288 If the optional third argument NOERROR is non-nil,
3289 then return nil if the file is not found instead of signaling an error.
3290 Normally the return value is FEATURE.
3291 The normal messages at start and end of loading FILENAME are suppressed. */)
3292 (feature
, filename
, noerror
)
3293 Lisp_Object feature
, filename
, noerror
;
3295 register Lisp_Object tem
;
3296 struct gcpro gcpro1
, gcpro2
;
3298 CHECK_SYMBOL (feature
);
3300 tem
= Fmemq (feature
, Vfeatures
);
3304 int count
= SPECPDL_INDEX ();
3307 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3309 /* This is to make sure that loadup.el gives a clear picture
3310 of what files are preloaded and when. */
3311 if (! NILP (Vpurify_flag
))
3312 error ("(require %s) while preparing to dump",
3313 SDATA (SYMBOL_NAME (feature
)));
3315 /* A certain amount of recursive `require' is legitimate,
3316 but if we require the same feature recursively 3 times,
3318 tem
= require_nesting_list
;
3319 while (! NILP (tem
))
3321 if (! NILP (Fequal (feature
, XCAR (tem
))))
3326 error ("Recursive `require' for feature `%s'",
3327 SDATA (SYMBOL_NAME (feature
)));
3329 /* Update the list for any nested `require's that occur. */
3330 record_unwind_protect (require_unwind
, require_nesting_list
);
3331 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3333 /* Value saved here is to be restored into Vautoload_queue */
3334 record_unwind_protect (un_autoload
, Vautoload_queue
);
3335 Vautoload_queue
= Qt
;
3337 /* Load the file. */
3338 GCPRO2 (feature
, filename
);
3339 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3340 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3343 /* If load failed entirely, return nil. */
3345 return unbind_to (count
, Qnil
);
3347 tem
= Fmemq (feature
, Vfeatures
);
3349 error ("Required feature `%s' was not provided",
3350 SDATA (SYMBOL_NAME (feature
)));
3352 /* Once loading finishes, don't undo it. */
3353 Vautoload_queue
= Qt
;
3354 feature
= unbind_to (count
, feature
);
3360 /* Primitives for work of the "widget" library.
3361 In an ideal world, this section would not have been necessary.
3362 However, lisp function calls being as slow as they are, it turns
3363 out that some functions in the widget library (wid-edit.el) are the
3364 bottleneck of Widget operation. Here is their translation to C,
3365 for the sole reason of efficiency. */
3367 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3368 doc
: /* Return non-nil if PLIST has the property PROP.
3369 PLIST is a property list, which is a list of the form
3370 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3371 Unlike `plist-get', this allows you to distinguish between a missing
3372 property and a property with the value nil.
3373 The value is actually the tail of PLIST whose car is PROP. */)
3375 Lisp_Object plist
, prop
;
3377 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3380 plist
= XCDR (plist
);
3381 plist
= CDR (plist
);
3386 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3387 doc
: /* In WIDGET, set PROPERTY to VALUE.
3388 The value can later be retrieved with `widget-get'. */)
3389 (widget
, property
, value
)
3390 Lisp_Object widget
, property
, value
;
3392 CHECK_CONS (widget
);
3393 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3397 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3398 doc
: /* In WIDGET, get the value of PROPERTY.
3399 The value could either be specified when the widget was created, or
3400 later with `widget-put'. */)
3402 Lisp_Object widget
, property
;
3410 CHECK_CONS (widget
);
3411 tmp
= Fplist_member (XCDR (widget
), property
);
3417 tmp
= XCAR (widget
);
3420 widget
= Fget (tmp
, Qwidget_type
);
3424 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3425 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3426 ARGS are passed as extra arguments to the function.
3427 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3432 /* This function can GC. */
3433 Lisp_Object newargs
[3];
3434 struct gcpro gcpro1
, gcpro2
;
3437 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3438 newargs
[1] = args
[0];
3439 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3440 GCPRO2 (newargs
[0], newargs
[2]);
3441 result
= Fapply (3, newargs
);
3446 #ifdef HAVE_LANGINFO_CODESET
3447 #include <langinfo.h>
3450 DEFUN ("langinfo", Flanginfo
, Slanginfo
, 1, 1, 0,
3451 doc
: /* Access locale category ITEM, if available.
3453 ITEM may be one of the following:
3454 `codeset', returning the character set as a string (CODESET);
3455 `days', returning a 7-element vector of day names (DAY_n);
3456 `months', returning a 12-element vector of month names (MON_n).
3458 If the system can't provide such information through a call to
3459 nl_langinfo(3), return nil.
3461 The data read from the system are decoded using `locale-coding-system'. */)
3466 #ifdef HAVE_LANGINFO_CODESET
3468 if (EQ (item
, Qcodeset
))
3470 str
= nl_langinfo (CODESET
);
3471 return build_string (str
);
3474 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3476 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3477 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3479 synchronize_system_time_locale ();
3480 for (i
= 0; i
< 7; i
++)
3482 str
= nl_langinfo (days
[i
]);
3483 val
= make_unibyte_string (str
, strlen (str
));
3484 /* Fixme: Is this coding system necessarily right, even if
3485 it is consistent with CODESET? If not, what to do? */
3486 Faset (v
, make_number (i
),
3487 code_convert_string_norecord (val
, Vlocale_coding_system
,
3494 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3496 struct Lisp_Vector
*p
= allocate_vector (12);
3497 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3498 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3500 synchronize_system_time_locale ();
3501 for (i
= 0; i
< 12; i
++)
3503 str
= nl_langinfo (months
[i
]);
3504 val
= make_unibyte_string (str
, strlen (str
));
3506 code_convert_string_norecord (val
, Vlocale_coding_system
, Qnil
);
3508 XSETVECTOR (val
, p
);
3512 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3513 but is in the locale files. This could be used by ps-print. */
3515 else if (EQ (item
, Qpaper
))
3517 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3518 make_number (nl_langinfo (PAPER_HEIGHT
)));
3520 #endif /* PAPER_WIDTH */
3521 #endif /* HAVE_LANGINFO_CODESET*/
3525 /* base64 encode/decode functions (RFC 2045).
3526 Based on code from GNU recode. */
3528 #define MIME_LINE_LENGTH 76
3530 #define IS_ASCII(Character) \
3532 #define IS_BASE64(Character) \
3533 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3534 #define IS_BASE64_IGNORABLE(Character) \
3535 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3536 || (Character) == '\f' || (Character) == '\r')
3538 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3539 character or return retval if there are no characters left to
3541 #define READ_QUADRUPLET_BYTE(retval) \
3546 if (nchars_return) \
3547 *nchars_return = nchars; \
3552 while (IS_BASE64_IGNORABLE (c))
3554 /* Don't use alloca for regions larger than this, lest we overflow
3556 #define MAX_ALLOCA 16*1024
3558 /* Table of characters coding the 64 values. */
3559 static char base64_value_to_char
[64] =
3561 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3562 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3563 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3564 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3565 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3566 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3567 '8', '9', '+', '/' /* 60-63 */
3570 /* Table of base64 values for first 128 characters. */
3571 static short base64_char_to_value
[128] =
3573 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3574 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3575 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3576 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3577 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3578 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3579 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3580 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3581 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3582 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3583 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3584 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3585 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3588 /* The following diagram shows the logical steps by which three octets
3589 get transformed into four base64 characters.
3591 .--------. .--------. .--------.
3592 |aaaaaabb| |bbbbcccc| |ccdddddd|
3593 `--------' `--------' `--------'
3595 .--------+--------+--------+--------.
3596 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3597 `--------+--------+--------+--------'
3599 .--------+--------+--------+--------.
3600 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3601 `--------+--------+--------+--------'
3603 The octets are divided into 6 bit chunks, which are then encoded into
3604 base64 characters. */
3607 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3608 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3610 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3612 doc
: /* Base64-encode the region between BEG and END.
3613 Return the length of the encoded text.
3614 Optional third argument NO-LINE-BREAK means do not break long lines
3615 into shorter lines. */)
3616 (beg
, end
, no_line_break
)
3617 Lisp_Object beg
, end
, no_line_break
;
3620 int allength
, length
;
3621 int ibeg
, iend
, encoded_length
;
3624 validate_region (&beg
, &end
);
3626 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3627 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3628 move_gap_both (XFASTINT (beg
), ibeg
);
3630 /* We need to allocate enough room for encoding the text.
3631 We need 33 1/3% more space, plus a newline every 76
3632 characters, and then we round up. */
3633 length
= iend
- ibeg
;
3634 allength
= length
+ length
/3 + 1;
3635 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3637 if (allength
<= MAX_ALLOCA
)
3638 encoded
= (char *) alloca (allength
);
3640 encoded
= (char *) xmalloc (allength
);
3641 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3642 NILP (no_line_break
),
3643 !NILP (current_buffer
->enable_multibyte_characters
));
3644 if (encoded_length
> allength
)
3647 if (encoded_length
< 0)
3649 /* The encoding wasn't possible. */
3650 if (length
> MAX_ALLOCA
)
3652 error ("Multibyte character in data for base64 encoding");
3655 /* Now we have encoded the region, so we insert the new contents
3656 and delete the old. (Insert first in order to preserve markers.) */
3657 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3658 insert (encoded
, encoded_length
);
3659 if (allength
> MAX_ALLOCA
)
3661 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3663 /* If point was outside of the region, restore it exactly; else just
3664 move to the beginning of the region. */
3665 if (old_pos
>= XFASTINT (end
))
3666 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3667 else if (old_pos
> XFASTINT (beg
))
3668 old_pos
= XFASTINT (beg
);
3671 /* We return the length of the encoded text. */
3672 return make_number (encoded_length
);
3675 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3677 doc
: /* Base64-encode STRING and return the result.
3678 Optional second argument NO-LINE-BREAK means do not break long lines
3679 into shorter lines. */)
3680 (string
, no_line_break
)
3681 Lisp_Object string
, no_line_break
;
3683 int allength
, length
, encoded_length
;
3685 Lisp_Object encoded_string
;
3687 CHECK_STRING (string
);
3689 /* We need to allocate enough room for encoding the text.
3690 We need 33 1/3% more space, plus a newline every 76
3691 characters, and then we round up. */
3692 length
= SBYTES (string
);
3693 allength
= length
+ length
/3 + 1;
3694 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3696 /* We need to allocate enough room for decoding the text. */
3697 if (allength
<= MAX_ALLOCA
)
3698 encoded
= (char *) alloca (allength
);
3700 encoded
= (char *) xmalloc (allength
);
3702 encoded_length
= base64_encode_1 (SDATA (string
),
3703 encoded
, length
, NILP (no_line_break
),
3704 STRING_MULTIBYTE (string
));
3705 if (encoded_length
> allength
)
3708 if (encoded_length
< 0)
3710 /* The encoding wasn't possible. */
3711 if (length
> MAX_ALLOCA
)
3713 error ("Multibyte character in data for base64 encoding");
3716 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3717 if (allength
> MAX_ALLOCA
)
3720 return encoded_string
;
3724 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3731 int counter
= 0, i
= 0;
3741 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3749 /* Wrap line every 76 characters. */
3753 if (counter
< MIME_LINE_LENGTH
/ 4)
3762 /* Process first byte of a triplet. */
3764 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3765 value
= (0x03 & c
) << 4;
3767 /* Process second byte of a triplet. */
3771 *e
++ = base64_value_to_char
[value
];
3779 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3787 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3788 value
= (0x0f & c
) << 2;
3790 /* Process third byte of a triplet. */
3794 *e
++ = base64_value_to_char
[value
];
3801 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3809 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3810 *e
++ = base64_value_to_char
[0x3f & c
];
3817 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3819 doc
: /* Base64-decode the region between BEG and END.
3820 Return the length of the decoded text.
3821 If the region can't be decoded, signal an error and don't modify the buffer. */)
3823 Lisp_Object beg
, end
;
3825 int ibeg
, iend
, length
, allength
;
3830 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3832 validate_region (&beg
, &end
);
3834 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3835 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3837 length
= iend
- ibeg
;
3839 /* We need to allocate enough room for decoding the text. If we are
3840 working on a multibyte buffer, each decoded code may occupy at
3842 allength
= multibyte
? length
* 2 : length
;
3843 if (allength
<= MAX_ALLOCA
)
3844 decoded
= (char *) alloca (allength
);
3846 decoded
= (char *) xmalloc (allength
);
3848 move_gap_both (XFASTINT (beg
), ibeg
);
3849 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3850 multibyte
, &inserted_chars
);
3851 if (decoded_length
> allength
)
3854 if (decoded_length
< 0)
3856 /* The decoding wasn't possible. */
3857 if (allength
> MAX_ALLOCA
)
3859 error ("Invalid base64 data");
3862 /* Now we have decoded the region, so we insert the new contents
3863 and delete the old. (Insert first in order to preserve markers.) */
3864 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3865 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3866 if (allength
> MAX_ALLOCA
)
3868 /* Delete the original text. */
3869 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3870 iend
+ decoded_length
, 1);
3872 /* If point was outside of the region, restore it exactly; else just
3873 move to the beginning of the region. */
3874 if (old_pos
>= XFASTINT (end
))
3875 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3876 else if (old_pos
> XFASTINT (beg
))
3877 old_pos
= XFASTINT (beg
);
3878 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3880 return make_number (inserted_chars
);
3883 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3885 doc
: /* Base64-decode STRING and return the result. */)
3890 int length
, decoded_length
;
3891 Lisp_Object decoded_string
;
3893 CHECK_STRING (string
);
3895 length
= SBYTES (string
);
3896 /* We need to allocate enough room for decoding the text. */
3897 if (length
<= MAX_ALLOCA
)
3898 decoded
= (char *) alloca (length
);
3900 decoded
= (char *) xmalloc (length
);
3902 /* The decoded result should be unibyte. */
3903 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3905 if (decoded_length
> length
)
3907 else if (decoded_length
>= 0)
3908 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3910 decoded_string
= Qnil
;
3912 if (length
> MAX_ALLOCA
)
3914 if (!STRINGP (decoded_string
))
3915 error ("Invalid base64 data");
3917 return decoded_string
;
3920 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3921 MULTIBYTE is nonzero, the decoded result should be in multibyte
3922 form. If NCHARS_RETRUN is not NULL, store the number of produced
3923 characters in *NCHARS_RETURN. */
3926 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3936 unsigned long value
;
3941 /* Process first byte of a quadruplet. */
3943 READ_QUADRUPLET_BYTE (e
-to
);
3947 value
= base64_char_to_value
[c
] << 18;
3949 /* Process second byte of a quadruplet. */
3951 READ_QUADRUPLET_BYTE (-1);
3955 value
|= base64_char_to_value
[c
] << 12;
3957 c
= (unsigned char) (value
>> 16);
3959 e
+= CHAR_STRING (c
, e
);
3964 /* Process third byte of a quadruplet. */
3966 READ_QUADRUPLET_BYTE (-1);
3970 READ_QUADRUPLET_BYTE (-1);
3979 value
|= base64_char_to_value
[c
] << 6;
3981 c
= (unsigned char) (0xff & value
>> 8);
3983 e
+= CHAR_STRING (c
, e
);
3988 /* Process fourth byte of a quadruplet. */
3990 READ_QUADRUPLET_BYTE (-1);
3997 value
|= base64_char_to_value
[c
];
3999 c
= (unsigned char) (0xff & value
);
4001 e
+= CHAR_STRING (c
, e
);
4010 /***********************************************************************
4012 ***** Hash Tables *****
4014 ***********************************************************************/
4016 /* Implemented by gerd@gnu.org. This hash table implementation was
4017 inspired by CMUCL hash tables. */
4021 1. For small tables, association lists are probably faster than
4022 hash tables because they have lower overhead.
4024 For uses of hash tables where the O(1) behavior of table
4025 operations is not a requirement, it might therefore be a good idea
4026 not to hash. Instead, we could just do a linear search in the
4027 key_and_value vector of the hash table. This could be done
4028 if a `:linear-search t' argument is given to make-hash-table. */
4031 /* The list of all weak hash tables. Don't staticpro this one. */
4033 Lisp_Object Vweak_hash_tables
;
4035 /* Various symbols. */
4037 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4038 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4039 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4041 /* Function prototypes. */
4043 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4044 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4045 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4046 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4047 Lisp_Object
, unsigned));
4048 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4049 Lisp_Object
, unsigned));
4050 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4051 unsigned, Lisp_Object
, unsigned));
4052 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4053 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4054 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4055 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4057 static unsigned sxhash_string
P_ ((unsigned char *, int));
4058 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4059 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4060 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4061 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4065 /***********************************************************************
4067 ***********************************************************************/
4069 /* If OBJ is a Lisp hash table, return a pointer to its struct
4070 Lisp_Hash_Table. Otherwise, signal an error. */
4072 static struct Lisp_Hash_Table
*
4073 check_hash_table (obj
)
4076 CHECK_HASH_TABLE (obj
);
4077 return XHASH_TABLE (obj
);
4081 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4085 next_almost_prime (n
)
4098 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4099 which USED[I] is non-zero. If found at index I in ARGS, set
4100 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4101 -1. This function is used to extract a keyword/argument pair from
4102 a DEFUN parameter list. */
4105 get_key_arg (key
, nargs
, args
, used
)
4113 for (i
= 0; i
< nargs
- 1; ++i
)
4114 if (!used
[i
] && EQ (args
[i
], key
))
4129 /* Return a Lisp vector which has the same contents as VEC but has
4130 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4131 vector that are not copied from VEC are set to INIT. */
4134 larger_vector (vec
, new_size
, init
)
4139 struct Lisp_Vector
*v
;
4142 xassert (VECTORP (vec
));
4143 old_size
= XVECTOR (vec
)->size
;
4144 xassert (new_size
>= old_size
);
4146 v
= allocate_vector (new_size
);
4147 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4148 old_size
* sizeof *v
->contents
);
4149 for (i
= old_size
; i
< new_size
; ++i
)
4150 v
->contents
[i
] = init
;
4151 XSETVECTOR (vec
, v
);
4156 /***********************************************************************
4158 ***********************************************************************/
4160 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4161 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4162 KEY2 are the same. */
4165 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4166 struct Lisp_Hash_Table
*h
;
4167 Lisp_Object key1
, key2
;
4168 unsigned hash1
, hash2
;
4170 return (FLOATP (key1
)
4172 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4176 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4177 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4178 KEY2 are the same. */
4181 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4182 struct Lisp_Hash_Table
*h
;
4183 Lisp_Object key1
, key2
;
4184 unsigned hash1
, hash2
;
4186 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4190 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4191 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4192 if KEY1 and KEY2 are the same. */
4195 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4196 struct Lisp_Hash_Table
*h
;
4197 Lisp_Object key1
, key2
;
4198 unsigned hash1
, hash2
;
4202 Lisp_Object args
[3];
4204 args
[0] = h
->user_cmp_function
;
4207 return !NILP (Ffuncall (3, args
));
4214 /* Value is a hash code for KEY for use in hash table H which uses
4215 `eq' to compare keys. The hash code returned is guaranteed to fit
4216 in a Lisp integer. */
4220 struct Lisp_Hash_Table
*h
;
4223 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4224 xassert ((hash
& ~VALMASK
) == 0);
4229 /* Value is a hash code for KEY for use in hash table H which uses
4230 `eql' to compare keys. The hash code returned is guaranteed to fit
4231 in a Lisp integer. */
4235 struct Lisp_Hash_Table
*h
;
4240 hash
= sxhash (key
, 0);
4242 hash
= XUINT (key
) ^ XGCTYPE (key
);
4243 xassert ((hash
& ~VALMASK
) == 0);
4248 /* Value is a hash code for KEY for use in hash table H which uses
4249 `equal' to compare keys. The hash code returned is guaranteed to fit
4250 in a Lisp integer. */
4253 hashfn_equal (h
, key
)
4254 struct Lisp_Hash_Table
*h
;
4257 unsigned hash
= sxhash (key
, 0);
4258 xassert ((hash
& ~VALMASK
) == 0);
4263 /* Value is a hash code for KEY for use in hash table H which uses as
4264 user-defined function to compare keys. The hash code returned is
4265 guaranteed to fit in a Lisp integer. */
4268 hashfn_user_defined (h
, key
)
4269 struct Lisp_Hash_Table
*h
;
4272 Lisp_Object args
[2], hash
;
4274 args
[0] = h
->user_hash_function
;
4276 hash
= Ffuncall (2, args
);
4277 if (!INTEGERP (hash
))
4279 list2 (build_string ("Invalid hash code returned from \
4280 user-supplied hash function"),
4282 return XUINT (hash
);
4286 /* Create and initialize a new hash table.
4288 TEST specifies the test the hash table will use to compare keys.
4289 It must be either one of the predefined tests `eq', `eql' or
4290 `equal' or a symbol denoting a user-defined test named TEST with
4291 test and hash functions USER_TEST and USER_HASH.
4293 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4295 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4296 new size when it becomes full is computed by adding REHASH_SIZE to
4297 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4298 table's new size is computed by multiplying its old size with
4301 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4302 be resized when the ratio of (number of entries in the table) /
4303 (table size) is >= REHASH_THRESHOLD.
4305 WEAK specifies the weakness of the table. If non-nil, it must be
4306 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4309 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4310 user_test
, user_hash
)
4311 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4312 Lisp_Object user_test
, user_hash
;
4314 struct Lisp_Hash_Table
*h
;
4316 int index_size
, i
, sz
;
4318 /* Preconditions. */
4319 xassert (SYMBOLP (test
));
4320 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4321 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4322 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4323 xassert (FLOATP (rehash_threshold
)
4324 && XFLOATINT (rehash_threshold
) > 0
4325 && XFLOATINT (rehash_threshold
) <= 1.0);
4327 if (XFASTINT (size
) == 0)
4328 size
= make_number (1);
4330 /* Allocate a table and initialize it. */
4331 h
= allocate_hash_table ();
4333 /* Initialize hash table slots. */
4334 sz
= XFASTINT (size
);
4337 if (EQ (test
, Qeql
))
4339 h
->cmpfn
= cmpfn_eql
;
4340 h
->hashfn
= hashfn_eql
;
4342 else if (EQ (test
, Qeq
))
4345 h
->hashfn
= hashfn_eq
;
4347 else if (EQ (test
, Qequal
))
4349 h
->cmpfn
= cmpfn_equal
;
4350 h
->hashfn
= hashfn_equal
;
4354 h
->user_cmp_function
= user_test
;
4355 h
->user_hash_function
= user_hash
;
4356 h
->cmpfn
= cmpfn_user_defined
;
4357 h
->hashfn
= hashfn_user_defined
;
4361 h
->rehash_threshold
= rehash_threshold
;
4362 h
->rehash_size
= rehash_size
;
4363 h
->count
= make_number (0);
4364 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4365 h
->hash
= Fmake_vector (size
, Qnil
);
4366 h
->next
= Fmake_vector (size
, Qnil
);
4367 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4368 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4369 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4371 /* Set up the free list. */
4372 for (i
= 0; i
< sz
- 1; ++i
)
4373 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4374 h
->next_free
= make_number (0);
4376 XSET_HASH_TABLE (table
, h
);
4377 xassert (HASH_TABLE_P (table
));
4378 xassert (XHASH_TABLE (table
) == h
);
4380 /* Maybe add this hash table to the list of all weak hash tables. */
4382 h
->next_weak
= Qnil
;
4385 h
->next_weak
= Vweak_hash_tables
;
4386 Vweak_hash_tables
= table
;
4393 /* Return a copy of hash table H1. Keys and values are not copied,
4394 only the table itself is. */
4397 copy_hash_table (h1
)
4398 struct Lisp_Hash_Table
*h1
;
4401 struct Lisp_Hash_Table
*h2
;
4402 struct Lisp_Vector
*next
;
4404 h2
= allocate_hash_table ();
4405 next
= h2
->vec_next
;
4406 bcopy (h1
, h2
, sizeof *h2
);
4407 h2
->vec_next
= next
;
4408 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4409 h2
->hash
= Fcopy_sequence (h1
->hash
);
4410 h2
->next
= Fcopy_sequence (h1
->next
);
4411 h2
->index
= Fcopy_sequence (h1
->index
);
4412 XSET_HASH_TABLE (table
, h2
);
4414 /* Maybe add this hash table to the list of all weak hash tables. */
4415 if (!NILP (h2
->weak
))
4417 h2
->next_weak
= Vweak_hash_tables
;
4418 Vweak_hash_tables
= table
;
4425 /* Resize hash table H if it's too full. If H cannot be resized
4426 because it's already too large, throw an error. */
4429 maybe_resize_hash_table (h
)
4430 struct Lisp_Hash_Table
*h
;
4432 if (NILP (h
->next_free
))
4434 int old_size
= HASH_TABLE_SIZE (h
);
4435 int i
, new_size
, index_size
;
4437 if (INTEGERP (h
->rehash_size
))
4438 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4440 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4441 new_size
= max (old_size
+ 1, new_size
);
4442 index_size
= next_almost_prime ((int)
4444 / XFLOATINT (h
->rehash_threshold
)));
4445 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4446 error ("Hash table too large to resize");
4448 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4449 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4450 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4451 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4453 /* Update the free list. Do it so that new entries are added at
4454 the end of the free list. This makes some operations like
4456 for (i
= old_size
; i
< new_size
- 1; ++i
)
4457 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4459 if (!NILP (h
->next_free
))
4461 Lisp_Object last
, next
;
4463 last
= h
->next_free
;
4464 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4468 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4471 XSETFASTINT (h
->next_free
, old_size
);
4474 for (i
= 0; i
< old_size
; ++i
)
4475 if (!NILP (HASH_HASH (h
, i
)))
4477 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4478 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4479 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4480 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4486 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4487 the hash code of KEY. Value is the index of the entry in H
4488 matching KEY, or -1 if not found. */
4491 hash_lookup (h
, key
, hash
)
4492 struct Lisp_Hash_Table
*h
;
4497 int start_of_bucket
;
4500 hash_code
= h
->hashfn (h
, key
);
4504 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4505 idx
= HASH_INDEX (h
, start_of_bucket
);
4507 /* We need not gcpro idx since it's either an integer or nil. */
4510 int i
= XFASTINT (idx
);
4511 if (EQ (key
, HASH_KEY (h
, i
))
4513 && h
->cmpfn (h
, key
, hash_code
,
4514 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4516 idx
= HASH_NEXT (h
, i
);
4519 return NILP (idx
) ? -1 : XFASTINT (idx
);
4523 /* Put an entry into hash table H that associates KEY with VALUE.
4524 HASH is a previously computed hash code of KEY.
4525 Value is the index of the entry in H matching KEY. */
4528 hash_put (h
, key
, value
, hash
)
4529 struct Lisp_Hash_Table
*h
;
4530 Lisp_Object key
, value
;
4533 int start_of_bucket
, i
;
4535 xassert ((hash
& ~VALMASK
) == 0);
4537 /* Increment count after resizing because resizing may fail. */
4538 maybe_resize_hash_table (h
);
4539 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4541 /* Store key/value in the key_and_value vector. */
4542 i
= XFASTINT (h
->next_free
);
4543 h
->next_free
= HASH_NEXT (h
, i
);
4544 HASH_KEY (h
, i
) = key
;
4545 HASH_VALUE (h
, i
) = value
;
4547 /* Remember its hash code. */
4548 HASH_HASH (h
, i
) = make_number (hash
);
4550 /* Add new entry to its collision chain. */
4551 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4552 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4553 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4558 /* Remove the entry matching KEY from hash table H, if there is one. */
4561 hash_remove (h
, key
)
4562 struct Lisp_Hash_Table
*h
;
4566 int start_of_bucket
;
4567 Lisp_Object idx
, prev
;
4569 hash_code
= h
->hashfn (h
, key
);
4570 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4571 idx
= HASH_INDEX (h
, start_of_bucket
);
4574 /* We need not gcpro idx, prev since they're either integers or nil. */
4577 int i
= XFASTINT (idx
);
4579 if (EQ (key
, HASH_KEY (h
, i
))
4581 && h
->cmpfn (h
, key
, hash_code
,
4582 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4584 /* Take entry out of collision chain. */
4586 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4588 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4590 /* Clear slots in key_and_value and add the slots to
4592 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4593 HASH_NEXT (h
, i
) = h
->next_free
;
4594 h
->next_free
= make_number (i
);
4595 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4596 xassert (XINT (h
->count
) >= 0);
4602 idx
= HASH_NEXT (h
, i
);
4608 /* Clear hash table H. */
4612 struct Lisp_Hash_Table
*h
;
4614 if (XFASTINT (h
->count
) > 0)
4616 int i
, size
= HASH_TABLE_SIZE (h
);
4618 for (i
= 0; i
< size
; ++i
)
4620 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4621 HASH_KEY (h
, i
) = Qnil
;
4622 HASH_VALUE (h
, i
) = Qnil
;
4623 HASH_HASH (h
, i
) = Qnil
;
4626 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4627 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4629 h
->next_free
= make_number (0);
4630 h
->count
= make_number (0);
4636 /************************************************************************
4638 ************************************************************************/
4640 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4641 entries from the table that don't survive the current GC.
4642 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4643 non-zero if anything was marked. */
4646 sweep_weak_table (h
, remove_entries_p
)
4647 struct Lisp_Hash_Table
*h
;
4648 int remove_entries_p
;
4650 int bucket
, n
, marked
;
4652 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4655 for (bucket
= 0; bucket
< n
; ++bucket
)
4657 Lisp_Object idx
, next
, prev
;
4659 /* Follow collision chain, removing entries that
4660 don't survive this garbage collection. */
4662 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4664 int i
= XFASTINT (idx
);
4665 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4666 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4669 if (EQ (h
->weak
, Qkey
))
4670 remove_p
= !key_known_to_survive_p
;
4671 else if (EQ (h
->weak
, Qvalue
))
4672 remove_p
= !value_known_to_survive_p
;
4673 else if (EQ (h
->weak
, Qkey_or_value
))
4674 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4675 else if (EQ (h
->weak
, Qkey_and_value
))
4676 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4680 next
= HASH_NEXT (h
, i
);
4682 if (remove_entries_p
)
4686 /* Take out of collision chain. */
4688 HASH_INDEX (h
, bucket
) = next
;
4690 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4692 /* Add to free list. */
4693 HASH_NEXT (h
, i
) = h
->next_free
;
4696 /* Clear key, value, and hash. */
4697 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4698 HASH_HASH (h
, i
) = Qnil
;
4700 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4707 /* Make sure key and value survive. */
4708 if (!key_known_to_survive_p
)
4710 mark_object (&HASH_KEY (h
, i
));
4714 if (!value_known_to_survive_p
)
4716 mark_object (&HASH_VALUE (h
, i
));
4727 /* Remove elements from weak hash tables that don't survive the
4728 current garbage collection. Remove weak tables that don't survive
4729 from Vweak_hash_tables. Called from gc_sweep. */
4732 sweep_weak_hash_tables ()
4734 Lisp_Object table
, used
, next
;
4735 struct Lisp_Hash_Table
*h
;
4738 /* Mark all keys and values that are in use. Keep on marking until
4739 there is no more change. This is necessary for cases like
4740 value-weak table A containing an entry X -> Y, where Y is used in a
4741 key-weak table B, Z -> Y. If B comes after A in the list of weak
4742 tables, X -> Y might be removed from A, although when looking at B
4743 one finds that it shouldn't. */
4747 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4749 h
= XHASH_TABLE (table
);
4750 if (h
->size
& ARRAY_MARK_FLAG
)
4751 marked
|= sweep_weak_table (h
, 0);
4756 /* Remove tables and entries that aren't used. */
4757 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4759 h
= XHASH_TABLE (table
);
4760 next
= h
->next_weak
;
4762 if (h
->size
& ARRAY_MARK_FLAG
)
4764 /* TABLE is marked as used. Sweep its contents. */
4765 if (XFASTINT (h
->count
) > 0)
4766 sweep_weak_table (h
, 1);
4768 /* Add table to the list of used weak hash tables. */
4769 h
->next_weak
= used
;
4774 Vweak_hash_tables
= used
;
4779 /***********************************************************************
4780 Hash Code Computation
4781 ***********************************************************************/
4783 /* Maximum depth up to which to dive into Lisp structures. */
4785 #define SXHASH_MAX_DEPTH 3
4787 /* Maximum length up to which to take list and vector elements into
4790 #define SXHASH_MAX_LEN 7
4792 /* Combine two integers X and Y for hashing. */
4794 #define SXHASH_COMBINE(X, Y) \
4795 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4799 /* Return a hash for string PTR which has length LEN. The hash
4800 code returned is guaranteed to fit in a Lisp integer. */
4803 sxhash_string (ptr
, len
)
4807 unsigned char *p
= ptr
;
4808 unsigned char *end
= p
+ len
;
4817 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4820 return hash
& VALMASK
;
4824 /* Return a hash for list LIST. DEPTH is the current depth in the
4825 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4828 sxhash_list (list
, depth
)
4835 if (depth
< SXHASH_MAX_DEPTH
)
4837 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4838 list
= XCDR (list
), ++i
)
4840 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4841 hash
= SXHASH_COMBINE (hash
, hash2
);
4848 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4849 the Lisp structure. */
4852 sxhash_vector (vec
, depth
)
4856 unsigned hash
= XVECTOR (vec
)->size
;
4859 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4860 for (i
= 0; i
< n
; ++i
)
4862 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4863 hash
= SXHASH_COMBINE (hash
, hash2
);
4870 /* Return a hash for bool-vector VECTOR. */
4873 sxhash_bool_vector (vec
)
4876 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4879 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4880 for (i
= 0; i
< n
; ++i
)
4881 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4887 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4888 structure. Value is an unsigned integer clipped to VALMASK. */
4897 if (depth
> SXHASH_MAX_DEPTH
)
4900 switch (XTYPE (obj
))
4907 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4908 SCHARS (SYMBOL_NAME (obj
)));
4916 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4919 /* This can be everything from a vector to an overlay. */
4920 case Lisp_Vectorlike
:
4922 /* According to the CL HyperSpec, two arrays are equal only if
4923 they are `eq', except for strings and bit-vectors. In
4924 Emacs, this works differently. We have to compare element
4926 hash
= sxhash_vector (obj
, depth
);
4927 else if (BOOL_VECTOR_P (obj
))
4928 hash
= sxhash_bool_vector (obj
);
4930 /* Others are `equal' if they are `eq', so let's take their
4936 hash
= sxhash_list (obj
, depth
);
4941 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4942 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4943 for (hash
= 0; p
< e
; ++p
)
4944 hash
= SXHASH_COMBINE (hash
, *p
);
4952 return hash
& VALMASK
;
4957 /***********************************************************************
4959 ***********************************************************************/
4962 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4963 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4967 unsigned hash
= sxhash (obj
, 0);;
4968 return make_number (hash
);
4972 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4973 doc
: /* Create and return a new hash table.
4975 Arguments are specified as keyword/argument pairs. The following
4976 arguments are defined:
4978 :test TEST -- TEST must be a symbol that specifies how to compare
4979 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4980 `equal'. User-supplied test and hash functions can be specified via
4981 `define-hash-table-test'.
4983 :size SIZE -- A hint as to how many elements will be put in the table.
4986 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4987 fills up. If REHASH-SIZE is an integer, add that many space. If it
4988 is a float, it must be > 1.0, and the new size is computed by
4989 multiplying the old size with that factor. Default is 1.5.
4991 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4992 Resize the hash table when ratio of the number of entries in the
4993 table. Default is 0.8.
4995 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4996 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4997 returned is a weak table. Key/value pairs are removed from a weak
4998 hash table when there are no non-weak references pointing to their
4999 key, value, one of key or value, or both key and value, depending on
5000 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5003 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5008 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5009 Lisp_Object user_test
, user_hash
;
5013 /* The vector `used' is used to keep track of arguments that
5014 have been consumed. */
5015 used
= (char *) alloca (nargs
* sizeof *used
);
5016 bzero (used
, nargs
* sizeof *used
);
5018 /* See if there's a `:test TEST' among the arguments. */
5019 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5020 test
= i
< 0 ? Qeql
: args
[i
];
5021 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5023 /* See if it is a user-defined test. */
5026 prop
= Fget (test
, Qhash_table_test
);
5027 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5028 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5030 user_test
= XCAR (prop
);
5031 user_hash
= XCAR (XCDR (prop
));
5034 user_test
= user_hash
= Qnil
;
5036 /* See if there's a `:size SIZE' argument. */
5037 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5038 size
= i
< 0 ? Qnil
: args
[i
];
5040 size
= make_number (DEFAULT_HASH_SIZE
);
5041 else if (!INTEGERP (size
) || XINT (size
) < 0)
5043 list2 (build_string ("Invalid hash table size"),
5046 /* Look for `:rehash-size SIZE'. */
5047 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5048 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5049 if (!NUMBERP (rehash_size
)
5050 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5051 || XFLOATINT (rehash_size
) <= 1.0)
5053 list2 (build_string ("Invalid hash table rehash size"),
5056 /* Look for `:rehash-threshold THRESHOLD'. */
5057 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5058 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5059 if (!FLOATP (rehash_threshold
)
5060 || XFLOATINT (rehash_threshold
) <= 0.0
5061 || XFLOATINT (rehash_threshold
) > 1.0)
5063 list2 (build_string ("Invalid hash table rehash threshold"),
5066 /* Look for `:weakness WEAK'. */
5067 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5068 weak
= i
< 0 ? Qnil
: args
[i
];
5070 weak
= Qkey_and_value
;
5073 && !EQ (weak
, Qvalue
)
5074 && !EQ (weak
, Qkey_or_value
)
5075 && !EQ (weak
, Qkey_and_value
))
5076 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5079 /* Now, all args should have been used up, or there's a problem. */
5080 for (i
= 0; i
< nargs
; ++i
)
5083 list2 (build_string ("Invalid argument list"), args
[i
]));
5085 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5086 user_test
, user_hash
);
5090 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5091 doc
: /* Return a copy of hash table TABLE. */)
5095 return copy_hash_table (check_hash_table (table
));
5099 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5100 doc
: /* Return the number of elements in TABLE. */)
5104 return check_hash_table (table
)->count
;
5108 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5109 Shash_table_rehash_size
, 1, 1, 0,
5110 doc
: /* Return the current rehash size of TABLE. */)
5114 return check_hash_table (table
)->rehash_size
;
5118 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5119 Shash_table_rehash_threshold
, 1, 1, 0,
5120 doc
: /* Return the current rehash threshold of TABLE. */)
5124 return check_hash_table (table
)->rehash_threshold
;
5128 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5129 doc
: /* Return the size of TABLE.
5130 The size can be used as an argument to `make-hash-table' to create
5131 a hash table than can hold as many elements of TABLE holds
5132 without need for resizing. */)
5136 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5137 return make_number (HASH_TABLE_SIZE (h
));
5141 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5142 doc
: /* Return the test TABLE uses. */)
5146 return check_hash_table (table
)->test
;
5150 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5152 doc
: /* Return the weakness of TABLE. */)
5156 return check_hash_table (table
)->weak
;
5160 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5161 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5165 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5169 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5170 doc
: /* Clear hash table TABLE. */)
5174 hash_clear (check_hash_table (table
));
5179 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5180 doc
: /* Look up KEY in TABLE and return its associated value.
5181 If KEY is not found, return DFLT which defaults to nil. */)
5183 Lisp_Object key
, table
, dflt
;
5185 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5186 int i
= hash_lookup (h
, key
, NULL
);
5187 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5191 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5192 doc
: /* Associate KEY with VALUE in hash table TABLE.
5193 If KEY is already present in table, replace its current value with
5196 Lisp_Object key
, value
, table
;
5198 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5202 i
= hash_lookup (h
, key
, &hash
);
5204 HASH_VALUE (h
, i
) = value
;
5206 hash_put (h
, key
, value
, hash
);
5212 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5213 doc
: /* Remove KEY from TABLE. */)
5215 Lisp_Object key
, table
;
5217 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5218 hash_remove (h
, key
);
5223 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5224 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5225 FUNCTION is called with 2 arguments KEY and VALUE. */)
5227 Lisp_Object function
, table
;
5229 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5230 Lisp_Object args
[3];
5233 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5234 if (!NILP (HASH_HASH (h
, i
)))
5237 args
[1] = HASH_KEY (h
, i
);
5238 args
[2] = HASH_VALUE (h
, i
);
5246 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5247 Sdefine_hash_table_test
, 3, 3, 0,
5248 doc
: /* Define a new hash table test with name NAME, a symbol.
5250 In hash tables created with NAME specified as test, use TEST to
5251 compare keys, and HASH for computing hash codes of keys.
5253 TEST must be a function taking two arguments and returning non-nil if
5254 both arguments are the same. HASH must be a function taking one
5255 argument and return an integer that is the hash code of the argument.
5256 Hash code computation should use the whole value range of integers,
5257 including negative integers. */)
5259 Lisp_Object name
, test
, hash
;
5261 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5266 /************************************************************************
5268 ************************************************************************/
5273 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5274 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5276 A message digest is a cryptographic checksum of a document, and the
5277 algorithm to calculate it is defined in RFC 1321.
5279 The two optional arguments START and END are character positions
5280 specifying for which part of OBJECT the message digest should be
5281 computed. If nil or omitted, the digest is computed for the whole
5284 The MD5 message digest is computed from the result of encoding the
5285 text in a coding system, not directly from the internal Emacs form of
5286 the text. The optional fourth argument CODING-SYSTEM specifies which
5287 coding system to encode the text with. It should be the same coding
5288 system that you used or will use when actually writing the text into a
5291 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5292 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5293 system would be chosen by default for writing this text into a file.
5295 If OBJECT is a string, the most preferred coding system (see the
5296 command `prefer-coding-system') is used.
5298 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5299 guesswork fails. Normally, an error is signaled in such case. */)
5300 (object
, start
, end
, coding_system
, noerror
)
5301 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5303 unsigned char digest
[16];
5304 unsigned char value
[33];
5308 int start_char
= 0, end_char
= 0;
5309 int start_byte
= 0, end_byte
= 0;
5311 register struct buffer
*bp
;
5314 if (STRINGP (object
))
5316 if (NILP (coding_system
))
5318 /* Decide the coding-system to encode the data with. */
5320 if (STRING_MULTIBYTE (object
))
5321 /* use default, we can't guess correct value */
5322 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5324 coding_system
= Qraw_text
;
5327 if (NILP (Fcoding_system_p (coding_system
)))
5329 /* Invalid coding system. */
5331 if (!NILP (noerror
))
5332 coding_system
= Qraw_text
;
5335 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5338 if (STRING_MULTIBYTE (object
))
5339 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5341 size
= SCHARS (object
);
5342 size_byte
= SBYTES (object
);
5346 CHECK_NUMBER (start
);
5348 start_char
= XINT (start
);
5353 start_byte
= string_char_to_byte (object
, start_char
);
5359 end_byte
= size_byte
;
5365 end_char
= XINT (end
);
5370 end_byte
= string_char_to_byte (object
, end_char
);
5373 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5374 args_out_of_range_3 (object
, make_number (start_char
),
5375 make_number (end_char
));
5379 CHECK_BUFFER (object
);
5381 bp
= XBUFFER (object
);
5387 CHECK_NUMBER_COERCE_MARKER (start
);
5395 CHECK_NUMBER_COERCE_MARKER (end
);
5400 temp
= b
, b
= e
, e
= temp
;
5402 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5403 args_out_of_range (start
, end
);
5405 if (NILP (coding_system
))
5407 /* Decide the coding-system to encode the data with.
5408 See fileio.c:Fwrite-region */
5410 if (!NILP (Vcoding_system_for_write
))
5411 coding_system
= Vcoding_system_for_write
;
5414 int force_raw_text
= 0;
5416 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5417 if (NILP (coding_system
)
5418 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5420 coding_system
= Qnil
;
5421 if (NILP (current_buffer
->enable_multibyte_characters
))
5425 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5427 /* Check file-coding-system-alist. */
5428 Lisp_Object args
[4], val
;
5430 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5431 args
[3] = Fbuffer_file_name(object
);
5432 val
= Ffind_operation_coding_system (4, args
);
5433 if (CONSP (val
) && !NILP (XCDR (val
)))
5434 coding_system
= XCDR (val
);
5437 if (NILP (coding_system
)
5438 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5440 /* If we still have not decided a coding system, use the
5441 default value of buffer-file-coding-system. */
5442 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5446 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5447 /* Confirm that VAL can surely encode the current region. */
5448 coding_system
= call4 (Vselect_safe_coding_system_function
,
5449 make_number (b
), make_number (e
),
5450 coding_system
, Qnil
);
5453 coding_system
= Qraw_text
;
5456 if (NILP (Fcoding_system_p (coding_system
)))
5458 /* Invalid coding system. */
5460 if (!NILP (noerror
))
5461 coding_system
= Qraw_text
;
5464 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5468 object
= make_buffer_string (b
, e
, 0);
5470 if (STRING_MULTIBYTE (object
))
5471 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5474 md5_buffer (SDATA (object
) + start_byte
,
5475 SBYTES (object
) - (size_byte
- end_byte
),
5478 for (i
= 0; i
< 16; i
++)
5479 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5482 return make_string (value
, 32);
5489 /* Hash table stuff. */
5490 Qhash_table_p
= intern ("hash-table-p");
5491 staticpro (&Qhash_table_p
);
5492 Qeq
= intern ("eq");
5494 Qeql
= intern ("eql");
5496 Qequal
= intern ("equal");
5497 staticpro (&Qequal
);
5498 QCtest
= intern (":test");
5499 staticpro (&QCtest
);
5500 QCsize
= intern (":size");
5501 staticpro (&QCsize
);
5502 QCrehash_size
= intern (":rehash-size");
5503 staticpro (&QCrehash_size
);
5504 QCrehash_threshold
= intern (":rehash-threshold");
5505 staticpro (&QCrehash_threshold
);
5506 QCweakness
= intern (":weakness");
5507 staticpro (&QCweakness
);
5508 Qkey
= intern ("key");
5510 Qvalue
= intern ("value");
5511 staticpro (&Qvalue
);
5512 Qhash_table_test
= intern ("hash-table-test");
5513 staticpro (&Qhash_table_test
);
5514 Qkey_or_value
= intern ("key-or-value");
5515 staticpro (&Qkey_or_value
);
5516 Qkey_and_value
= intern ("key-and-value");
5517 staticpro (&Qkey_and_value
);
5520 defsubr (&Smake_hash_table
);
5521 defsubr (&Scopy_hash_table
);
5522 defsubr (&Shash_table_count
);
5523 defsubr (&Shash_table_rehash_size
);
5524 defsubr (&Shash_table_rehash_threshold
);
5525 defsubr (&Shash_table_size
);
5526 defsubr (&Shash_table_test
);
5527 defsubr (&Shash_table_weakness
);
5528 defsubr (&Shash_table_p
);
5529 defsubr (&Sclrhash
);
5530 defsubr (&Sgethash
);
5531 defsubr (&Sputhash
);
5532 defsubr (&Sremhash
);
5533 defsubr (&Smaphash
);
5534 defsubr (&Sdefine_hash_table_test
);
5536 Qstring_lessp
= intern ("string-lessp");
5537 staticpro (&Qstring_lessp
);
5538 Qprovide
= intern ("provide");
5539 staticpro (&Qprovide
);
5540 Qrequire
= intern ("require");
5541 staticpro (&Qrequire
);
5542 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5543 staticpro (&Qyes_or_no_p_history
);
5544 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5545 staticpro (&Qcursor_in_echo_area
);
5546 Qwidget_type
= intern ("widget-type");
5547 staticpro (&Qwidget_type
);
5549 staticpro (&string_char_byte_cache_string
);
5550 string_char_byte_cache_string
= Qnil
;
5552 require_nesting_list
= Qnil
;
5553 staticpro (&require_nesting_list
);
5555 Fset (Qyes_or_no_p_history
, Qnil
);
5557 DEFVAR_LISP ("features", &Vfeatures
,
5558 doc
: /* A list of symbols which are the features of the executing emacs.
5559 Used by `featurep' and `require', and altered by `provide'. */);
5561 Qsubfeatures
= intern ("subfeatures");
5562 staticpro (&Qsubfeatures
);
5564 #ifdef HAVE_LANGINFO_CODESET
5565 Qcodeset
= intern ("codeset");
5566 staticpro (&Qcodeset
);
5567 Qdays
= intern ("days");
5569 Qmonths
= intern ("months");
5570 staticpro (&Qmonths
);
5571 Qpaper
= intern ("paper");
5572 staticpro (&Qpaper
);
5573 #endif /* HAVE_LANGINFO_CODESET */
5575 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5576 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5577 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5578 invoked by mouse clicks and mouse menu items. */);
5581 defsubr (&Sidentity
);
5584 defsubr (&Ssafe_length
);
5585 defsubr (&Sstring_bytes
);
5586 defsubr (&Sstring_equal
);
5587 defsubr (&Scompare_strings
);
5588 defsubr (&Sstring_lessp
);
5591 defsubr (&Svconcat
);
5592 defsubr (&Scopy_sequence
);
5593 defsubr (&Sstring_make_multibyte
);
5594 defsubr (&Sstring_make_unibyte
);
5595 defsubr (&Sstring_as_multibyte
);
5596 defsubr (&Sstring_as_unibyte
);
5597 defsubr (&Sstring_to_multibyte
);
5598 defsubr (&Scopy_alist
);
5599 defsubr (&Ssubstring
);
5600 defsubr (&Ssubstring_no_properties
);
5612 defsubr (&Snreverse
);
5613 defsubr (&Sreverse
);
5615 defsubr (&Splist_get
);
5617 defsubr (&Splist_put
);
5619 defsubr (&Slax_plist_get
);
5620 defsubr (&Slax_plist_put
);
5622 defsubr (&Sfillarray
);
5623 defsubr (&Schar_table_subtype
);
5624 defsubr (&Schar_table_parent
);
5625 defsubr (&Sset_char_table_parent
);
5626 defsubr (&Schar_table_extra_slot
);
5627 defsubr (&Sset_char_table_extra_slot
);
5628 defsubr (&Schar_table_range
);
5629 defsubr (&Sset_char_table_range
);
5630 defsubr (&Sset_char_table_default
);
5631 defsubr (&Soptimize_char_table
);
5632 defsubr (&Smap_char_table
);
5636 defsubr (&Smapconcat
);
5637 defsubr (&Sy_or_n_p
);
5638 defsubr (&Syes_or_no_p
);
5639 defsubr (&Sload_average
);
5640 defsubr (&Sfeaturep
);
5641 defsubr (&Srequire
);
5642 defsubr (&Sprovide
);
5643 defsubr (&Splist_member
);
5644 defsubr (&Swidget_put
);
5645 defsubr (&Swidget_get
);
5646 defsubr (&Swidget_apply
);
5647 defsubr (&Sbase64_encode_region
);
5648 defsubr (&Sbase64_decode_region
);
5649 defsubr (&Sbase64_encode_string
);
5650 defsubr (&Sbase64_decode_string
);
5652 defsubr (&Slanginfo
);
5659 Vweak_hash_tables
= Qnil
;