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
);
1038 /* Convert STRING to a single-byte string. */
1041 string_make_unibyte (string
)
1046 if (! STRING_MULTIBYTE (string
))
1049 buf
= (unsigned char *) alloca (SCHARS (string
));
1051 copy_text (SDATA (string
), buf
, SBYTES (string
),
1054 return make_unibyte_string (buf
, SCHARS (string
));
1057 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1059 doc
: /* Return the multibyte equivalent of STRING.
1060 The function `unibyte-char-to-multibyte' is used to convert
1061 each unibyte character to a multibyte character. */)
1065 CHECK_STRING (string
);
1067 return string_make_multibyte (string
);
1070 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1072 doc
: /* Return the unibyte equivalent of STRING.
1073 Multibyte character codes are converted to unibyte according to
1074 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1075 If the lookup in the translation table fails, this function takes just
1076 the low 8 bits of each character. */)
1080 CHECK_STRING (string
);
1082 return string_make_unibyte (string
);
1085 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1087 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1088 If STRING is unibyte, the result is STRING itself.
1089 Otherwise it is a newly created string, with no text properties.
1090 If STRING is multibyte and contains a character of charset
1091 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1092 corresponding single byte. */)
1096 CHECK_STRING (string
);
1098 if (STRING_MULTIBYTE (string
))
1100 int bytes
= SBYTES (string
);
1101 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1103 bcopy (SDATA (string
), str
, bytes
);
1104 bytes
= str_as_unibyte (str
, bytes
);
1105 string
= make_unibyte_string (str
, bytes
);
1111 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1113 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1114 If STRING is multibyte, the result is STRING itself.
1115 Otherwise it is a newly created string, with no text properties.
1116 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1117 part of a multibyte form), it is converted to the corresponding
1118 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1122 CHECK_STRING (string
);
1124 if (! STRING_MULTIBYTE (string
))
1126 Lisp_Object new_string
;
1129 parse_str_as_multibyte (SDATA (string
),
1132 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1133 bcopy (SDATA (string
), SDATA (new_string
),
1135 if (nbytes
!= SBYTES (string
))
1136 str_as_multibyte (SDATA (new_string
), nbytes
,
1137 SBYTES (string
), NULL
);
1138 string
= new_string
;
1139 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1144 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1145 doc
: /* Return a copy of ALIST.
1146 This is an alist which represents the same mapping from objects to objects,
1147 but does not share the alist structure with ALIST.
1148 The objects mapped (cars and cdrs of elements of the alist)
1149 are shared, however.
1150 Elements of ALIST that are not conses are also shared. */)
1154 register Lisp_Object tem
;
1159 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1160 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1162 register Lisp_Object car
;
1166 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1171 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1172 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1173 TO may be nil or omitted; then the substring runs to the end of STRING.
1174 FROM and TO start at 0. If either is negative, it counts from the end.
1176 This function allows vectors as well as strings. */)
1179 register Lisp_Object from
, to
;
1184 int from_char
, to_char
;
1185 int from_byte
= 0, to_byte
= 0;
1187 if (! (STRINGP (string
) || VECTORP (string
)))
1188 wrong_type_argument (Qarrayp
, string
);
1190 CHECK_NUMBER (from
);
1192 if (STRINGP (string
))
1194 size
= SCHARS (string
);
1195 size_byte
= SBYTES (string
);
1198 size
= XVECTOR (string
)->size
;
1203 to_byte
= size_byte
;
1209 to_char
= XINT (to
);
1213 if (STRINGP (string
))
1214 to_byte
= string_char_to_byte (string
, to_char
);
1217 from_char
= XINT (from
);
1220 if (STRINGP (string
))
1221 from_byte
= string_char_to_byte (string
, from_char
);
1223 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1224 args_out_of_range_3 (string
, make_number (from_char
),
1225 make_number (to_char
));
1227 if (STRINGP (string
))
1229 res
= make_specified_string (SDATA (string
) + from_byte
,
1230 to_char
- from_char
, to_byte
- from_byte
,
1231 STRING_MULTIBYTE (string
));
1232 copy_text_properties (make_number (from_char
), make_number (to_char
),
1233 string
, make_number (0), res
, Qnil
);
1236 res
= Fvector (to_char
- from_char
,
1237 XVECTOR (string
)->contents
+ from_char
);
1243 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1244 doc
: /* Return a substring of STRING, without text properties.
1245 It starts at index FROM and ending before TO.
1246 TO may be nil or omitted; then the substring runs to the end of STRING.
1247 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1248 If FROM or TO is negative, it counts from the end.
1250 With one argument, just copy STRING without its properties. */)
1253 register Lisp_Object from
, to
;
1255 int size
, size_byte
;
1256 int from_char
, to_char
;
1257 int from_byte
, to_byte
;
1259 CHECK_STRING (string
);
1261 size
= SCHARS (string
);
1262 size_byte
= SBYTES (string
);
1265 from_char
= from_byte
= 0;
1268 CHECK_NUMBER (from
);
1269 from_char
= XINT (from
);
1273 from_byte
= string_char_to_byte (string
, from_char
);
1279 to_byte
= size_byte
;
1285 to_char
= XINT (to
);
1289 to_byte
= string_char_to_byte (string
, to_char
);
1292 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1293 args_out_of_range_3 (string
, make_number (from_char
),
1294 make_number (to_char
));
1296 return make_specified_string (SDATA (string
) + from_byte
,
1297 to_char
- from_char
, to_byte
- from_byte
,
1298 STRING_MULTIBYTE (string
));
1301 /* Extract a substring of STRING, giving start and end positions
1302 both in characters and in bytes. */
1305 substring_both (string
, from
, from_byte
, to
, to_byte
)
1307 int from
, from_byte
, to
, to_byte
;
1313 if (! (STRINGP (string
) || VECTORP (string
)))
1314 wrong_type_argument (Qarrayp
, string
);
1316 if (STRINGP (string
))
1318 size
= SCHARS (string
);
1319 size_byte
= SBYTES (string
);
1322 size
= XVECTOR (string
)->size
;
1324 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1325 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1327 if (STRINGP (string
))
1329 res
= make_specified_string (SDATA (string
) + from_byte
,
1330 to
- from
, to_byte
- from_byte
,
1331 STRING_MULTIBYTE (string
));
1332 copy_text_properties (make_number (from
), make_number (to
),
1333 string
, make_number (0), res
, Qnil
);
1336 res
= Fvector (to
- from
,
1337 XVECTOR (string
)->contents
+ from
);
1342 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1343 doc
: /* Take cdr N times on LIST, returns the result. */)
1346 register Lisp_Object list
;
1348 register int i
, num
;
1351 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1355 wrong_type_argument (Qlistp
, list
);
1361 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1362 doc
: /* Return the Nth element of LIST.
1363 N counts from zero. If LIST is not that long, nil is returned. */)
1365 Lisp_Object n
, list
;
1367 return Fcar (Fnthcdr (n
, list
));
1370 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1371 doc
: /* Return element of SEQUENCE at index N. */)
1373 register Lisp_Object sequence
, n
;
1378 if (CONSP (sequence
) || NILP (sequence
))
1379 return Fcar (Fnthcdr (n
, sequence
));
1380 else if (STRINGP (sequence
) || VECTORP (sequence
)
1381 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1382 return Faref (sequence
, n
);
1384 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1388 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1389 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1390 The value is actually the tail of LIST whose car is ELT. */)
1392 register Lisp_Object elt
;
1395 register Lisp_Object tail
;
1396 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1398 register Lisp_Object tem
;
1400 wrong_type_argument (Qlistp
, list
);
1402 if (! NILP (Fequal (elt
, tem
)))
1409 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1410 doc
: /* Return non-nil if ELT is an element of LIST.
1411 Comparison done with EQ. The value is actually the tail of LIST
1412 whose car is ELT. */)
1414 Lisp_Object elt
, list
;
1418 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1422 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1426 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1433 if (!CONSP (list
) && !NILP (list
))
1434 list
= wrong_type_argument (Qlistp
, list
);
1439 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1440 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1441 The value is actually the element of LIST whose car is KEY.
1442 Elements of LIST that are not conses are ignored. */)
1444 Lisp_Object key
, list
;
1451 || (CONSP (XCAR (list
))
1452 && EQ (XCAR (XCAR (list
)), key
)))
1457 || (CONSP (XCAR (list
))
1458 && EQ (XCAR (XCAR (list
)), key
)))
1463 || (CONSP (XCAR (list
))
1464 && EQ (XCAR (XCAR (list
)), key
)))
1472 result
= XCAR (list
);
1473 else if (NILP (list
))
1476 result
= wrong_type_argument (Qlistp
, list
);
1481 /* Like Fassq but never report an error and do not allow quits.
1482 Use only on lists known never to be circular. */
1485 assq_no_quit (key
, list
)
1486 Lisp_Object key
, list
;
1489 && (!CONSP (XCAR (list
))
1490 || !EQ (XCAR (XCAR (list
)), key
)))
1493 return CONSP (list
) ? XCAR (list
) : Qnil
;
1496 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1497 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1498 The value is actually the element of LIST whose car equals KEY. */)
1500 Lisp_Object key
, list
;
1502 Lisp_Object result
, car
;
1507 || (CONSP (XCAR (list
))
1508 && (car
= XCAR (XCAR (list
)),
1509 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1514 || (CONSP (XCAR (list
))
1515 && (car
= XCAR (XCAR (list
)),
1516 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1521 || (CONSP (XCAR (list
))
1522 && (car
= XCAR (XCAR (list
)),
1523 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1531 result
= XCAR (list
);
1532 else if (NILP (list
))
1535 result
= wrong_type_argument (Qlistp
, list
);
1540 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1541 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1542 The value is actually the element of LIST whose cdr is KEY. */)
1544 register Lisp_Object key
;
1552 || (CONSP (XCAR (list
))
1553 && EQ (XCDR (XCAR (list
)), key
)))
1558 || (CONSP (XCAR (list
))
1559 && EQ (XCDR (XCAR (list
)), key
)))
1564 || (CONSP (XCAR (list
))
1565 && EQ (XCDR (XCAR (list
)), key
)))
1574 else if (CONSP (list
))
1575 result
= XCAR (list
);
1577 result
= wrong_type_argument (Qlistp
, list
);
1582 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1583 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1584 The value is actually the element of LIST whose cdr equals KEY. */)
1586 Lisp_Object key
, list
;
1588 Lisp_Object result
, cdr
;
1593 || (CONSP (XCAR (list
))
1594 && (cdr
= XCDR (XCAR (list
)),
1595 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1600 || (CONSP (XCAR (list
))
1601 && (cdr
= XCDR (XCAR (list
)),
1602 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1607 || (CONSP (XCAR (list
))
1608 && (cdr
= XCDR (XCAR (list
)),
1609 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1617 result
= XCAR (list
);
1618 else if (NILP (list
))
1621 result
= wrong_type_argument (Qlistp
, list
);
1626 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1627 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1628 The modified LIST is returned. Comparison is done with `eq'.
1629 If the first member of LIST is ELT, there is no way to remove it by side effect;
1630 therefore, write `(setq foo (delq element foo))'
1631 to be sure of changing the value of `foo'. */)
1633 register Lisp_Object elt
;
1636 register Lisp_Object tail
, prev
;
1637 register Lisp_Object tem
;
1641 while (!NILP (tail
))
1644 wrong_type_argument (Qlistp
, list
);
1651 Fsetcdr (prev
, XCDR (tail
));
1661 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1662 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1663 SEQ must be a list, a vector, or a string.
1664 The modified SEQ is returned. Comparison is done with `equal'.
1665 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1666 is not a side effect; it is simply using a different sequence.
1667 Therefore, write `(setq foo (delete element foo))'
1668 to be sure of changing the value of `foo'. */)
1670 Lisp_Object elt
, seq
;
1676 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1677 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1680 if (n
!= ASIZE (seq
))
1682 struct Lisp_Vector
*p
= allocate_vector (n
);
1684 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1685 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1686 p
->contents
[n
++] = AREF (seq
, i
);
1688 XSETVECTOR (seq
, p
);
1691 else if (STRINGP (seq
))
1693 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1696 for (i
= nchars
= nbytes
= ibyte
= 0;
1698 ++i
, ibyte
+= cbytes
)
1700 if (STRING_MULTIBYTE (seq
))
1702 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1703 SBYTES (seq
) - ibyte
);
1704 cbytes
= CHAR_BYTES (c
);
1712 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1719 if (nchars
!= SCHARS (seq
))
1723 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1724 if (!STRING_MULTIBYTE (seq
))
1725 STRING_SET_UNIBYTE (tem
);
1727 for (i
= nchars
= nbytes
= ibyte
= 0;
1729 ++i
, ibyte
+= cbytes
)
1731 if (STRING_MULTIBYTE (seq
))
1733 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1734 SBYTES (seq
) - ibyte
);
1735 cbytes
= CHAR_BYTES (c
);
1743 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1745 unsigned char *from
= SDATA (seq
) + ibyte
;
1746 unsigned char *to
= SDATA (tem
) + nbytes
;
1752 for (n
= cbytes
; n
--; )
1762 Lisp_Object tail
, prev
;
1764 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1767 wrong_type_argument (Qlistp
, seq
);
1769 if (!NILP (Fequal (elt
, XCAR (tail
))))
1774 Fsetcdr (prev
, XCDR (tail
));
1785 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1786 doc
: /* Reverse LIST by modifying cdr pointers.
1787 Returns the beginning of the reversed list. */)
1791 register Lisp_Object prev
, tail
, next
;
1793 if (NILP (list
)) return list
;
1796 while (!NILP (tail
))
1800 wrong_type_argument (Qlistp
, list
);
1802 Fsetcdr (tail
, prev
);
1809 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1810 doc
: /* Reverse LIST, copying. Returns the beginning of the reversed list.
1811 See also the function `nreverse', which is used more often. */)
1817 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1820 new = Fcons (XCAR (list
), new);
1823 wrong_type_argument (Qconsp
, list
);
1827 Lisp_Object
merge ();
1829 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1830 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1831 Returns the sorted list. LIST is modified by side effects.
1832 PREDICATE is called with two elements of LIST, and should return t
1833 if the first element is "less" than the second. */)
1835 Lisp_Object list
, predicate
;
1837 Lisp_Object front
, back
;
1838 register Lisp_Object len
, tem
;
1839 struct gcpro gcpro1
, gcpro2
;
1840 register int length
;
1843 len
= Flength (list
);
1844 length
= XINT (len
);
1848 XSETINT (len
, (length
/ 2) - 1);
1849 tem
= Fnthcdr (len
, list
);
1851 Fsetcdr (tem
, Qnil
);
1853 GCPRO2 (front
, back
);
1854 front
= Fsort (front
, predicate
);
1855 back
= Fsort (back
, predicate
);
1857 return merge (front
, back
, predicate
);
1861 merge (org_l1
, org_l2
, pred
)
1862 Lisp_Object org_l1
, org_l2
;
1866 register Lisp_Object tail
;
1868 register Lisp_Object l1
, l2
;
1869 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1876 /* It is sufficient to protect org_l1 and org_l2.
1877 When l1 and l2 are updated, we copy the new values
1878 back into the org_ vars. */
1879 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1899 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1915 Fsetcdr (tail
, tem
);
1921 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1922 doc
: /* Extract a value from a property list.
1923 PLIST is a property list, which is a list of the form
1924 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1925 corresponding to the given PROP, or nil if PROP is not
1926 one of the properties on the list. */)
1934 CONSP (tail
) && CONSP (XCDR (tail
));
1935 tail
= XCDR (XCDR (tail
)))
1937 if (EQ (prop
, XCAR (tail
)))
1938 return XCAR (XCDR (tail
));
1940 /* This function can be called asynchronously
1941 (setup_coding_system). Don't QUIT in that case. */
1942 if (!interrupt_input_blocked
)
1947 wrong_type_argument (Qlistp
, prop
);
1952 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1953 doc
: /* Return the value of SYMBOL's PROPNAME property.
1954 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1956 Lisp_Object symbol
, propname
;
1958 CHECK_SYMBOL (symbol
);
1959 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1962 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1963 doc
: /* Change value in PLIST of PROP to VAL.
1964 PLIST is a property list, which is a list of the form
1965 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1966 If PROP is already a property on the list, its value is set to VAL,
1967 otherwise the new PROP VAL pair is added. The new plist is returned;
1968 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1969 The PLIST is modified by side effects. */)
1972 register Lisp_Object prop
;
1975 register Lisp_Object tail
, prev
;
1976 Lisp_Object newcell
;
1978 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1979 tail
= XCDR (XCDR (tail
)))
1981 if (EQ (prop
, XCAR (tail
)))
1983 Fsetcar (XCDR (tail
), val
);
1990 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1994 Fsetcdr (XCDR (prev
), newcell
);
1998 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1999 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2000 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2001 (symbol
, propname
, value
)
2002 Lisp_Object symbol
, propname
, value
;
2004 CHECK_SYMBOL (symbol
);
2005 XSYMBOL (symbol
)->plist
2006 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2010 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2011 doc
: /* Extract a value from a property list, comparing with `equal'.
2012 PLIST is a property list, which is a list of the form
2013 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2014 corresponding to the given PROP, or nil if PROP is not
2015 one of the properties on the list. */)
2023 CONSP (tail
) && CONSP (XCDR (tail
));
2024 tail
= XCDR (XCDR (tail
)))
2026 if (! NILP (Fequal (prop
, XCAR (tail
))))
2027 return XCAR (XCDR (tail
));
2033 wrong_type_argument (Qlistp
, prop
);
2038 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2039 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2040 PLIST is a property list, which is a list of the form
2041 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2042 If PROP is already a property on the list, its value is set to VAL,
2043 otherwise the new PROP VAL pair is added. The new plist is returned;
2044 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2045 The PLIST is modified by side effects. */)
2048 register Lisp_Object prop
;
2051 register Lisp_Object tail
, prev
;
2052 Lisp_Object newcell
;
2054 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2055 tail
= XCDR (XCDR (tail
)))
2057 if (! NILP (Fequal (prop
, XCAR (tail
))))
2059 Fsetcar (XCDR (tail
), val
);
2066 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2070 Fsetcdr (XCDR (prev
), newcell
);
2074 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2075 doc
: /* Return t if two Lisp objects have similar structure and contents.
2076 They must have the same data type.
2077 Conses are compared by comparing the cars and the cdrs.
2078 Vectors and strings are compared element by element.
2079 Numbers are compared by value, but integers cannot equal floats.
2080 (Use `=' if you want integers and floats to be able to be equal.)
2081 Symbols must match exactly. */)
2083 register Lisp_Object o1
, o2
;
2085 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2089 internal_equal (o1
, o2
, depth
)
2090 register Lisp_Object o1
, o2
;
2094 error ("Stack overflow in equal");
2100 if (XTYPE (o1
) != XTYPE (o2
))
2106 return (extract_float (o1
) == extract_float (o2
));
2109 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2116 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2120 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2122 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2125 o1
= XOVERLAY (o1
)->plist
;
2126 o2
= XOVERLAY (o2
)->plist
;
2131 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2132 && (XMARKER (o1
)->buffer
== 0
2133 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2137 case Lisp_Vectorlike
:
2139 register int i
, size
;
2140 size
= XVECTOR (o1
)->size
;
2141 /* Pseudovectors have the type encoded in the size field, so this test
2142 actually checks that the objects have the same type as well as the
2144 if (XVECTOR (o2
)->size
!= size
)
2146 /* Boolvectors are compared much like strings. */
2147 if (BOOL_VECTOR_P (o1
))
2150 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2152 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2154 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2159 if (WINDOW_CONFIGURATIONP (o1
))
2160 return compare_window_configurations (o1
, o2
, 0);
2162 /* Aside from them, only true vectors, char-tables, and compiled
2163 functions are sensible to compare, so eliminate the others now. */
2164 if (size
& PSEUDOVECTOR_FLAG
)
2166 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2168 size
&= PSEUDOVECTOR_SIZE_MASK
;
2170 for (i
= 0; i
< size
; i
++)
2173 v1
= XVECTOR (o1
)->contents
[i
];
2174 v2
= XVECTOR (o2
)->contents
[i
];
2175 if (!internal_equal (v1
, v2
, depth
+ 1))
2183 if (SCHARS (o1
) != SCHARS (o2
))
2185 if (SBYTES (o1
) != SBYTES (o2
))
2187 if (bcmp (SDATA (o1
), SDATA (o2
),
2194 case Lisp_Type_Limit
:
2201 extern Lisp_Object
Fmake_char_internal ();
2203 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2204 doc
: /* Store each element of ARRAY with ITEM.
2205 ARRAY is a vector, string, char-table, or bool-vector. */)
2207 Lisp_Object array
, item
;
2209 register int size
, index
, charval
;
2211 if (VECTORP (array
))
2213 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2214 size
= XVECTOR (array
)->size
;
2215 for (index
= 0; index
< size
; index
++)
2218 else if (CHAR_TABLE_P (array
))
2220 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2221 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2222 for (index
= 0; index
< size
; index
++)
2224 XCHAR_TABLE (array
)->defalt
= Qnil
;
2226 else if (STRINGP (array
))
2228 register unsigned char *p
= SDATA (array
);
2229 CHECK_NUMBER (item
);
2230 charval
= XINT (item
);
2231 size
= SCHARS (array
);
2232 if (STRING_MULTIBYTE (array
))
2234 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2235 int len
= CHAR_STRING (charval
, str
);
2236 int size_byte
= SBYTES (array
);
2237 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2240 if (size
!= size_byte
)
2243 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2244 if (len
!= this_len
)
2245 error ("Attempt to change byte length of a string");
2248 for (i
= 0; i
< size_byte
; i
++)
2249 *p
++ = str
[i
% len
];
2252 for (index
= 0; index
< size
; index
++)
2255 else if (BOOL_VECTOR_P (array
))
2257 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2259 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2261 charval
= (! NILP (item
) ? -1 : 0);
2262 for (index
= 0; index
< size_in_chars
; index
++)
2267 array
= wrong_type_argument (Qarrayp
, array
);
2273 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2275 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2277 Lisp_Object char_table
;
2279 CHECK_CHAR_TABLE (char_table
);
2281 return XCHAR_TABLE (char_table
)->purpose
;
2284 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2286 doc
: /* Return the parent char-table of CHAR-TABLE.
2287 The value is either nil or another char-table.
2288 If CHAR-TABLE holds nil for a given character,
2289 then the actual applicable value is inherited from the parent char-table
2290 \(or from its parents, if necessary). */)
2292 Lisp_Object char_table
;
2294 CHECK_CHAR_TABLE (char_table
);
2296 return XCHAR_TABLE (char_table
)->parent
;
2299 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2301 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2302 PARENT must be either nil or another char-table. */)
2303 (char_table
, parent
)
2304 Lisp_Object char_table
, parent
;
2308 CHECK_CHAR_TABLE (char_table
);
2312 CHECK_CHAR_TABLE (parent
);
2314 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2315 if (EQ (temp
, char_table
))
2316 error ("Attempt to make a chartable be its own parent");
2319 XCHAR_TABLE (char_table
)->parent
= parent
;
2324 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2326 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2328 Lisp_Object char_table
, n
;
2330 CHECK_CHAR_TABLE (char_table
);
2333 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2334 args_out_of_range (char_table
, n
);
2336 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2339 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2340 Sset_char_table_extra_slot
,
2342 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2343 (char_table
, n
, value
)
2344 Lisp_Object char_table
, n
, value
;
2346 CHECK_CHAR_TABLE (char_table
);
2349 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2350 args_out_of_range (char_table
, n
);
2352 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2355 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2357 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2358 RANGE should be nil (for the default value)
2359 a vector which identifies a character set or a row of a character set,
2360 a character set name, or a character code. */)
2362 Lisp_Object char_table
, range
;
2364 CHECK_CHAR_TABLE (char_table
);
2366 if (EQ (range
, Qnil
))
2367 return XCHAR_TABLE (char_table
)->defalt
;
2368 else if (INTEGERP (range
))
2369 return Faref (char_table
, range
);
2370 else if (SYMBOLP (range
))
2372 Lisp_Object charset_info
;
2374 charset_info
= Fget (range
, Qcharset
);
2375 CHECK_VECTOR (charset_info
);
2377 return Faref (char_table
,
2378 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2381 else if (VECTORP (range
))
2383 if (XVECTOR (range
)->size
== 1)
2384 return Faref (char_table
,
2385 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2388 int size
= XVECTOR (range
)->size
;
2389 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2390 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2391 size
<= 1 ? Qnil
: val
[1],
2392 size
<= 2 ? Qnil
: val
[2]);
2393 return Faref (char_table
, ch
);
2397 error ("Invalid RANGE argument to `char-table-range'");
2401 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2403 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2404 RANGE should be t (for all characters), nil (for the default value)
2405 a vector which identifies a character set or a row of a character set,
2406 a coding system, or a character code. */)
2407 (char_table
, range
, value
)
2408 Lisp_Object char_table
, range
, value
;
2412 CHECK_CHAR_TABLE (char_table
);
2415 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2416 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2417 else if (EQ (range
, Qnil
))
2418 XCHAR_TABLE (char_table
)->defalt
= value
;
2419 else if (SYMBOLP (range
))
2421 Lisp_Object charset_info
;
2423 charset_info
= Fget (range
, Qcharset
);
2424 CHECK_VECTOR (charset_info
);
2426 return Faset (char_table
,
2427 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2431 else if (INTEGERP (range
))
2432 Faset (char_table
, range
, value
);
2433 else if (VECTORP (range
))
2435 if (XVECTOR (range
)->size
== 1)
2436 return Faset (char_table
,
2437 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2441 int size
= XVECTOR (range
)->size
;
2442 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2443 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2444 size
<= 1 ? Qnil
: val
[1],
2445 size
<= 2 ? Qnil
: val
[2]);
2446 return Faset (char_table
, ch
, value
);
2450 error ("Invalid RANGE argument to `set-char-table-range'");
2455 DEFUN ("set-char-table-default", Fset_char_table_default
,
2456 Sset_char_table_default
, 3, 3, 0,
2457 doc
: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
2458 The generic character specifies the group of characters.
2459 See also the documentation of make-char. */)
2460 (char_table
, ch
, value
)
2461 Lisp_Object char_table
, ch
, value
;
2463 int c
, charset
, code1
, code2
;
2466 CHECK_CHAR_TABLE (char_table
);
2470 SPLIT_CHAR (c
, charset
, code1
, code2
);
2472 /* Since we may want to set the default value for a character set
2473 not yet defined, we check only if the character set is in the
2474 valid range or not, instead of it is already defined or not. */
2475 if (! CHARSET_VALID_P (charset
))
2476 invalid_character (c
);
2478 if (charset
== CHARSET_ASCII
)
2479 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2481 /* Even if C is not a generic char, we had better behave as if a
2482 generic char is specified. */
2483 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2485 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2488 if (SUB_CHAR_TABLE_P (temp
))
2489 XCHAR_TABLE (temp
)->defalt
= value
;
2491 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2494 if (SUB_CHAR_TABLE_P (temp
))
2497 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2498 = make_sub_char_table (temp
));
2499 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2500 if (SUB_CHAR_TABLE_P (temp
))
2501 XCHAR_TABLE (temp
)->defalt
= value
;
2503 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2507 /* Look up the element in TABLE at index CH,
2508 and return it as an integer.
2509 If the element is nil, return CH itself.
2510 (Actually we do that for any non-integer.) */
2513 char_table_translate (table
, ch
)
2518 value
= Faref (table
, make_number (ch
));
2519 if (! INTEGERP (value
))
2521 return XINT (value
);
2525 optimize_sub_char_table (table
, chars
)
2533 from
= 33, to
= 127;
2535 from
= 32, to
= 128;
2537 if (!SUB_CHAR_TABLE_P (*table
))
2539 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2540 for (; from
< to
; from
++)
2541 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2546 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2547 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2555 CHECK_CHAR_TABLE (table
);
2557 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2559 elt
= XCHAR_TABLE (table
)->contents
[i
];
2560 if (!SUB_CHAR_TABLE_P (elt
))
2562 dim
= CHARSET_DIMENSION (i
- 128);
2564 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2565 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2566 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2572 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2573 character or group of characters that share a value.
2574 DEPTH is the current depth in the originally specified
2575 chartable, and INDICES contains the vector indices
2576 for the levels our callers have descended.
2578 ARG is passed to C_FUNCTION when that is called. */
2581 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2582 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2583 Lisp_Object function
, subtable
, arg
, *indices
;
2590 /* At first, handle ASCII and 8-bit European characters. */
2591 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2593 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2595 (*c_function
) (arg
, make_number (i
), elt
);
2597 call2 (function
, make_number (i
), elt
);
2599 #if 0 /* If the char table has entries for higher characters,
2600 we should report them. */
2601 if (NILP (current_buffer
->enable_multibyte_characters
))
2604 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2608 int charset
= XFASTINT (indices
[0]) - 128;
2611 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2612 if (CHARSET_CHARS (charset
) == 94)
2621 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2622 XSETFASTINT (indices
[depth
], i
);
2623 charset
= XFASTINT (indices
[0]) - 128;
2625 && (!CHARSET_DEFINED_P (charset
)
2626 || charset
== CHARSET_8_BIT_CONTROL
2627 || charset
== CHARSET_8_BIT_GRAPHIC
))
2630 if (SUB_CHAR_TABLE_P (elt
))
2633 error ("Too deep char table");
2634 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2641 elt
= XCHAR_TABLE (subtable
)->defalt
;
2642 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2643 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2644 c
= MAKE_CHAR (charset
, c1
, c2
);
2646 (*c_function
) (arg
, make_number (c
), elt
);
2648 call2 (function
, make_number (c
), elt
);
2653 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2655 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2656 FUNCTION is called with two arguments--a key and a value.
2657 The key is always a possible IDX argument to `aref'. */)
2658 (function
, char_table
)
2659 Lisp_Object function
, char_table
;
2661 /* The depth of char table is at most 3. */
2662 Lisp_Object indices
[3];
2664 CHECK_CHAR_TABLE (char_table
);
2666 map_char_table ((POINTER_TYPE
*) call2
, Qnil
, char_table
, function
, 0, indices
);
2670 /* Return a value for character C in char-table TABLE. Store the
2671 actual index for that value in *IDX. Ignore the default value of
2675 char_table_ref_and_index (table
, c
, idx
)
2679 int charset
, c1
, c2
;
2682 if (SINGLE_BYTE_CHAR_P (c
))
2685 return XCHAR_TABLE (table
)->contents
[c
];
2687 SPLIT_CHAR (c
, charset
, c1
, c2
);
2688 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2689 *idx
= MAKE_CHAR (charset
, 0, 0);
2690 if (!SUB_CHAR_TABLE_P (elt
))
2692 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2693 return XCHAR_TABLE (elt
)->defalt
;
2694 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2695 *idx
= MAKE_CHAR (charset
, c1
, 0);
2696 if (!SUB_CHAR_TABLE_P (elt
))
2698 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2699 return XCHAR_TABLE (elt
)->defalt
;
2701 return XCHAR_TABLE (elt
)->contents
[c2
];
2711 Lisp_Object args
[2];
2714 return Fnconc (2, args
);
2716 return Fnconc (2, &s1
);
2717 #endif /* NO_ARG_ARRAY */
2720 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2721 doc
: /* Concatenate any number of lists by altering them.
2722 Only the last argument is not altered, and need not be a list.
2723 usage: (nconc &rest LISTS) */)
2728 register int argnum
;
2729 register Lisp_Object tail
, tem
, val
;
2733 for (argnum
= 0; argnum
< nargs
; argnum
++)
2736 if (NILP (tem
)) continue;
2741 if (argnum
+ 1 == nargs
) break;
2744 tem
= wrong_type_argument (Qlistp
, tem
);
2753 tem
= args
[argnum
+ 1];
2754 Fsetcdr (tail
, tem
);
2756 args
[argnum
+ 1] = tail
;
2762 /* This is the guts of all mapping functions.
2763 Apply FN to each element of SEQ, one by one,
2764 storing the results into elements of VALS, a C vector of Lisp_Objects.
2765 LENI is the length of VALS, which should also be the length of SEQ. */
2768 mapcar1 (leni
, vals
, fn
, seq
)
2771 Lisp_Object fn
, seq
;
2773 register Lisp_Object tail
;
2776 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2780 /* Don't let vals contain any garbage when GC happens. */
2781 for (i
= 0; i
< leni
; i
++)
2784 GCPRO3 (dummy
, fn
, seq
);
2786 gcpro1
.nvars
= leni
;
2790 /* We need not explicitly protect `tail' because it is used only on lists, and
2791 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2795 for (i
= 0; i
< leni
; i
++)
2797 dummy
= XVECTOR (seq
)->contents
[i
];
2798 dummy
= call1 (fn
, dummy
);
2803 else if (BOOL_VECTOR_P (seq
))
2805 for (i
= 0; i
< leni
; i
++)
2808 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2809 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2814 dummy
= call1 (fn
, dummy
);
2819 else if (STRINGP (seq
))
2823 for (i
= 0, i_byte
= 0; i
< leni
;)
2828 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2829 XSETFASTINT (dummy
, c
);
2830 dummy
= call1 (fn
, dummy
);
2832 vals
[i_before
] = dummy
;
2835 else /* Must be a list, since Flength did not get an error */
2838 for (i
= 0; i
< leni
; i
++)
2840 dummy
= call1 (fn
, Fcar (tail
));
2850 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2851 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2852 In between each pair of results, stick in SEPARATOR. Thus, " " as
2853 SEPARATOR results in spaces between the values returned by FUNCTION.
2854 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2855 (function
, sequence
, separator
)
2856 Lisp_Object function
, sequence
, separator
;
2861 register Lisp_Object
*args
;
2863 struct gcpro gcpro1
;
2865 len
= Flength (sequence
);
2867 nargs
= leni
+ leni
- 1;
2868 if (nargs
< 0) return build_string ("");
2870 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2873 mapcar1 (leni
, args
, function
, sequence
);
2876 for (i
= leni
- 1; i
>= 0; i
--)
2877 args
[i
+ i
] = args
[i
];
2879 for (i
= 1; i
< nargs
; i
+= 2)
2880 args
[i
] = separator
;
2882 return Fconcat (nargs
, args
);
2885 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2886 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2887 The result is a list just as long as SEQUENCE.
2888 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2889 (function
, sequence
)
2890 Lisp_Object function
, sequence
;
2892 register Lisp_Object len
;
2894 register Lisp_Object
*args
;
2896 len
= Flength (sequence
);
2897 leni
= XFASTINT (len
);
2898 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2900 mapcar1 (leni
, args
, function
, sequence
);
2902 return Flist (leni
, args
);
2905 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2906 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2907 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2908 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2909 (function
, sequence
)
2910 Lisp_Object function
, sequence
;
2914 leni
= XFASTINT (Flength (sequence
));
2915 mapcar1 (leni
, 0, function
, sequence
);
2920 /* Anything that calls this function must protect from GC! */
2922 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2923 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2924 Takes one argument, which is the string to display to ask the question.
2925 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2926 No confirmation of the answer is requested; a single character is enough.
2927 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2928 the bindings in `query-replace-map'; see the documentation of that variable
2929 for more information. In this case, the useful bindings are `act', `skip',
2930 `recenter', and `quit'.\)
2932 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2933 is nil and `use-dialog-box' is non-nil. */)
2937 register Lisp_Object obj
, key
, def
, map
;
2938 register int answer
;
2939 Lisp_Object xprompt
;
2940 Lisp_Object args
[2];
2941 struct gcpro gcpro1
, gcpro2
;
2942 int count
= SPECPDL_INDEX ();
2944 specbind (Qcursor_in_echo_area
, Qt
);
2946 map
= Fsymbol_value (intern ("query-replace-map"));
2948 CHECK_STRING (prompt
);
2950 GCPRO2 (prompt
, xprompt
);
2952 #ifdef HAVE_X_WINDOWS
2953 if (display_hourglass_p
)
2954 cancel_hourglass ();
2961 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2965 Lisp_Object pane
, menu
;
2966 redisplay_preserve_echo_area (3);
2967 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2968 Fcons (Fcons (build_string ("No"), Qnil
),
2970 menu
= Fcons (prompt
, pane
);
2971 obj
= Fx_popup_dialog (Qt
, menu
);
2972 answer
= !NILP (obj
);
2975 #endif /* HAVE_MENUS */
2976 cursor_in_echo_area
= 1;
2977 choose_minibuf_frame ();
2980 Lisp_Object pargs
[3];
2982 /* Colorize prompt according to `minibuffer-prompt' face. */
2983 pargs
[0] = build_string ("%s(y or n) ");
2984 pargs
[1] = intern ("face");
2985 pargs
[2] = intern ("minibuffer-prompt");
2986 args
[0] = Fpropertize (3, pargs
);
2991 if (minibuffer_auto_raise
)
2993 Lisp_Object mini_frame
;
2995 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2997 Fraise_frame (mini_frame
);
3000 obj
= read_filtered_event (1, 0, 0, 0);
3001 cursor_in_echo_area
= 0;
3002 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3005 key
= Fmake_vector (make_number (1), obj
);
3006 def
= Flookup_key (map
, key
, Qt
);
3008 if (EQ (def
, intern ("skip")))
3013 else if (EQ (def
, intern ("act")))
3018 else if (EQ (def
, intern ("recenter")))
3024 else if (EQ (def
, intern ("quit")))
3026 /* We want to exit this command for exit-prefix,
3027 and this is the only way to do it. */
3028 else if (EQ (def
, intern ("exit-prefix")))
3033 /* If we don't clear this, then the next call to read_char will
3034 return quit_char again, and we'll enter an infinite loop. */
3039 if (EQ (xprompt
, prompt
))
3041 args
[0] = build_string ("Please answer y or n. ");
3043 xprompt
= Fconcat (2, args
);
3048 if (! noninteractive
)
3050 cursor_in_echo_area
= -1;
3051 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3055 unbind_to (count
, Qnil
);
3056 return answer
? Qt
: Qnil
;
3059 /* This is how C code calls `yes-or-no-p' and allows the user
3062 Anything that calls this function must protect from GC! */
3065 do_yes_or_no_p (prompt
)
3068 return call1 (intern ("yes-or-no-p"), prompt
);
3071 /* Anything that calls this function must protect from GC! */
3073 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3074 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3075 Takes one argument, which is the string to display to ask the question.
3076 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3077 The user must confirm the answer with RET,
3078 and can edit it until it has been confirmed.
3080 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3081 is nil, and `use-dialog-box' is non-nil. */)
3085 register Lisp_Object ans
;
3086 Lisp_Object args
[2];
3087 struct gcpro gcpro1
;
3089 CHECK_STRING (prompt
);
3092 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3096 Lisp_Object pane
, menu
, obj
;
3097 redisplay_preserve_echo_area (4);
3098 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3099 Fcons (Fcons (build_string ("No"), Qnil
),
3102 menu
= Fcons (prompt
, pane
);
3103 obj
= Fx_popup_dialog (Qt
, menu
);
3107 #endif /* HAVE_MENUS */
3110 args
[1] = build_string ("(yes or no) ");
3111 prompt
= Fconcat (2, args
);
3117 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3118 Qyes_or_no_p_history
, Qnil
,
3120 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3125 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3133 message ("Please answer yes or no.");
3134 Fsleep_for (make_number (2), Qnil
);
3138 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3139 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3141 Each of the three load averages is multiplied by 100, then converted
3144 When USE-FLOATS is non-nil, floats will be used instead of integers.
3145 These floats are not multiplied by 100.
3147 If the 5-minute or 15-minute load averages are not available, return a
3148 shortened list, containing only those averages which are available. */)
3150 Lisp_Object use_floats
;
3153 int loads
= getloadavg (load_ave
, 3);
3154 Lisp_Object ret
= Qnil
;
3157 error ("load-average not implemented for this operating system");
3161 Lisp_Object load
= (NILP (use_floats
) ?
3162 make_number ((int) (100.0 * load_ave
[loads
]))
3163 : make_float (load_ave
[loads
]));
3164 ret
= Fcons (load
, ret
);
3170 Lisp_Object Vfeatures
, Qsubfeatures
;
3171 extern Lisp_Object Vafter_load_alist
;
3173 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3174 doc
: /* Returns t if FEATURE is present in this Emacs.
3176 Use this to conditionalize execution of lisp code based on the
3177 presence or absence of emacs or environment extensions.
3178 Use `provide' to declare that a feature is available. This function
3179 looks at the value of the variable `features'. The optional argument
3180 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3181 (feature
, subfeature
)
3182 Lisp_Object feature
, subfeature
;
3184 register Lisp_Object tem
;
3185 CHECK_SYMBOL (feature
);
3186 tem
= Fmemq (feature
, Vfeatures
);
3187 if (!NILP (tem
) && !NILP (subfeature
))
3188 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3189 return (NILP (tem
)) ? Qnil
: Qt
;
3192 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3193 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3194 The optional argument SUBFEATURES should be a list of symbols listing
3195 particular subfeatures supported in this version of FEATURE. */)
3196 (feature
, subfeatures
)
3197 Lisp_Object feature
, subfeatures
;
3199 register Lisp_Object tem
;
3200 CHECK_SYMBOL (feature
);
3201 CHECK_LIST (subfeatures
);
3202 if (!NILP (Vautoload_queue
))
3203 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3204 tem
= Fmemq (feature
, Vfeatures
);
3206 Vfeatures
= Fcons (feature
, Vfeatures
);
3207 if (!NILP (subfeatures
))
3208 Fput (feature
, Qsubfeatures
, subfeatures
);
3209 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3211 /* Run any load-hooks for this file. */
3212 tem
= Fassq (feature
, Vafter_load_alist
);
3214 Fprogn (XCDR (tem
));
3219 /* `require' and its subroutines. */
3221 /* List of features currently being require'd, innermost first. */
3223 Lisp_Object require_nesting_list
;
3226 require_unwind (old_value
)
3227 Lisp_Object old_value
;
3229 return require_nesting_list
= old_value
;
3232 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3233 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3234 If FEATURE is not a member of the list `features', then the feature
3235 is not loaded; so load the file FILENAME.
3236 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3237 and `load' will try to load this name appended with the suffix `.elc',
3238 `.el' or the unmodified name, in that order.
3239 If the optional third argument NOERROR is non-nil,
3240 then return nil if the file is not found instead of signaling an error.
3241 Normally the return value is FEATURE.
3242 The normal messages at start and end of loading FILENAME are suppressed. */)
3243 (feature
, filename
, noerror
)
3244 Lisp_Object feature
, filename
, noerror
;
3246 register Lisp_Object tem
;
3247 struct gcpro gcpro1
, gcpro2
;
3249 CHECK_SYMBOL (feature
);
3251 tem
= Fmemq (feature
, Vfeatures
);
3255 int count
= SPECPDL_INDEX ();
3258 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3260 /* This is to make sure that loadup.el gives a clear picture
3261 of what files are preloaded and when. */
3262 if (! NILP (Vpurify_flag
))
3263 error ("(require %s) while preparing to dump",
3264 SDATA (SYMBOL_NAME (feature
)));
3266 /* A certain amount of recursive `require' is legitimate,
3267 but if we require the same feature recursively 3 times,
3269 tem
= require_nesting_list
;
3270 while (! NILP (tem
))
3272 if (! NILP (Fequal (feature
, XCAR (tem
))))
3277 error ("Recursive `require' for feature `%s'",
3278 SDATA (SYMBOL_NAME (feature
)));
3280 /* Update the list for any nested `require's that occur. */
3281 record_unwind_protect (require_unwind
, require_nesting_list
);
3282 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3284 /* Value saved here is to be restored into Vautoload_queue */
3285 record_unwind_protect (un_autoload
, Vautoload_queue
);
3286 Vautoload_queue
= Qt
;
3288 /* Load the file. */
3289 GCPRO2 (feature
, filename
);
3290 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3291 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3294 /* If load failed entirely, return nil. */
3296 return unbind_to (count
, Qnil
);
3298 tem
= Fmemq (feature
, Vfeatures
);
3300 error ("Required feature `%s' was not provided",
3301 SDATA (SYMBOL_NAME (feature
)));
3303 /* Once loading finishes, don't undo it. */
3304 Vautoload_queue
= Qt
;
3305 feature
= unbind_to (count
, feature
);
3311 /* Primitives for work of the "widget" library.
3312 In an ideal world, this section would not have been necessary.
3313 However, lisp function calls being as slow as they are, it turns
3314 out that some functions in the widget library (wid-edit.el) are the
3315 bottleneck of Widget operation. Here is their translation to C,
3316 for the sole reason of efficiency. */
3318 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3319 doc
: /* Return non-nil if PLIST has the property PROP.
3320 PLIST is a property list, which is a list of the form
3321 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3322 Unlike `plist-get', this allows you to distinguish between a missing
3323 property and a property with the value nil.
3324 The value is actually the tail of PLIST whose car is PROP. */)
3326 Lisp_Object plist
, prop
;
3328 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3331 plist
= XCDR (plist
);
3332 plist
= CDR (plist
);
3337 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3338 doc
: /* In WIDGET, set PROPERTY to VALUE.
3339 The value can later be retrieved with `widget-get'. */)
3340 (widget
, property
, value
)
3341 Lisp_Object widget
, property
, value
;
3343 CHECK_CONS (widget
);
3344 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3348 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3349 doc
: /* In WIDGET, get the value of PROPERTY.
3350 The value could either be specified when the widget was created, or
3351 later with `widget-put'. */)
3353 Lisp_Object widget
, property
;
3361 CHECK_CONS (widget
);
3362 tmp
= Fplist_member (XCDR (widget
), property
);
3368 tmp
= XCAR (widget
);
3371 widget
= Fget (tmp
, Qwidget_type
);
3375 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3376 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3377 ARGS are passed as extra arguments to the function.
3378 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3383 /* This function can GC. */
3384 Lisp_Object newargs
[3];
3385 struct gcpro gcpro1
, gcpro2
;
3388 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3389 newargs
[1] = args
[0];
3390 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3391 GCPRO2 (newargs
[0], newargs
[2]);
3392 result
= Fapply (3, newargs
);
3397 #ifdef HAVE_LANGINFO_CODESET
3398 #include <langinfo.h>
3401 DEFUN ("langinfo", Flanginfo
, Slanginfo
, 1, 1, 0,
3402 doc
: /* Access locale category ITEM, if available.
3404 ITEM may be one of the following:
3405 `codeset', returning the character set as a string (CODESET);
3406 `days', returning a 7-element vector of day names (DAY_n);
3407 `months', returning a 12-element vector of month names (MON_n).
3409 If the system can't provide such information through a call to
3410 nl_langinfo(3), return nil.
3412 The data read from the system are decoded using `locale-coding-system'. */)
3417 #ifdef HAVE_LANGINFO_CODESET
3419 if (EQ (item
, Qcodeset
))
3421 str
= nl_langinfo (CODESET
);
3422 return build_string (str
);
3425 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3427 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3428 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3430 synchronize_system_time_locale ();
3431 for (i
= 0; i
< 7; i
++)
3433 str
= nl_langinfo (days
[i
]);
3434 val
= make_unibyte_string (str
, strlen (str
));
3435 /* Fixme: Is this coding system necessarily right, even if
3436 it is consistent with CODESET? If not, what to do? */
3437 Faset (v
, make_number (i
),
3438 code_convert_string_norecord (val
, Vlocale_coding_system
,
3445 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3447 struct Lisp_Vector
*p
= allocate_vector (12);
3448 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3449 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3451 synchronize_system_time_locale ();
3452 for (i
= 0; i
< 12; i
++)
3454 str
= nl_langinfo (months
[i
]);
3455 val
= make_unibyte_string (str
, strlen (str
));
3457 code_convert_string_norecord (val
, Vlocale_coding_system
, Qnil
);
3459 XSETVECTOR (val
, p
);
3463 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3464 but is in the locale files. This could be used by ps-print. */
3466 else if (EQ (item
, Qpaper
))
3468 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3469 make_number (nl_langinfo (PAPER_HEIGHT
)));
3471 #endif /* PAPER_WIDTH */
3472 #endif /* HAVE_LANGINFO_CODESET*/
3476 /* base64 encode/decode functions (RFC 2045).
3477 Based on code from GNU recode. */
3479 #define MIME_LINE_LENGTH 76
3481 #define IS_ASCII(Character) \
3483 #define IS_BASE64(Character) \
3484 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3485 #define IS_BASE64_IGNORABLE(Character) \
3486 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3487 || (Character) == '\f' || (Character) == '\r')
3489 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3490 character or return retval if there are no characters left to
3492 #define READ_QUADRUPLET_BYTE(retval) \
3497 if (nchars_return) \
3498 *nchars_return = nchars; \
3503 while (IS_BASE64_IGNORABLE (c))
3505 /* Don't use alloca for regions larger than this, lest we overflow
3507 #define MAX_ALLOCA 16*1024
3509 /* Table of characters coding the 64 values. */
3510 static char base64_value_to_char
[64] =
3512 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3513 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3514 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3515 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3516 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3517 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3518 '8', '9', '+', '/' /* 60-63 */
3521 /* Table of base64 values for first 128 characters. */
3522 static short base64_char_to_value
[128] =
3524 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3525 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3526 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3527 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3528 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3529 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3530 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3531 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3532 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3533 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3534 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3535 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3536 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3539 /* The following diagram shows the logical steps by which three octets
3540 get transformed into four base64 characters.
3542 .--------. .--------. .--------.
3543 |aaaaaabb| |bbbbcccc| |ccdddddd|
3544 `--------' `--------' `--------'
3546 .--------+--------+--------+--------.
3547 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3548 `--------+--------+--------+--------'
3550 .--------+--------+--------+--------.
3551 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3552 `--------+--------+--------+--------'
3554 The octets are divided into 6 bit chunks, which are then encoded into
3555 base64 characters. */
3558 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3559 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3561 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3563 doc
: /* Base64-encode the region between BEG and END.
3564 Return the length of the encoded text.
3565 Optional third argument NO-LINE-BREAK means do not break long lines
3566 into shorter lines. */)
3567 (beg
, end
, no_line_break
)
3568 Lisp_Object beg
, end
, no_line_break
;
3571 int allength
, length
;
3572 int ibeg
, iend
, encoded_length
;
3575 validate_region (&beg
, &end
);
3577 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3578 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3579 move_gap_both (XFASTINT (beg
), ibeg
);
3581 /* We need to allocate enough room for encoding the text.
3582 We need 33 1/3% more space, plus a newline every 76
3583 characters, and then we round up. */
3584 length
= iend
- ibeg
;
3585 allength
= length
+ length
/3 + 1;
3586 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3588 if (allength
<= MAX_ALLOCA
)
3589 encoded
= (char *) alloca (allength
);
3591 encoded
= (char *) xmalloc (allength
);
3592 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3593 NILP (no_line_break
),
3594 !NILP (current_buffer
->enable_multibyte_characters
));
3595 if (encoded_length
> allength
)
3598 if (encoded_length
< 0)
3600 /* The encoding wasn't possible. */
3601 if (length
> MAX_ALLOCA
)
3603 error ("Multibyte character in data for base64 encoding");
3606 /* Now we have encoded the region, so we insert the new contents
3607 and delete the old. (Insert first in order to preserve markers.) */
3608 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3609 insert (encoded
, encoded_length
);
3610 if (allength
> MAX_ALLOCA
)
3612 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3614 /* If point was outside of the region, restore it exactly; else just
3615 move to the beginning of the region. */
3616 if (old_pos
>= XFASTINT (end
))
3617 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3618 else if (old_pos
> XFASTINT (beg
))
3619 old_pos
= XFASTINT (beg
);
3622 /* We return the length of the encoded text. */
3623 return make_number (encoded_length
);
3626 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3628 doc
: /* Base64-encode STRING and return the result.
3629 Optional second argument NO-LINE-BREAK means do not break long lines
3630 into shorter lines. */)
3631 (string
, no_line_break
)
3632 Lisp_Object string
, no_line_break
;
3634 int allength
, length
, encoded_length
;
3636 Lisp_Object encoded_string
;
3638 CHECK_STRING (string
);
3640 /* We need to allocate enough room for encoding the text.
3641 We need 33 1/3% more space, plus a newline every 76
3642 characters, and then we round up. */
3643 length
= SBYTES (string
);
3644 allength
= length
+ length
/3 + 1;
3645 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3647 /* We need to allocate enough room for decoding the text. */
3648 if (allength
<= MAX_ALLOCA
)
3649 encoded
= (char *) alloca (allength
);
3651 encoded
= (char *) xmalloc (allength
);
3653 encoded_length
= base64_encode_1 (SDATA (string
),
3654 encoded
, length
, NILP (no_line_break
),
3655 STRING_MULTIBYTE (string
));
3656 if (encoded_length
> allength
)
3659 if (encoded_length
< 0)
3661 /* The encoding wasn't possible. */
3662 if (length
> MAX_ALLOCA
)
3664 error ("Multibyte character in data for base64 encoding");
3667 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3668 if (allength
> MAX_ALLOCA
)
3671 return encoded_string
;
3675 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3682 int counter
= 0, i
= 0;
3692 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3700 /* Wrap line every 76 characters. */
3704 if (counter
< MIME_LINE_LENGTH
/ 4)
3713 /* Process first byte of a triplet. */
3715 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3716 value
= (0x03 & c
) << 4;
3718 /* Process second byte of a triplet. */
3722 *e
++ = base64_value_to_char
[value
];
3730 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3738 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3739 value
= (0x0f & c
) << 2;
3741 /* Process third byte of a triplet. */
3745 *e
++ = base64_value_to_char
[value
];
3752 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3760 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3761 *e
++ = base64_value_to_char
[0x3f & c
];
3768 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3770 doc
: /* Base64-decode the region between BEG and END.
3771 Return the length of the decoded text.
3772 If the region can't be decoded, signal an error and don't modify the buffer. */)
3774 Lisp_Object beg
, end
;
3776 int ibeg
, iend
, length
, allength
;
3781 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3783 validate_region (&beg
, &end
);
3785 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3786 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3788 length
= iend
- ibeg
;
3790 /* We need to allocate enough room for decoding the text. If we are
3791 working on a multibyte buffer, each decoded code may occupy at
3793 allength
= multibyte
? length
* 2 : length
;
3794 if (allength
<= MAX_ALLOCA
)
3795 decoded
= (char *) alloca (allength
);
3797 decoded
= (char *) xmalloc (allength
);
3799 move_gap_both (XFASTINT (beg
), ibeg
);
3800 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3801 multibyte
, &inserted_chars
);
3802 if (decoded_length
> allength
)
3805 if (decoded_length
< 0)
3807 /* The decoding wasn't possible. */
3808 if (allength
> MAX_ALLOCA
)
3810 error ("Invalid base64 data");
3813 /* Now we have decoded the region, so we insert the new contents
3814 and delete the old. (Insert first in order to preserve markers.) */
3815 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3816 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3817 if (allength
> MAX_ALLOCA
)
3819 /* Delete the original text. */
3820 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3821 iend
+ decoded_length
, 1);
3823 /* If point was outside of the region, restore it exactly; else just
3824 move to the beginning of the region. */
3825 if (old_pos
>= XFASTINT (end
))
3826 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3827 else if (old_pos
> XFASTINT (beg
))
3828 old_pos
= XFASTINT (beg
);
3829 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3831 return make_number (inserted_chars
);
3834 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3836 doc
: /* Base64-decode STRING and return the result. */)
3841 int length
, decoded_length
;
3842 Lisp_Object decoded_string
;
3844 CHECK_STRING (string
);
3846 length
= SBYTES (string
);
3847 /* We need to allocate enough room for decoding the text. */
3848 if (length
<= MAX_ALLOCA
)
3849 decoded
= (char *) alloca (length
);
3851 decoded
= (char *) xmalloc (length
);
3853 /* The decoded result should be unibyte. */
3854 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3856 if (decoded_length
> length
)
3858 else if (decoded_length
>= 0)
3859 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3861 decoded_string
= Qnil
;
3863 if (length
> MAX_ALLOCA
)
3865 if (!STRINGP (decoded_string
))
3866 error ("Invalid base64 data");
3868 return decoded_string
;
3871 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3872 MULTIBYTE is nonzero, the decoded result should be in multibyte
3873 form. If NCHARS_RETRUN is not NULL, store the number of produced
3874 characters in *NCHARS_RETURN. */
3877 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3887 unsigned long value
;
3892 /* Process first byte of a quadruplet. */
3894 READ_QUADRUPLET_BYTE (e
-to
);
3898 value
= base64_char_to_value
[c
] << 18;
3900 /* Process second byte of a quadruplet. */
3902 READ_QUADRUPLET_BYTE (-1);
3906 value
|= base64_char_to_value
[c
] << 12;
3908 c
= (unsigned char) (value
>> 16);
3910 e
+= CHAR_STRING (c
, e
);
3915 /* Process third byte of a quadruplet. */
3917 READ_QUADRUPLET_BYTE (-1);
3921 READ_QUADRUPLET_BYTE (-1);
3930 value
|= base64_char_to_value
[c
] << 6;
3932 c
= (unsigned char) (0xff & value
>> 8);
3934 e
+= CHAR_STRING (c
, e
);
3939 /* Process fourth byte of a quadruplet. */
3941 READ_QUADRUPLET_BYTE (-1);
3948 value
|= base64_char_to_value
[c
];
3950 c
= (unsigned char) (0xff & value
);
3952 e
+= CHAR_STRING (c
, e
);
3961 /***********************************************************************
3963 ***** Hash Tables *****
3965 ***********************************************************************/
3967 /* Implemented by gerd@gnu.org. This hash table implementation was
3968 inspired by CMUCL hash tables. */
3972 1. For small tables, association lists are probably faster than
3973 hash tables because they have lower overhead.
3975 For uses of hash tables where the O(1) behavior of table
3976 operations is not a requirement, it might therefore be a good idea
3977 not to hash. Instead, we could just do a linear search in the
3978 key_and_value vector of the hash table. This could be done
3979 if a `:linear-search t' argument is given to make-hash-table. */
3982 /* The list of all weak hash tables. Don't staticpro this one. */
3984 Lisp_Object Vweak_hash_tables
;
3986 /* Various symbols. */
3988 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3989 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3990 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3992 /* Function prototypes. */
3994 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3995 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3996 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3997 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3998 Lisp_Object
, unsigned));
3999 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4000 Lisp_Object
, unsigned));
4001 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4002 unsigned, Lisp_Object
, unsigned));
4003 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4004 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4005 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4006 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4008 static unsigned sxhash_string
P_ ((unsigned char *, int));
4009 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4010 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4011 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4012 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4016 /***********************************************************************
4018 ***********************************************************************/
4020 /* If OBJ is a Lisp hash table, return a pointer to its struct
4021 Lisp_Hash_Table. Otherwise, signal an error. */
4023 static struct Lisp_Hash_Table
*
4024 check_hash_table (obj
)
4027 CHECK_HASH_TABLE (obj
);
4028 return XHASH_TABLE (obj
);
4032 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4036 next_almost_prime (n
)
4049 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4050 which USED[I] is non-zero. If found at index I in ARGS, set
4051 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4052 -1. This function is used to extract a keyword/argument pair from
4053 a DEFUN parameter list. */
4056 get_key_arg (key
, nargs
, args
, used
)
4064 for (i
= 0; i
< nargs
- 1; ++i
)
4065 if (!used
[i
] && EQ (args
[i
], key
))
4080 /* Return a Lisp vector which has the same contents as VEC but has
4081 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4082 vector that are not copied from VEC are set to INIT. */
4085 larger_vector (vec
, new_size
, init
)
4090 struct Lisp_Vector
*v
;
4093 xassert (VECTORP (vec
));
4094 old_size
= XVECTOR (vec
)->size
;
4095 xassert (new_size
>= old_size
);
4097 v
= allocate_vector (new_size
);
4098 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4099 old_size
* sizeof *v
->contents
);
4100 for (i
= old_size
; i
< new_size
; ++i
)
4101 v
->contents
[i
] = init
;
4102 XSETVECTOR (vec
, v
);
4107 /***********************************************************************
4109 ***********************************************************************/
4111 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4112 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4113 KEY2 are the same. */
4116 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4117 struct Lisp_Hash_Table
*h
;
4118 Lisp_Object key1
, key2
;
4119 unsigned hash1
, hash2
;
4121 return (FLOATP (key1
)
4123 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4127 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4128 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4129 KEY2 are the same. */
4132 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4133 struct Lisp_Hash_Table
*h
;
4134 Lisp_Object key1
, key2
;
4135 unsigned hash1
, hash2
;
4137 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4141 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4142 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4143 if KEY1 and KEY2 are the same. */
4146 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4147 struct Lisp_Hash_Table
*h
;
4148 Lisp_Object key1
, key2
;
4149 unsigned hash1
, hash2
;
4153 Lisp_Object args
[3];
4155 args
[0] = h
->user_cmp_function
;
4158 return !NILP (Ffuncall (3, args
));
4165 /* Value is a hash code for KEY for use in hash table H which uses
4166 `eq' to compare keys. The hash code returned is guaranteed to fit
4167 in a Lisp integer. */
4171 struct Lisp_Hash_Table
*h
;
4174 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4175 xassert ((hash
& ~VALMASK
) == 0);
4180 /* Value is a hash code for KEY for use in hash table H which uses
4181 `eql' to compare keys. The hash code returned is guaranteed to fit
4182 in a Lisp integer. */
4186 struct Lisp_Hash_Table
*h
;
4191 hash
= sxhash (key
, 0);
4193 hash
= XUINT (key
) ^ XGCTYPE (key
);
4194 xassert ((hash
& ~VALMASK
) == 0);
4199 /* Value is a hash code for KEY for use in hash table H which uses
4200 `equal' to compare keys. The hash code returned is guaranteed to fit
4201 in a Lisp integer. */
4204 hashfn_equal (h
, key
)
4205 struct Lisp_Hash_Table
*h
;
4208 unsigned hash
= sxhash (key
, 0);
4209 xassert ((hash
& ~VALMASK
) == 0);
4214 /* Value is a hash code for KEY for use in hash table H which uses as
4215 user-defined function to compare keys. The hash code returned is
4216 guaranteed to fit in a Lisp integer. */
4219 hashfn_user_defined (h
, key
)
4220 struct Lisp_Hash_Table
*h
;
4223 Lisp_Object args
[2], hash
;
4225 args
[0] = h
->user_hash_function
;
4227 hash
= Ffuncall (2, args
);
4228 if (!INTEGERP (hash
))
4230 list2 (build_string ("Invalid hash code returned from \
4231 user-supplied hash function"),
4233 return XUINT (hash
);
4237 /* Create and initialize a new hash table.
4239 TEST specifies the test the hash table will use to compare keys.
4240 It must be either one of the predefined tests `eq', `eql' or
4241 `equal' or a symbol denoting a user-defined test named TEST with
4242 test and hash functions USER_TEST and USER_HASH.
4244 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4246 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4247 new size when it becomes full is computed by adding REHASH_SIZE to
4248 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4249 table's new size is computed by multiplying its old size with
4252 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4253 be resized when the ratio of (number of entries in the table) /
4254 (table size) is >= REHASH_THRESHOLD.
4256 WEAK specifies the weakness of the table. If non-nil, it must be
4257 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4260 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4261 user_test
, user_hash
)
4262 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4263 Lisp_Object user_test
, user_hash
;
4265 struct Lisp_Hash_Table
*h
;
4267 int index_size
, i
, sz
;
4269 /* Preconditions. */
4270 xassert (SYMBOLP (test
));
4271 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4272 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4273 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4274 xassert (FLOATP (rehash_threshold
)
4275 && XFLOATINT (rehash_threshold
) > 0
4276 && XFLOATINT (rehash_threshold
) <= 1.0);
4278 if (XFASTINT (size
) == 0)
4279 size
= make_number (1);
4281 /* Allocate a table and initialize it. */
4282 h
= allocate_hash_table ();
4284 /* Initialize hash table slots. */
4285 sz
= XFASTINT (size
);
4288 if (EQ (test
, Qeql
))
4290 h
->cmpfn
= cmpfn_eql
;
4291 h
->hashfn
= hashfn_eql
;
4293 else if (EQ (test
, Qeq
))
4296 h
->hashfn
= hashfn_eq
;
4298 else if (EQ (test
, Qequal
))
4300 h
->cmpfn
= cmpfn_equal
;
4301 h
->hashfn
= hashfn_equal
;
4305 h
->user_cmp_function
= user_test
;
4306 h
->user_hash_function
= user_hash
;
4307 h
->cmpfn
= cmpfn_user_defined
;
4308 h
->hashfn
= hashfn_user_defined
;
4312 h
->rehash_threshold
= rehash_threshold
;
4313 h
->rehash_size
= rehash_size
;
4314 h
->count
= make_number (0);
4315 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4316 h
->hash
= Fmake_vector (size
, Qnil
);
4317 h
->next
= Fmake_vector (size
, Qnil
);
4318 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4319 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4320 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4322 /* Set up the free list. */
4323 for (i
= 0; i
< sz
- 1; ++i
)
4324 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4325 h
->next_free
= make_number (0);
4327 XSET_HASH_TABLE (table
, h
);
4328 xassert (HASH_TABLE_P (table
));
4329 xassert (XHASH_TABLE (table
) == h
);
4331 /* Maybe add this hash table to the list of all weak hash tables. */
4333 h
->next_weak
= Qnil
;
4336 h
->next_weak
= Vweak_hash_tables
;
4337 Vweak_hash_tables
= table
;
4344 /* Return a copy of hash table H1. Keys and values are not copied,
4345 only the table itself is. */
4348 copy_hash_table (h1
)
4349 struct Lisp_Hash_Table
*h1
;
4352 struct Lisp_Hash_Table
*h2
;
4353 struct Lisp_Vector
*next
;
4355 h2
= allocate_hash_table ();
4356 next
= h2
->vec_next
;
4357 bcopy (h1
, h2
, sizeof *h2
);
4358 h2
->vec_next
= next
;
4359 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4360 h2
->hash
= Fcopy_sequence (h1
->hash
);
4361 h2
->next
= Fcopy_sequence (h1
->next
);
4362 h2
->index
= Fcopy_sequence (h1
->index
);
4363 XSET_HASH_TABLE (table
, h2
);
4365 /* Maybe add this hash table to the list of all weak hash tables. */
4366 if (!NILP (h2
->weak
))
4368 h2
->next_weak
= Vweak_hash_tables
;
4369 Vweak_hash_tables
= table
;
4376 /* Resize hash table H if it's too full. If H cannot be resized
4377 because it's already too large, throw an error. */
4380 maybe_resize_hash_table (h
)
4381 struct Lisp_Hash_Table
*h
;
4383 if (NILP (h
->next_free
))
4385 int old_size
= HASH_TABLE_SIZE (h
);
4386 int i
, new_size
, index_size
;
4388 if (INTEGERP (h
->rehash_size
))
4389 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4391 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4392 new_size
= max (old_size
+ 1, new_size
);
4393 index_size
= next_almost_prime ((int)
4395 / XFLOATINT (h
->rehash_threshold
)));
4396 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4397 error ("Hash table too large to resize");
4399 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4400 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4401 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4402 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4404 /* Update the free list. Do it so that new entries are added at
4405 the end of the free list. This makes some operations like
4407 for (i
= old_size
; i
< new_size
- 1; ++i
)
4408 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4410 if (!NILP (h
->next_free
))
4412 Lisp_Object last
, next
;
4414 last
= h
->next_free
;
4415 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4419 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4422 XSETFASTINT (h
->next_free
, old_size
);
4425 for (i
= 0; i
< old_size
; ++i
)
4426 if (!NILP (HASH_HASH (h
, i
)))
4428 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4429 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4430 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4431 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4437 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4438 the hash code of KEY. Value is the index of the entry in H
4439 matching KEY, or -1 if not found. */
4442 hash_lookup (h
, key
, hash
)
4443 struct Lisp_Hash_Table
*h
;
4448 int start_of_bucket
;
4451 hash_code
= h
->hashfn (h
, key
);
4455 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4456 idx
= HASH_INDEX (h
, start_of_bucket
);
4458 /* We need not gcpro idx since it's either an integer or nil. */
4461 int i
= XFASTINT (idx
);
4462 if (EQ (key
, HASH_KEY (h
, i
))
4464 && h
->cmpfn (h
, key
, hash_code
,
4465 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4467 idx
= HASH_NEXT (h
, i
);
4470 return NILP (idx
) ? -1 : XFASTINT (idx
);
4474 /* Put an entry into hash table H that associates KEY with VALUE.
4475 HASH is a previously computed hash code of KEY.
4476 Value is the index of the entry in H matching KEY. */
4479 hash_put (h
, key
, value
, hash
)
4480 struct Lisp_Hash_Table
*h
;
4481 Lisp_Object key
, value
;
4484 int start_of_bucket
, i
;
4486 xassert ((hash
& ~VALMASK
) == 0);
4488 /* Increment count after resizing because resizing may fail. */
4489 maybe_resize_hash_table (h
);
4490 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4492 /* Store key/value in the key_and_value vector. */
4493 i
= XFASTINT (h
->next_free
);
4494 h
->next_free
= HASH_NEXT (h
, i
);
4495 HASH_KEY (h
, i
) = key
;
4496 HASH_VALUE (h
, i
) = value
;
4498 /* Remember its hash code. */
4499 HASH_HASH (h
, i
) = make_number (hash
);
4501 /* Add new entry to its collision chain. */
4502 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4503 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4504 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4509 /* Remove the entry matching KEY from hash table H, if there is one. */
4512 hash_remove (h
, key
)
4513 struct Lisp_Hash_Table
*h
;
4517 int start_of_bucket
;
4518 Lisp_Object idx
, prev
;
4520 hash_code
= h
->hashfn (h
, key
);
4521 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4522 idx
= HASH_INDEX (h
, start_of_bucket
);
4525 /* We need not gcpro idx, prev since they're either integers or nil. */
4528 int i
= XFASTINT (idx
);
4530 if (EQ (key
, HASH_KEY (h
, i
))
4532 && h
->cmpfn (h
, key
, hash_code
,
4533 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4535 /* Take entry out of collision chain. */
4537 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4539 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4541 /* Clear slots in key_and_value and add the slots to
4543 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4544 HASH_NEXT (h
, i
) = h
->next_free
;
4545 h
->next_free
= make_number (i
);
4546 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4547 xassert (XINT (h
->count
) >= 0);
4553 idx
= HASH_NEXT (h
, i
);
4559 /* Clear hash table H. */
4563 struct Lisp_Hash_Table
*h
;
4565 if (XFASTINT (h
->count
) > 0)
4567 int i
, size
= HASH_TABLE_SIZE (h
);
4569 for (i
= 0; i
< size
; ++i
)
4571 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4572 HASH_KEY (h
, i
) = Qnil
;
4573 HASH_VALUE (h
, i
) = Qnil
;
4574 HASH_HASH (h
, i
) = Qnil
;
4577 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4578 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4580 h
->next_free
= make_number (0);
4581 h
->count
= make_number (0);
4587 /************************************************************************
4589 ************************************************************************/
4591 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4592 entries from the table that don't survive the current GC.
4593 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4594 non-zero if anything was marked. */
4597 sweep_weak_table (h
, remove_entries_p
)
4598 struct Lisp_Hash_Table
*h
;
4599 int remove_entries_p
;
4601 int bucket
, n
, marked
;
4603 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4606 for (bucket
= 0; bucket
< n
; ++bucket
)
4608 Lisp_Object idx
, next
, prev
;
4610 /* Follow collision chain, removing entries that
4611 don't survive this garbage collection. */
4613 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4615 int i
= XFASTINT (idx
);
4616 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4617 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4620 if (EQ (h
->weak
, Qkey
))
4621 remove_p
= !key_known_to_survive_p
;
4622 else if (EQ (h
->weak
, Qvalue
))
4623 remove_p
= !value_known_to_survive_p
;
4624 else if (EQ (h
->weak
, Qkey_or_value
))
4625 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4626 else if (EQ (h
->weak
, Qkey_and_value
))
4627 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4631 next
= HASH_NEXT (h
, i
);
4633 if (remove_entries_p
)
4637 /* Take out of collision chain. */
4639 HASH_INDEX (h
, bucket
) = next
;
4641 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4643 /* Add to free list. */
4644 HASH_NEXT (h
, i
) = h
->next_free
;
4647 /* Clear key, value, and hash. */
4648 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4649 HASH_HASH (h
, i
) = Qnil
;
4651 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4658 /* Make sure key and value survive. */
4659 if (!key_known_to_survive_p
)
4661 mark_object (&HASH_KEY (h
, i
));
4665 if (!value_known_to_survive_p
)
4667 mark_object (&HASH_VALUE (h
, i
));
4678 /* Remove elements from weak hash tables that don't survive the
4679 current garbage collection. Remove weak tables that don't survive
4680 from Vweak_hash_tables. Called from gc_sweep. */
4683 sweep_weak_hash_tables ()
4685 Lisp_Object table
, used
, next
;
4686 struct Lisp_Hash_Table
*h
;
4689 /* Mark all keys and values that are in use. Keep on marking until
4690 there is no more change. This is necessary for cases like
4691 value-weak table A containing an entry X -> Y, where Y is used in a
4692 key-weak table B, Z -> Y. If B comes after A in the list of weak
4693 tables, X -> Y might be removed from A, although when looking at B
4694 one finds that it shouldn't. */
4698 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4700 h
= XHASH_TABLE (table
);
4701 if (h
->size
& ARRAY_MARK_FLAG
)
4702 marked
|= sweep_weak_table (h
, 0);
4707 /* Remove tables and entries that aren't used. */
4708 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4710 h
= XHASH_TABLE (table
);
4711 next
= h
->next_weak
;
4713 if (h
->size
& ARRAY_MARK_FLAG
)
4715 /* TABLE is marked as used. Sweep its contents. */
4716 if (XFASTINT (h
->count
) > 0)
4717 sweep_weak_table (h
, 1);
4719 /* Add table to the list of used weak hash tables. */
4720 h
->next_weak
= used
;
4725 Vweak_hash_tables
= used
;
4730 /***********************************************************************
4731 Hash Code Computation
4732 ***********************************************************************/
4734 /* Maximum depth up to which to dive into Lisp structures. */
4736 #define SXHASH_MAX_DEPTH 3
4738 /* Maximum length up to which to take list and vector elements into
4741 #define SXHASH_MAX_LEN 7
4743 /* Combine two integers X and Y for hashing. */
4745 #define SXHASH_COMBINE(X, Y) \
4746 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4750 /* Return a hash for string PTR which has length LEN. The hash
4751 code returned is guaranteed to fit in a Lisp integer. */
4754 sxhash_string (ptr
, len
)
4758 unsigned char *p
= ptr
;
4759 unsigned char *end
= p
+ len
;
4768 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4771 return hash
& VALMASK
;
4775 /* Return a hash for list LIST. DEPTH is the current depth in the
4776 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4779 sxhash_list (list
, depth
)
4786 if (depth
< SXHASH_MAX_DEPTH
)
4788 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4789 list
= XCDR (list
), ++i
)
4791 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4792 hash
= SXHASH_COMBINE (hash
, hash2
);
4799 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4800 the Lisp structure. */
4803 sxhash_vector (vec
, depth
)
4807 unsigned hash
= XVECTOR (vec
)->size
;
4810 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4811 for (i
= 0; i
< n
; ++i
)
4813 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4814 hash
= SXHASH_COMBINE (hash
, hash2
);
4821 /* Return a hash for bool-vector VECTOR. */
4824 sxhash_bool_vector (vec
)
4827 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4830 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4831 for (i
= 0; i
< n
; ++i
)
4832 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4838 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4839 structure. Value is an unsigned integer clipped to VALMASK. */
4848 if (depth
> SXHASH_MAX_DEPTH
)
4851 switch (XTYPE (obj
))
4858 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4859 SCHARS (SYMBOL_NAME (obj
)));
4867 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4870 /* This can be everything from a vector to an overlay. */
4871 case Lisp_Vectorlike
:
4873 /* According to the CL HyperSpec, two arrays are equal only if
4874 they are `eq', except for strings and bit-vectors. In
4875 Emacs, this works differently. We have to compare element
4877 hash
= sxhash_vector (obj
, depth
);
4878 else if (BOOL_VECTOR_P (obj
))
4879 hash
= sxhash_bool_vector (obj
);
4881 /* Others are `equal' if they are `eq', so let's take their
4887 hash
= sxhash_list (obj
, depth
);
4892 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4893 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4894 for (hash
= 0; p
< e
; ++p
)
4895 hash
= SXHASH_COMBINE (hash
, *p
);
4903 return hash
& VALMASK
;
4908 /***********************************************************************
4910 ***********************************************************************/
4913 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4914 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4918 unsigned hash
= sxhash (obj
, 0);;
4919 return make_number (hash
);
4923 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4924 doc
: /* Create and return a new hash table.
4926 Arguments are specified as keyword/argument pairs. The following
4927 arguments are defined:
4929 :test TEST -- TEST must be a symbol that specifies how to compare
4930 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4931 `equal'. User-supplied test and hash functions can be specified via
4932 `define-hash-table-test'.
4934 :size SIZE -- A hint as to how many elements will be put in the table.
4937 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4938 fills up. If REHASH-SIZE is an integer, add that many space. If it
4939 is a float, it must be > 1.0, and the new size is computed by
4940 multiplying the old size with that factor. Default is 1.5.
4942 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4943 Resize the hash table when ratio of the number of entries in the
4944 table. Default is 0.8.
4946 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4947 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4948 returned is a weak table. Key/value pairs are removed from a weak
4949 hash table when there are no non-weak references pointing to their
4950 key, value, one of key or value, or both key and value, depending on
4951 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4954 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4959 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4960 Lisp_Object user_test
, user_hash
;
4964 /* The vector `used' is used to keep track of arguments that
4965 have been consumed. */
4966 used
= (char *) alloca (nargs
* sizeof *used
);
4967 bzero (used
, nargs
* sizeof *used
);
4969 /* See if there's a `:test TEST' among the arguments. */
4970 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4971 test
= i
< 0 ? Qeql
: args
[i
];
4972 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4974 /* See if it is a user-defined test. */
4977 prop
= Fget (test
, Qhash_table_test
);
4978 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4979 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4981 user_test
= XCAR (prop
);
4982 user_hash
= XCAR (XCDR (prop
));
4985 user_test
= user_hash
= Qnil
;
4987 /* See if there's a `:size SIZE' argument. */
4988 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4989 size
= i
< 0 ? Qnil
: args
[i
];
4991 size
= make_number (DEFAULT_HASH_SIZE
);
4992 else if (!INTEGERP (size
) || XINT (size
) < 0)
4994 list2 (build_string ("Invalid hash table size"),
4997 /* Look for `:rehash-size SIZE'. */
4998 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4999 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5000 if (!NUMBERP (rehash_size
)
5001 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5002 || XFLOATINT (rehash_size
) <= 1.0)
5004 list2 (build_string ("Invalid hash table rehash size"),
5007 /* Look for `:rehash-threshold THRESHOLD'. */
5008 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5009 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5010 if (!FLOATP (rehash_threshold
)
5011 || XFLOATINT (rehash_threshold
) <= 0.0
5012 || XFLOATINT (rehash_threshold
) > 1.0)
5014 list2 (build_string ("Invalid hash table rehash threshold"),
5017 /* Look for `:weakness WEAK'. */
5018 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5019 weak
= i
< 0 ? Qnil
: args
[i
];
5021 weak
= Qkey_and_value
;
5024 && !EQ (weak
, Qvalue
)
5025 && !EQ (weak
, Qkey_or_value
)
5026 && !EQ (weak
, Qkey_and_value
))
5027 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5030 /* Now, all args should have been used up, or there's a problem. */
5031 for (i
= 0; i
< nargs
; ++i
)
5034 list2 (build_string ("Invalid argument list"), args
[i
]));
5036 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5037 user_test
, user_hash
);
5041 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5042 doc
: /* Return a copy of hash table TABLE. */)
5046 return copy_hash_table (check_hash_table (table
));
5050 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5051 doc
: /* Return the number of elements in TABLE. */)
5055 return check_hash_table (table
)->count
;
5059 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5060 Shash_table_rehash_size
, 1, 1, 0,
5061 doc
: /* Return the current rehash size of TABLE. */)
5065 return check_hash_table (table
)->rehash_size
;
5069 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5070 Shash_table_rehash_threshold
, 1, 1, 0,
5071 doc
: /* Return the current rehash threshold of TABLE. */)
5075 return check_hash_table (table
)->rehash_threshold
;
5079 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5080 doc
: /* Return the size of TABLE.
5081 The size can be used as an argument to `make-hash-table' to create
5082 a hash table than can hold as many elements of TABLE holds
5083 without need for resizing. */)
5087 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5088 return make_number (HASH_TABLE_SIZE (h
));
5092 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5093 doc
: /* Return the test TABLE uses. */)
5097 return check_hash_table (table
)->test
;
5101 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5103 doc
: /* Return the weakness of TABLE. */)
5107 return check_hash_table (table
)->weak
;
5111 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5112 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5116 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5120 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5121 doc
: /* Clear hash table TABLE. */)
5125 hash_clear (check_hash_table (table
));
5130 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5131 doc
: /* Look up KEY in TABLE and return its associated value.
5132 If KEY is not found, return DFLT which defaults to nil. */)
5134 Lisp_Object key
, table
, dflt
;
5136 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5137 int i
= hash_lookup (h
, key
, NULL
);
5138 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5142 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5143 doc
: /* Associate KEY with VALUE in hash table TABLE.
5144 If KEY is already present in table, replace its current value with
5147 Lisp_Object key
, value
, table
;
5149 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5153 i
= hash_lookup (h
, key
, &hash
);
5155 HASH_VALUE (h
, i
) = value
;
5157 hash_put (h
, key
, value
, hash
);
5163 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5164 doc
: /* Remove KEY from TABLE. */)
5166 Lisp_Object key
, table
;
5168 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5169 hash_remove (h
, key
);
5174 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5175 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5176 FUNCTION is called with 2 arguments KEY and VALUE. */)
5178 Lisp_Object function
, table
;
5180 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5181 Lisp_Object args
[3];
5184 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5185 if (!NILP (HASH_HASH (h
, i
)))
5188 args
[1] = HASH_KEY (h
, i
);
5189 args
[2] = HASH_VALUE (h
, i
);
5197 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5198 Sdefine_hash_table_test
, 3, 3, 0,
5199 doc
: /* Define a new hash table test with name NAME, a symbol.
5201 In hash tables created with NAME specified as test, use TEST to
5202 compare keys, and HASH for computing hash codes of keys.
5204 TEST must be a function taking two arguments and returning non-nil if
5205 both arguments are the same. HASH must be a function taking one
5206 argument and return an integer that is the hash code of the argument.
5207 Hash code computation should use the whole value range of integers,
5208 including negative integers. */)
5210 Lisp_Object name
, test
, hash
;
5212 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5217 /************************************************************************
5219 ************************************************************************/
5224 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5225 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5227 A message digest is a cryptographic checksum of a document, and the
5228 algorithm to calculate it is defined in RFC 1321.
5230 The two optional arguments START and END are character positions
5231 specifying for which part of OBJECT the message digest should be
5232 computed. If nil or omitted, the digest is computed for the whole
5235 The MD5 message digest is computed from the result of encoding the
5236 text in a coding system, not directly from the internal Emacs form of
5237 the text. The optional fourth argument CODING-SYSTEM specifies which
5238 coding system to encode the text with. It should be the same coding
5239 system that you used or will use when actually writing the text into a
5242 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5243 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5244 system would be chosen by default for writing this text into a file.
5246 If OBJECT is a string, the most preferred coding system (see the
5247 command `prefer-coding-system') is used.
5249 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5250 guesswork fails. Normally, an error is signaled in such case. */)
5251 (object
, start
, end
, coding_system
, noerror
)
5252 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5254 unsigned char digest
[16];
5255 unsigned char value
[33];
5259 int start_char
= 0, end_char
= 0;
5260 int start_byte
= 0, end_byte
= 0;
5262 register struct buffer
*bp
;
5265 if (STRINGP (object
))
5267 if (NILP (coding_system
))
5269 /* Decide the coding-system to encode the data with. */
5271 if (STRING_MULTIBYTE (object
))
5272 /* use default, we can't guess correct value */
5273 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5275 coding_system
= Qraw_text
;
5278 if (NILP (Fcoding_system_p (coding_system
)))
5280 /* Invalid coding system. */
5282 if (!NILP (noerror
))
5283 coding_system
= Qraw_text
;
5286 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5289 if (STRING_MULTIBYTE (object
))
5290 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5292 size
= SCHARS (object
);
5293 size_byte
= SBYTES (object
);
5297 CHECK_NUMBER (start
);
5299 start_char
= XINT (start
);
5304 start_byte
= string_char_to_byte (object
, start_char
);
5310 end_byte
= size_byte
;
5316 end_char
= XINT (end
);
5321 end_byte
= string_char_to_byte (object
, end_char
);
5324 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5325 args_out_of_range_3 (object
, make_number (start_char
),
5326 make_number (end_char
));
5330 CHECK_BUFFER (object
);
5332 bp
= XBUFFER (object
);
5338 CHECK_NUMBER_COERCE_MARKER (start
);
5346 CHECK_NUMBER_COERCE_MARKER (end
);
5351 temp
= b
, b
= e
, e
= temp
;
5353 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5354 args_out_of_range (start
, end
);
5356 if (NILP (coding_system
))
5358 /* Decide the coding-system to encode the data with.
5359 See fileio.c:Fwrite-region */
5361 if (!NILP (Vcoding_system_for_write
))
5362 coding_system
= Vcoding_system_for_write
;
5365 int force_raw_text
= 0;
5367 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5368 if (NILP (coding_system
)
5369 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5371 coding_system
= Qnil
;
5372 if (NILP (current_buffer
->enable_multibyte_characters
))
5376 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5378 /* Check file-coding-system-alist. */
5379 Lisp_Object args
[4], val
;
5381 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5382 args
[3] = Fbuffer_file_name(object
);
5383 val
= Ffind_operation_coding_system (4, args
);
5384 if (CONSP (val
) && !NILP (XCDR (val
)))
5385 coding_system
= XCDR (val
);
5388 if (NILP (coding_system
)
5389 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5391 /* If we still have not decided a coding system, use the
5392 default value of buffer-file-coding-system. */
5393 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5397 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5398 /* Confirm that VAL can surely encode the current region. */
5399 coding_system
= call4 (Vselect_safe_coding_system_function
,
5400 make_number (b
), make_number (e
),
5401 coding_system
, Qnil
);
5404 coding_system
= Qraw_text
;
5407 if (NILP (Fcoding_system_p (coding_system
)))
5409 /* Invalid coding system. */
5411 if (!NILP (noerror
))
5412 coding_system
= Qraw_text
;
5415 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5419 object
= make_buffer_string (b
, e
, 0);
5421 if (STRING_MULTIBYTE (object
))
5422 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5425 md5_buffer (SDATA (object
) + start_byte
,
5426 SBYTES (object
) - (size_byte
- end_byte
),
5429 for (i
= 0; i
< 16; i
++)
5430 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5433 return make_string (value
, 32);
5440 /* Hash table stuff. */
5441 Qhash_table_p
= intern ("hash-table-p");
5442 staticpro (&Qhash_table_p
);
5443 Qeq
= intern ("eq");
5445 Qeql
= intern ("eql");
5447 Qequal
= intern ("equal");
5448 staticpro (&Qequal
);
5449 QCtest
= intern (":test");
5450 staticpro (&QCtest
);
5451 QCsize
= intern (":size");
5452 staticpro (&QCsize
);
5453 QCrehash_size
= intern (":rehash-size");
5454 staticpro (&QCrehash_size
);
5455 QCrehash_threshold
= intern (":rehash-threshold");
5456 staticpro (&QCrehash_threshold
);
5457 QCweakness
= intern (":weakness");
5458 staticpro (&QCweakness
);
5459 Qkey
= intern ("key");
5461 Qvalue
= intern ("value");
5462 staticpro (&Qvalue
);
5463 Qhash_table_test
= intern ("hash-table-test");
5464 staticpro (&Qhash_table_test
);
5465 Qkey_or_value
= intern ("key-or-value");
5466 staticpro (&Qkey_or_value
);
5467 Qkey_and_value
= intern ("key-and-value");
5468 staticpro (&Qkey_and_value
);
5471 defsubr (&Smake_hash_table
);
5472 defsubr (&Scopy_hash_table
);
5473 defsubr (&Shash_table_count
);
5474 defsubr (&Shash_table_rehash_size
);
5475 defsubr (&Shash_table_rehash_threshold
);
5476 defsubr (&Shash_table_size
);
5477 defsubr (&Shash_table_test
);
5478 defsubr (&Shash_table_weakness
);
5479 defsubr (&Shash_table_p
);
5480 defsubr (&Sclrhash
);
5481 defsubr (&Sgethash
);
5482 defsubr (&Sputhash
);
5483 defsubr (&Sremhash
);
5484 defsubr (&Smaphash
);
5485 defsubr (&Sdefine_hash_table_test
);
5487 Qstring_lessp
= intern ("string-lessp");
5488 staticpro (&Qstring_lessp
);
5489 Qprovide
= intern ("provide");
5490 staticpro (&Qprovide
);
5491 Qrequire
= intern ("require");
5492 staticpro (&Qrequire
);
5493 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5494 staticpro (&Qyes_or_no_p_history
);
5495 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5496 staticpro (&Qcursor_in_echo_area
);
5497 Qwidget_type
= intern ("widget-type");
5498 staticpro (&Qwidget_type
);
5500 staticpro (&string_char_byte_cache_string
);
5501 string_char_byte_cache_string
= Qnil
;
5503 require_nesting_list
= Qnil
;
5504 staticpro (&require_nesting_list
);
5506 Fset (Qyes_or_no_p_history
, Qnil
);
5508 DEFVAR_LISP ("features", &Vfeatures
,
5509 doc
: /* A list of symbols which are the features of the executing emacs.
5510 Used by `featurep' and `require', and altered by `provide'. */);
5512 Qsubfeatures
= intern ("subfeatures");
5513 staticpro (&Qsubfeatures
);
5515 #ifdef HAVE_LANGINFO_CODESET
5516 Qcodeset
= intern ("codeset");
5517 staticpro (&Qcodeset
);
5518 Qdays
= intern ("days");
5520 Qmonths
= intern ("months");
5521 staticpro (&Qmonths
);
5522 Qpaper
= intern ("paper");
5523 staticpro (&Qpaper
);
5524 #endif /* HAVE_LANGINFO_CODESET */
5526 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5527 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5528 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5529 invoked by mouse clicks and mouse menu items. */);
5532 defsubr (&Sidentity
);
5535 defsubr (&Ssafe_length
);
5536 defsubr (&Sstring_bytes
);
5537 defsubr (&Sstring_equal
);
5538 defsubr (&Scompare_strings
);
5539 defsubr (&Sstring_lessp
);
5542 defsubr (&Svconcat
);
5543 defsubr (&Scopy_sequence
);
5544 defsubr (&Sstring_make_multibyte
);
5545 defsubr (&Sstring_make_unibyte
);
5546 defsubr (&Sstring_as_multibyte
);
5547 defsubr (&Sstring_as_unibyte
);
5548 defsubr (&Scopy_alist
);
5549 defsubr (&Ssubstring
);
5550 defsubr (&Ssubstring_no_properties
);
5562 defsubr (&Snreverse
);
5563 defsubr (&Sreverse
);
5565 defsubr (&Splist_get
);
5567 defsubr (&Splist_put
);
5569 defsubr (&Slax_plist_get
);
5570 defsubr (&Slax_plist_put
);
5572 defsubr (&Sfillarray
);
5573 defsubr (&Schar_table_subtype
);
5574 defsubr (&Schar_table_parent
);
5575 defsubr (&Sset_char_table_parent
);
5576 defsubr (&Schar_table_extra_slot
);
5577 defsubr (&Sset_char_table_extra_slot
);
5578 defsubr (&Schar_table_range
);
5579 defsubr (&Sset_char_table_range
);
5580 defsubr (&Sset_char_table_default
);
5581 defsubr (&Soptimize_char_table
);
5582 defsubr (&Smap_char_table
);
5586 defsubr (&Smapconcat
);
5587 defsubr (&Sy_or_n_p
);
5588 defsubr (&Syes_or_no_p
);
5589 defsubr (&Sload_average
);
5590 defsubr (&Sfeaturep
);
5591 defsubr (&Srequire
);
5592 defsubr (&Sprovide
);
5593 defsubr (&Splist_member
);
5594 defsubr (&Swidget_put
);
5595 defsubr (&Swidget_get
);
5596 defsubr (&Swidget_apply
);
5597 defsubr (&Sbase64_encode_region
);
5598 defsubr (&Sbase64_decode_region
);
5599 defsubr (&Sbase64_encode_string
);
5600 defsubr (&Sbase64_decode_string
);
5602 defsubr (&Slanginfo
);
5609 Vweak_hash_tables
= Qnil
;