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 If FROM or TO 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
))
1818 new = Fcons (XCAR (list
), new);
1820 wrong_type_argument (Qconsp
, list
);
1824 Lisp_Object
merge ();
1826 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1827 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1828 Returns the sorted list. LIST is modified by side effects.
1829 PREDICATE is called with two elements of LIST, and should return t
1830 if the first element is "less" than the second. */)
1832 Lisp_Object list
, predicate
;
1834 Lisp_Object front
, back
;
1835 register Lisp_Object len
, tem
;
1836 struct gcpro gcpro1
, gcpro2
;
1837 register int length
;
1840 len
= Flength (list
);
1841 length
= XINT (len
);
1845 XSETINT (len
, (length
/ 2) - 1);
1846 tem
= Fnthcdr (len
, list
);
1848 Fsetcdr (tem
, Qnil
);
1850 GCPRO2 (front
, back
);
1851 front
= Fsort (front
, predicate
);
1852 back
= Fsort (back
, predicate
);
1854 return merge (front
, back
, predicate
);
1858 merge (org_l1
, org_l2
, pred
)
1859 Lisp_Object org_l1
, org_l2
;
1863 register Lisp_Object tail
;
1865 register Lisp_Object l1
, l2
;
1866 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1873 /* It is sufficient to protect org_l1 and org_l2.
1874 When l1 and l2 are updated, we copy the new values
1875 back into the org_ vars. */
1876 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1896 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1912 Fsetcdr (tail
, tem
);
1918 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1919 doc
: /* Extract a value from a property list.
1920 PLIST is a property list, which is a list of the form
1921 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1922 corresponding to the given PROP, or nil if PROP is not
1923 one of the properties on the list. */)
1931 CONSP (tail
) && CONSP (XCDR (tail
));
1932 tail
= XCDR (XCDR (tail
)))
1934 if (EQ (prop
, XCAR (tail
)))
1935 return XCAR (XCDR (tail
));
1937 /* This function can be called asynchronously
1938 (setup_coding_system). Don't QUIT in that case. */
1939 if (!interrupt_input_blocked
)
1944 wrong_type_argument (Qlistp
, prop
);
1949 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1950 doc
: /* Return the value of SYMBOL's PROPNAME property.
1951 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1953 Lisp_Object symbol
, propname
;
1955 CHECK_SYMBOL (symbol
);
1956 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1959 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1960 doc
: /* Change value in PLIST of PROP to VAL.
1961 PLIST is a property list, which is a list of the form
1962 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1963 If PROP is already a property on the list, its value is set to VAL,
1964 otherwise the new PROP VAL pair is added. The new plist is returned;
1965 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1966 The PLIST is modified by side effects. */)
1969 register Lisp_Object prop
;
1972 register Lisp_Object tail
, prev
;
1973 Lisp_Object newcell
;
1975 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1976 tail
= XCDR (XCDR (tail
)))
1978 if (EQ (prop
, XCAR (tail
)))
1980 Fsetcar (XCDR (tail
), val
);
1987 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1991 Fsetcdr (XCDR (prev
), newcell
);
1995 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1996 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1997 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1998 (symbol
, propname
, value
)
1999 Lisp_Object symbol
, propname
, value
;
2001 CHECK_SYMBOL (symbol
);
2002 XSYMBOL (symbol
)->plist
2003 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2007 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2008 doc
: /* Extract a value from a property list, comparing with `equal'.
2009 PLIST is a property list, which is a list of the form
2010 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2011 corresponding to the given PROP, or nil if PROP is not
2012 one of the properties on the list. */)
2020 CONSP (tail
) && CONSP (XCDR (tail
));
2021 tail
= XCDR (XCDR (tail
)))
2023 if (! NILP (Fequal (prop
, XCAR (tail
))))
2024 return XCAR (XCDR (tail
));
2030 wrong_type_argument (Qlistp
, prop
);
2035 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2036 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2037 PLIST is a property list, which is a list of the form
2038 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2039 If PROP is already a property on the list, its value is set to VAL,
2040 otherwise the new PROP VAL pair is added. The new plist is returned;
2041 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2042 The PLIST is modified by side effects. */)
2045 register Lisp_Object prop
;
2048 register Lisp_Object tail
, prev
;
2049 Lisp_Object newcell
;
2051 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2052 tail
= XCDR (XCDR (tail
)))
2054 if (! NILP (Fequal (prop
, XCAR (tail
))))
2056 Fsetcar (XCDR (tail
), val
);
2063 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2067 Fsetcdr (XCDR (prev
), newcell
);
2071 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2072 doc
: /* Return t if two Lisp objects have similar structure and contents.
2073 They must have the same data type.
2074 Conses are compared by comparing the cars and the cdrs.
2075 Vectors and strings are compared element by element.
2076 Numbers are compared by value, but integers cannot equal floats.
2077 (Use `=' if you want integers and floats to be able to be equal.)
2078 Symbols must match exactly. */)
2080 register Lisp_Object o1
, o2
;
2082 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2086 internal_equal (o1
, o2
, depth
)
2087 register Lisp_Object o1
, o2
;
2091 error ("Stack overflow in equal");
2097 if (XTYPE (o1
) != XTYPE (o2
))
2103 return (extract_float (o1
) == extract_float (o2
));
2106 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2113 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2117 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2119 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2122 o1
= XOVERLAY (o1
)->plist
;
2123 o2
= XOVERLAY (o2
)->plist
;
2128 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2129 && (XMARKER (o1
)->buffer
== 0
2130 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2134 case Lisp_Vectorlike
:
2136 register int i
, size
;
2137 size
= XVECTOR (o1
)->size
;
2138 /* Pseudovectors have the type encoded in the size field, so this test
2139 actually checks that the objects have the same type as well as the
2141 if (XVECTOR (o2
)->size
!= size
)
2143 /* Boolvectors are compared much like strings. */
2144 if (BOOL_VECTOR_P (o1
))
2147 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2149 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2151 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2156 if (WINDOW_CONFIGURATIONP (o1
))
2157 return compare_window_configurations (o1
, o2
, 0);
2159 /* Aside from them, only true vectors, char-tables, and compiled
2160 functions are sensible to compare, so eliminate the others now. */
2161 if (size
& PSEUDOVECTOR_FLAG
)
2163 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2165 size
&= PSEUDOVECTOR_SIZE_MASK
;
2167 for (i
= 0; i
< size
; i
++)
2170 v1
= XVECTOR (o1
)->contents
[i
];
2171 v2
= XVECTOR (o2
)->contents
[i
];
2172 if (!internal_equal (v1
, v2
, depth
+ 1))
2180 if (SCHARS (o1
) != SCHARS (o2
))
2182 if (SBYTES (o1
) != SBYTES (o2
))
2184 if (bcmp (SDATA (o1
), SDATA (o2
),
2191 case Lisp_Type_Limit
:
2198 extern Lisp_Object
Fmake_char_internal ();
2200 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2201 doc
: /* Store each element of ARRAY with ITEM.
2202 ARRAY is a vector, string, char-table, or bool-vector. */)
2204 Lisp_Object array
, item
;
2206 register int size
, index
, charval
;
2208 if (VECTORP (array
))
2210 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2211 size
= XVECTOR (array
)->size
;
2212 for (index
= 0; index
< size
; index
++)
2215 else if (CHAR_TABLE_P (array
))
2217 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2218 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2219 for (index
= 0; index
< size
; index
++)
2221 XCHAR_TABLE (array
)->defalt
= Qnil
;
2223 else if (STRINGP (array
))
2225 register unsigned char *p
= SDATA (array
);
2226 CHECK_NUMBER (item
);
2227 charval
= XINT (item
);
2228 size
= SCHARS (array
);
2229 if (STRING_MULTIBYTE (array
))
2231 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2232 int len
= CHAR_STRING (charval
, str
);
2233 int size_byte
= SBYTES (array
);
2234 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2237 if (size
!= size_byte
)
2240 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2241 if (len
!= this_len
)
2242 error ("Attempt to change byte length of a string");
2245 for (i
= 0; i
< size_byte
; i
++)
2246 *p
++ = str
[i
% len
];
2249 for (index
= 0; index
< size
; index
++)
2252 else if (BOOL_VECTOR_P (array
))
2254 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2256 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2258 charval
= (! NILP (item
) ? -1 : 0);
2259 for (index
= 0; index
< size_in_chars
; index
++)
2264 array
= wrong_type_argument (Qarrayp
, array
);
2270 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2272 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2274 Lisp_Object char_table
;
2276 CHECK_CHAR_TABLE (char_table
);
2278 return XCHAR_TABLE (char_table
)->purpose
;
2281 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2283 doc
: /* Return the parent char-table of CHAR-TABLE.
2284 The value is either nil or another char-table.
2285 If CHAR-TABLE holds nil for a given character,
2286 then the actual applicable value is inherited from the parent char-table
2287 \(or from its parents, if necessary). */)
2289 Lisp_Object char_table
;
2291 CHECK_CHAR_TABLE (char_table
);
2293 return XCHAR_TABLE (char_table
)->parent
;
2296 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2298 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2299 PARENT must be either nil or another char-table. */)
2300 (char_table
, parent
)
2301 Lisp_Object char_table
, parent
;
2305 CHECK_CHAR_TABLE (char_table
);
2309 CHECK_CHAR_TABLE (parent
);
2311 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2312 if (EQ (temp
, char_table
))
2313 error ("Attempt to make a chartable be its own parent");
2316 XCHAR_TABLE (char_table
)->parent
= parent
;
2321 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2323 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2325 Lisp_Object char_table
, n
;
2327 CHECK_CHAR_TABLE (char_table
);
2330 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2331 args_out_of_range (char_table
, n
);
2333 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2336 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2337 Sset_char_table_extra_slot
,
2339 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2340 (char_table
, n
, value
)
2341 Lisp_Object char_table
, n
, value
;
2343 CHECK_CHAR_TABLE (char_table
);
2346 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2347 args_out_of_range (char_table
, n
);
2349 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2352 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2354 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2355 RANGE should be nil (for the default value)
2356 a vector which identifies a character set or a row of a character set,
2357 a character set name, or a character code. */)
2359 Lisp_Object char_table
, range
;
2361 CHECK_CHAR_TABLE (char_table
);
2363 if (EQ (range
, Qnil
))
2364 return XCHAR_TABLE (char_table
)->defalt
;
2365 else if (INTEGERP (range
))
2366 return Faref (char_table
, range
);
2367 else if (SYMBOLP (range
))
2369 Lisp_Object charset_info
;
2371 charset_info
= Fget (range
, Qcharset
);
2372 CHECK_VECTOR (charset_info
);
2374 return Faref (char_table
,
2375 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2378 else if (VECTORP (range
))
2380 if (XVECTOR (range
)->size
== 1)
2381 return Faref (char_table
,
2382 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2385 int size
= XVECTOR (range
)->size
;
2386 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2387 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2388 size
<= 1 ? Qnil
: val
[1],
2389 size
<= 2 ? Qnil
: val
[2]);
2390 return Faref (char_table
, ch
);
2394 error ("Invalid RANGE argument to `char-table-range'");
2398 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2400 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2401 RANGE should be t (for all characters), nil (for the default value)
2402 a vector which identifies a character set or a row of a character set,
2403 a coding system, or a character code. */)
2404 (char_table
, range
, value
)
2405 Lisp_Object char_table
, range
, value
;
2409 CHECK_CHAR_TABLE (char_table
);
2412 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2413 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2414 else if (EQ (range
, Qnil
))
2415 XCHAR_TABLE (char_table
)->defalt
= value
;
2416 else if (SYMBOLP (range
))
2418 Lisp_Object charset_info
;
2420 charset_info
= Fget (range
, Qcharset
);
2421 CHECK_VECTOR (charset_info
);
2423 return Faset (char_table
,
2424 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2428 else if (INTEGERP (range
))
2429 Faset (char_table
, range
, value
);
2430 else if (VECTORP (range
))
2432 if (XVECTOR (range
)->size
== 1)
2433 return Faset (char_table
,
2434 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2438 int size
= XVECTOR (range
)->size
;
2439 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2440 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2441 size
<= 1 ? Qnil
: val
[1],
2442 size
<= 2 ? Qnil
: val
[2]);
2443 return Faset (char_table
, ch
, value
);
2447 error ("Invalid RANGE argument to `set-char-table-range'");
2452 DEFUN ("set-char-table-default", Fset_char_table_default
,
2453 Sset_char_table_default
, 3, 3, 0,
2454 doc
: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
2455 The generic character specifies the group of characters.
2456 See also the documentation of make-char. */)
2457 (char_table
, ch
, value
)
2458 Lisp_Object char_table
, ch
, value
;
2460 int c
, charset
, code1
, code2
;
2463 CHECK_CHAR_TABLE (char_table
);
2467 SPLIT_CHAR (c
, charset
, code1
, code2
);
2469 /* Since we may want to set the default value for a character set
2470 not yet defined, we check only if the character set is in the
2471 valid range or not, instead of it is already defined or not. */
2472 if (! CHARSET_VALID_P (charset
))
2473 invalid_character (c
);
2475 if (charset
== CHARSET_ASCII
)
2476 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2478 /* Even if C is not a generic char, we had better behave as if a
2479 generic char is specified. */
2480 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2482 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2485 if (SUB_CHAR_TABLE_P (temp
))
2486 XCHAR_TABLE (temp
)->defalt
= value
;
2488 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2491 if (SUB_CHAR_TABLE_P (temp
))
2494 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2495 = make_sub_char_table (temp
));
2496 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2497 if (SUB_CHAR_TABLE_P (temp
))
2498 XCHAR_TABLE (temp
)->defalt
= value
;
2500 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2504 /* Look up the element in TABLE at index CH,
2505 and return it as an integer.
2506 If the element is nil, return CH itself.
2507 (Actually we do that for any non-integer.) */
2510 char_table_translate (table
, ch
)
2515 value
= Faref (table
, make_number (ch
));
2516 if (! INTEGERP (value
))
2518 return XINT (value
);
2522 optimize_sub_char_table (table
, chars
)
2530 from
= 33, to
= 127;
2532 from
= 32, to
= 128;
2534 if (!SUB_CHAR_TABLE_P (*table
))
2536 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2537 for (; from
< to
; from
++)
2538 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2543 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2544 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2552 CHECK_CHAR_TABLE (table
);
2554 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2556 elt
= XCHAR_TABLE (table
)->contents
[i
];
2557 if (!SUB_CHAR_TABLE_P (elt
))
2559 dim
= CHARSET_DIMENSION (i
- 128);
2561 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2562 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2563 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2569 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2570 character or group of characters that share a value.
2571 DEPTH is the current depth in the originally specified
2572 chartable, and INDICES contains the vector indices
2573 for the levels our callers have descended.
2575 ARG is passed to C_FUNCTION when that is called. */
2578 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2579 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2580 Lisp_Object function
, subtable
, arg
, *indices
;
2587 /* At first, handle ASCII and 8-bit European characters. */
2588 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2590 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2592 (*c_function
) (arg
, make_number (i
), elt
);
2594 call2 (function
, make_number (i
), elt
);
2596 #if 0 /* If the char table has entries for higher characters,
2597 we should report them. */
2598 if (NILP (current_buffer
->enable_multibyte_characters
))
2601 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2605 int charset
= XFASTINT (indices
[0]) - 128;
2608 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2609 if (CHARSET_CHARS (charset
) == 94)
2618 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2619 XSETFASTINT (indices
[depth
], i
);
2620 charset
= XFASTINT (indices
[0]) - 128;
2622 && (!CHARSET_DEFINED_P (charset
)
2623 || charset
== CHARSET_8_BIT_CONTROL
2624 || charset
== CHARSET_8_BIT_GRAPHIC
))
2627 if (SUB_CHAR_TABLE_P (elt
))
2630 error ("Too deep char table");
2631 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2638 elt
= XCHAR_TABLE (subtable
)->defalt
;
2639 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2640 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2641 c
= MAKE_CHAR (charset
, c1
, c2
);
2643 (*c_function
) (arg
, make_number (c
), elt
);
2645 call2 (function
, make_number (c
), elt
);
2650 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2652 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2653 FUNCTION is called with two arguments--a key and a value.
2654 The key is always a possible IDX argument to `aref'. */)
2655 (function
, char_table
)
2656 Lisp_Object function
, char_table
;
2658 /* The depth of char table is at most 3. */
2659 Lisp_Object indices
[3];
2661 CHECK_CHAR_TABLE (char_table
);
2663 map_char_table ((POINTER_TYPE
*) call2
, Qnil
, char_table
, function
, 0, indices
);
2667 /* Return a value for character C in char-table TABLE. Store the
2668 actual index for that value in *IDX. Ignore the default value of
2672 char_table_ref_and_index (table
, c
, idx
)
2676 int charset
, c1
, c2
;
2679 if (SINGLE_BYTE_CHAR_P (c
))
2682 return XCHAR_TABLE (table
)->contents
[c
];
2684 SPLIT_CHAR (c
, charset
, c1
, c2
);
2685 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2686 *idx
= MAKE_CHAR (charset
, 0, 0);
2687 if (!SUB_CHAR_TABLE_P (elt
))
2689 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2690 return XCHAR_TABLE (elt
)->defalt
;
2691 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2692 *idx
= MAKE_CHAR (charset
, c1
, 0);
2693 if (!SUB_CHAR_TABLE_P (elt
))
2695 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2696 return XCHAR_TABLE (elt
)->defalt
;
2698 return XCHAR_TABLE (elt
)->contents
[c2
];
2708 Lisp_Object args
[2];
2711 return Fnconc (2, args
);
2713 return Fnconc (2, &s1
);
2714 #endif /* NO_ARG_ARRAY */
2717 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2718 doc
: /* Concatenate any number of lists by altering them.
2719 Only the last argument is not altered, and need not be a list.
2720 usage: (nconc &rest LISTS) */)
2725 register int argnum
;
2726 register Lisp_Object tail
, tem
, val
;
2730 for (argnum
= 0; argnum
< nargs
; argnum
++)
2733 if (NILP (tem
)) continue;
2738 if (argnum
+ 1 == nargs
) break;
2741 tem
= wrong_type_argument (Qlistp
, tem
);
2750 tem
= args
[argnum
+ 1];
2751 Fsetcdr (tail
, tem
);
2753 args
[argnum
+ 1] = tail
;
2759 /* This is the guts of all mapping functions.
2760 Apply FN to each element of SEQ, one by one,
2761 storing the results into elements of VALS, a C vector of Lisp_Objects.
2762 LENI is the length of VALS, which should also be the length of SEQ. */
2765 mapcar1 (leni
, vals
, fn
, seq
)
2768 Lisp_Object fn
, seq
;
2770 register Lisp_Object tail
;
2773 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2777 /* Don't let vals contain any garbage when GC happens. */
2778 for (i
= 0; i
< leni
; i
++)
2781 GCPRO3 (dummy
, fn
, seq
);
2783 gcpro1
.nvars
= leni
;
2787 /* We need not explicitly protect `tail' because it is used only on lists, and
2788 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2792 for (i
= 0; i
< leni
; i
++)
2794 dummy
= XVECTOR (seq
)->contents
[i
];
2795 dummy
= call1 (fn
, dummy
);
2800 else if (BOOL_VECTOR_P (seq
))
2802 for (i
= 0; i
< leni
; i
++)
2805 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2806 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2811 dummy
= call1 (fn
, dummy
);
2816 else if (STRINGP (seq
))
2820 for (i
= 0, i_byte
= 0; i
< leni
;)
2825 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2826 XSETFASTINT (dummy
, c
);
2827 dummy
= call1 (fn
, dummy
);
2829 vals
[i_before
] = dummy
;
2832 else /* Must be a list, since Flength did not get an error */
2835 for (i
= 0; i
< leni
; i
++)
2837 dummy
= call1 (fn
, Fcar (tail
));
2847 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2848 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2849 In between each pair of results, stick in SEPARATOR. Thus, " " as
2850 SEPARATOR results in spaces between the values returned by FUNCTION.
2851 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2852 (function
, sequence
, separator
)
2853 Lisp_Object function
, sequence
, separator
;
2858 register Lisp_Object
*args
;
2860 struct gcpro gcpro1
;
2862 len
= Flength (sequence
);
2864 nargs
= leni
+ leni
- 1;
2865 if (nargs
< 0) return build_string ("");
2867 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2870 mapcar1 (leni
, args
, function
, sequence
);
2873 for (i
= leni
- 1; i
>= 0; i
--)
2874 args
[i
+ i
] = args
[i
];
2876 for (i
= 1; i
< nargs
; i
+= 2)
2877 args
[i
] = separator
;
2879 return Fconcat (nargs
, args
);
2882 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2883 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2884 The result is a list just as long as SEQUENCE.
2885 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2886 (function
, sequence
)
2887 Lisp_Object function
, sequence
;
2889 register Lisp_Object len
;
2891 register Lisp_Object
*args
;
2893 len
= Flength (sequence
);
2894 leni
= XFASTINT (len
);
2895 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2897 mapcar1 (leni
, args
, function
, sequence
);
2899 return Flist (leni
, args
);
2902 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2903 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2904 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2905 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2906 (function
, sequence
)
2907 Lisp_Object function
, sequence
;
2911 leni
= XFASTINT (Flength (sequence
));
2912 mapcar1 (leni
, 0, function
, sequence
);
2917 /* Anything that calls this function must protect from GC! */
2919 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2920 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2921 Takes one argument, which is the string to display to ask the question.
2922 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2923 No confirmation of the answer is requested; a single character is enough.
2924 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2925 the bindings in `query-replace-map'; see the documentation of that variable
2926 for more information. In this case, the useful bindings are `act', `skip',
2927 `recenter', and `quit'.\)
2929 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2930 is nil and `use-dialog-box' is non-nil. */)
2934 register Lisp_Object obj
, key
, def
, map
;
2935 register int answer
;
2936 Lisp_Object xprompt
;
2937 Lisp_Object args
[2];
2938 struct gcpro gcpro1
, gcpro2
;
2939 int count
= SPECPDL_INDEX ();
2941 specbind (Qcursor_in_echo_area
, Qt
);
2943 map
= Fsymbol_value (intern ("query-replace-map"));
2945 CHECK_STRING (prompt
);
2947 GCPRO2 (prompt
, xprompt
);
2949 #ifdef HAVE_X_WINDOWS
2950 if (display_hourglass_p
)
2951 cancel_hourglass ();
2958 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2962 Lisp_Object pane
, menu
;
2963 redisplay_preserve_echo_area (3);
2964 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2965 Fcons (Fcons (build_string ("No"), Qnil
),
2967 menu
= Fcons (prompt
, pane
);
2968 obj
= Fx_popup_dialog (Qt
, menu
);
2969 answer
= !NILP (obj
);
2972 #endif /* HAVE_MENUS */
2973 cursor_in_echo_area
= 1;
2974 choose_minibuf_frame ();
2977 Lisp_Object pargs
[3];
2979 /* Colorize prompt according to `minibuffer-prompt' face. */
2980 pargs
[0] = build_string ("%s(y or n) ");
2981 pargs
[1] = intern ("face");
2982 pargs
[2] = intern ("minibuffer-prompt");
2983 args
[0] = Fpropertize (3, pargs
);
2988 if (minibuffer_auto_raise
)
2990 Lisp_Object mini_frame
;
2992 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2994 Fraise_frame (mini_frame
);
2997 obj
= read_filtered_event (1, 0, 0, 0);
2998 cursor_in_echo_area
= 0;
2999 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3002 key
= Fmake_vector (make_number (1), obj
);
3003 def
= Flookup_key (map
, key
, Qt
);
3005 if (EQ (def
, intern ("skip")))
3010 else if (EQ (def
, intern ("act")))
3015 else if (EQ (def
, intern ("recenter")))
3021 else if (EQ (def
, intern ("quit")))
3023 /* We want to exit this command for exit-prefix,
3024 and this is the only way to do it. */
3025 else if (EQ (def
, intern ("exit-prefix")))
3030 /* If we don't clear this, then the next call to read_char will
3031 return quit_char again, and we'll enter an infinite loop. */
3036 if (EQ (xprompt
, prompt
))
3038 args
[0] = build_string ("Please answer y or n. ");
3040 xprompt
= Fconcat (2, args
);
3045 if (! noninteractive
)
3047 cursor_in_echo_area
= -1;
3048 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3052 unbind_to (count
, Qnil
);
3053 return answer
? Qt
: Qnil
;
3056 /* This is how C code calls `yes-or-no-p' and allows the user
3059 Anything that calls this function must protect from GC! */
3062 do_yes_or_no_p (prompt
)
3065 return call1 (intern ("yes-or-no-p"), prompt
);
3068 /* Anything that calls this function must protect from GC! */
3070 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3071 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3072 Takes one argument, which is the string to display to ask the question.
3073 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3074 The user must confirm the answer with RET,
3075 and can edit it until it has been confirmed.
3077 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3078 is nil, and `use-dialog-box' is non-nil. */)
3082 register Lisp_Object ans
;
3083 Lisp_Object args
[2];
3084 struct gcpro gcpro1
;
3086 CHECK_STRING (prompt
);
3089 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3093 Lisp_Object pane
, menu
, obj
;
3094 redisplay_preserve_echo_area (4);
3095 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3096 Fcons (Fcons (build_string ("No"), Qnil
),
3099 menu
= Fcons (prompt
, pane
);
3100 obj
= Fx_popup_dialog (Qt
, menu
);
3104 #endif /* HAVE_MENUS */
3107 args
[1] = build_string ("(yes or no) ");
3108 prompt
= Fconcat (2, args
);
3114 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3115 Qyes_or_no_p_history
, Qnil
,
3117 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3122 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3130 message ("Please answer yes or no.");
3131 Fsleep_for (make_number (2), Qnil
);
3135 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3136 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3138 Each of the three load averages is multiplied by 100, then converted
3141 When USE-FLOATS is non-nil, floats will be used instead of integers.
3142 These floats are not multiplied by 100.
3144 If the 5-minute or 15-minute load averages are not available, return a
3145 shortened list, containing only those averages which are available. */)
3147 Lisp_Object use_floats
;
3150 int loads
= getloadavg (load_ave
, 3);
3151 Lisp_Object ret
= Qnil
;
3154 error ("load-average not implemented for this operating system");
3158 Lisp_Object load
= (NILP (use_floats
) ?
3159 make_number ((int) (100.0 * load_ave
[loads
]))
3160 : make_float (load_ave
[loads
]));
3161 ret
= Fcons (load
, ret
);
3167 Lisp_Object Vfeatures
, Qsubfeatures
;
3168 extern Lisp_Object Vafter_load_alist
;
3170 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3171 doc
: /* Returns t if FEATURE is present in this Emacs.
3173 Use this to conditionalize execution of lisp code based on the
3174 presence or absence of emacs or environment extensions.
3175 Use `provide' to declare that a feature is available. This function
3176 looks at the value of the variable `features'. The optional argument
3177 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3178 (feature
, subfeature
)
3179 Lisp_Object feature
, subfeature
;
3181 register Lisp_Object tem
;
3182 CHECK_SYMBOL (feature
);
3183 tem
= Fmemq (feature
, Vfeatures
);
3184 if (!NILP (tem
) && !NILP (subfeature
))
3185 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3186 return (NILP (tem
)) ? Qnil
: Qt
;
3189 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3190 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3191 The optional argument SUBFEATURES should be a list of symbols listing
3192 particular subfeatures supported in this version of FEATURE. */)
3193 (feature
, subfeatures
)
3194 Lisp_Object feature
, subfeatures
;
3196 register Lisp_Object tem
;
3197 CHECK_SYMBOL (feature
);
3198 CHECK_LIST (subfeatures
);
3199 if (!NILP (Vautoload_queue
))
3200 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3201 tem
= Fmemq (feature
, Vfeatures
);
3203 Vfeatures
= Fcons (feature
, Vfeatures
);
3204 if (!NILP (subfeatures
))
3205 Fput (feature
, Qsubfeatures
, subfeatures
);
3206 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3208 /* Run any load-hooks for this file. */
3209 tem
= Fassq (feature
, Vafter_load_alist
);
3211 Fprogn (XCDR (tem
));
3216 /* `require' and its subroutines. */
3218 /* List of features currently being require'd, innermost first. */
3220 Lisp_Object require_nesting_list
;
3223 require_unwind (old_value
)
3224 Lisp_Object old_value
;
3226 return require_nesting_list
= old_value
;
3229 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3230 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3231 If FEATURE is not a member of the list `features', then the feature
3232 is not loaded; so load the file FILENAME.
3233 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3234 and `load' will try to load this name appended with the suffix `.elc',
3235 `.el' or the unmodified name, in that order.
3236 If the optional third argument NOERROR is non-nil,
3237 then return nil if the file is not found instead of signaling an error.
3238 Normally the return value is FEATURE.
3239 The normal messages at start and end of loading FILENAME are suppressed. */)
3240 (feature
, filename
, noerror
)
3241 Lisp_Object feature
, filename
, noerror
;
3243 register Lisp_Object tem
;
3244 struct gcpro gcpro1
, gcpro2
;
3246 CHECK_SYMBOL (feature
);
3248 tem
= Fmemq (feature
, Vfeatures
);
3252 int count
= SPECPDL_INDEX ();
3255 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3257 /* This is to make sure that loadup.el gives a clear picture
3258 of what files are preloaded and when. */
3259 if (! NILP (Vpurify_flag
))
3260 error ("(require %s) while preparing to dump",
3261 SDATA (SYMBOL_NAME (feature
)));
3263 /* A certain amount of recursive `require' is legitimate,
3264 but if we require the same feature recursively 3 times,
3266 tem
= require_nesting_list
;
3267 while (! NILP (tem
))
3269 if (! NILP (Fequal (feature
, XCAR (tem
))))
3274 error ("Recursive `require' for feature `%s'",
3275 SDATA (SYMBOL_NAME (feature
)));
3277 /* Update the list for any nested `require's that occur. */
3278 record_unwind_protect (require_unwind
, require_nesting_list
);
3279 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3281 /* Value saved here is to be restored into Vautoload_queue */
3282 record_unwind_protect (un_autoload
, Vautoload_queue
);
3283 Vautoload_queue
= Qt
;
3285 /* Load the file. */
3286 GCPRO2 (feature
, filename
);
3287 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3288 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3291 /* If load failed entirely, return nil. */
3293 return unbind_to (count
, Qnil
);
3295 tem
= Fmemq (feature
, Vfeatures
);
3297 error ("Required feature `%s' was not provided",
3298 SDATA (SYMBOL_NAME (feature
)));
3300 /* Once loading finishes, don't undo it. */
3301 Vautoload_queue
= Qt
;
3302 feature
= unbind_to (count
, feature
);
3308 /* Primitives for work of the "widget" library.
3309 In an ideal world, this section would not have been necessary.
3310 However, lisp function calls being as slow as they are, it turns
3311 out that some functions in the widget library (wid-edit.el) are the
3312 bottleneck of Widget operation. Here is their translation to C,
3313 for the sole reason of efficiency. */
3315 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3316 doc
: /* Return non-nil if PLIST has the property PROP.
3317 PLIST is a property list, which is a list of the form
3318 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3319 Unlike `plist-get', this allows you to distinguish between a missing
3320 property and a property with the value nil.
3321 The value is actually the tail of PLIST whose car is PROP. */)
3323 Lisp_Object plist
, prop
;
3325 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3328 plist
= XCDR (plist
);
3329 plist
= CDR (plist
);
3334 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3335 doc
: /* In WIDGET, set PROPERTY to VALUE.
3336 The value can later be retrieved with `widget-get'. */)
3337 (widget
, property
, value
)
3338 Lisp_Object widget
, property
, value
;
3340 CHECK_CONS (widget
);
3341 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3345 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3346 doc
: /* In WIDGET, get the value of PROPERTY.
3347 The value could either be specified when the widget was created, or
3348 later with `widget-put'. */)
3350 Lisp_Object widget
, property
;
3358 CHECK_CONS (widget
);
3359 tmp
= Fplist_member (XCDR (widget
), property
);
3365 tmp
= XCAR (widget
);
3368 widget
= Fget (tmp
, Qwidget_type
);
3372 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3373 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3374 ARGS are passed as extra arguments to the function.
3375 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3380 /* This function can GC. */
3381 Lisp_Object newargs
[3];
3382 struct gcpro gcpro1
, gcpro2
;
3385 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3386 newargs
[1] = args
[0];
3387 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3388 GCPRO2 (newargs
[0], newargs
[2]);
3389 result
= Fapply (3, newargs
);
3394 #ifdef HAVE_LANGINFO_CODESET
3395 #include <langinfo.h>
3398 DEFUN ("langinfo", Flanginfo
, Slanginfo
, 1, 1, 0,
3399 doc
: /* Access locale category ITEM, if available.
3401 ITEM may be one of the following:
3402 `codeset', returning the character set as a string (CODESET);
3403 `days', returning a 7-element vector of day names (DAY_n);
3404 `months', returning a 12-element vector of month names (MON_n).
3406 If the system can't provide such information through a call to
3407 nl_langinfo(3), return nil.
3409 The data read from the system are decoded using `locale-coding-system'. */)
3414 #ifdef HAVE_LANGINFO_CODESET
3416 if (EQ (item
, Qcodeset
))
3418 str
= nl_langinfo (CODESET
);
3419 return build_string (str
);
3422 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3424 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3425 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3427 synchronize_system_time_locale ();
3428 for (i
= 0; i
< 7; i
++)
3430 str
= nl_langinfo (days
[i
]);
3431 val
= make_unibyte_string (str
, strlen (str
));
3432 /* Fixme: Is this coding system necessarily right, even if
3433 it is consistent with CODESET? If not, what to do? */
3434 Faset (v
, make_number (i
),
3435 code_convert_string_norecord (val
, Vlocale_coding_system
,
3442 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3444 struct Lisp_Vector
*p
= allocate_vector (12);
3445 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3446 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3448 synchronize_system_time_locale ();
3449 for (i
= 0; i
< 12; i
++)
3451 str
= nl_langinfo (months
[i
]);
3452 val
= make_unibyte_string (str
, strlen (str
));
3454 code_convert_string_norecord (val
, Vlocale_coding_system
, Qnil
);
3456 XSETVECTOR (val
, p
);
3460 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3461 but is in the locale files. This could be used by ps-print. */
3463 else if (EQ (item
, Qpaper
))
3465 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3466 make_number (nl_langinfo (PAPER_HEIGHT
)));
3468 #endif /* PAPER_WIDTH */
3469 #endif /* HAVE_LANGINFO_CODESET*/
3473 /* base64 encode/decode functions (RFC 2045).
3474 Based on code from GNU recode. */
3476 #define MIME_LINE_LENGTH 76
3478 #define IS_ASCII(Character) \
3480 #define IS_BASE64(Character) \
3481 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3482 #define IS_BASE64_IGNORABLE(Character) \
3483 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3484 || (Character) == '\f' || (Character) == '\r')
3486 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3487 character or return retval if there are no characters left to
3489 #define READ_QUADRUPLET_BYTE(retval) \
3494 if (nchars_return) \
3495 *nchars_return = nchars; \
3500 while (IS_BASE64_IGNORABLE (c))
3502 /* Don't use alloca for regions larger than this, lest we overflow
3504 #define MAX_ALLOCA 16*1024
3506 /* Table of characters coding the 64 values. */
3507 static char base64_value_to_char
[64] =
3509 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3510 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3511 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3512 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3513 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3514 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3515 '8', '9', '+', '/' /* 60-63 */
3518 /* Table of base64 values for first 128 characters. */
3519 static short base64_char_to_value
[128] =
3521 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3522 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3523 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3524 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3525 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3526 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3527 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3528 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3529 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3530 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3531 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3532 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3533 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3536 /* The following diagram shows the logical steps by which three octets
3537 get transformed into four base64 characters.
3539 .--------. .--------. .--------.
3540 |aaaaaabb| |bbbbcccc| |ccdddddd|
3541 `--------' `--------' `--------'
3543 .--------+--------+--------+--------.
3544 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3545 `--------+--------+--------+--------'
3547 .--------+--------+--------+--------.
3548 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3549 `--------+--------+--------+--------'
3551 The octets are divided into 6 bit chunks, which are then encoded into
3552 base64 characters. */
3555 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3556 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3558 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3560 doc
: /* Base64-encode the region between BEG and END.
3561 Return the length of the encoded text.
3562 Optional third argument NO-LINE-BREAK means do not break long lines
3563 into shorter lines. */)
3564 (beg
, end
, no_line_break
)
3565 Lisp_Object beg
, end
, no_line_break
;
3568 int allength
, length
;
3569 int ibeg
, iend
, encoded_length
;
3572 validate_region (&beg
, &end
);
3574 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3575 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3576 move_gap_both (XFASTINT (beg
), ibeg
);
3578 /* We need to allocate enough room for encoding the text.
3579 We need 33 1/3% more space, plus a newline every 76
3580 characters, and then we round up. */
3581 length
= iend
- ibeg
;
3582 allength
= length
+ length
/3 + 1;
3583 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3585 if (allength
<= MAX_ALLOCA
)
3586 encoded
= (char *) alloca (allength
);
3588 encoded
= (char *) xmalloc (allength
);
3589 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3590 NILP (no_line_break
),
3591 !NILP (current_buffer
->enable_multibyte_characters
));
3592 if (encoded_length
> allength
)
3595 if (encoded_length
< 0)
3597 /* The encoding wasn't possible. */
3598 if (length
> MAX_ALLOCA
)
3600 error ("Multibyte character in data for base64 encoding");
3603 /* Now we have encoded the region, so we insert the new contents
3604 and delete the old. (Insert first in order to preserve markers.) */
3605 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3606 insert (encoded
, encoded_length
);
3607 if (allength
> MAX_ALLOCA
)
3609 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3611 /* If point was outside of the region, restore it exactly; else just
3612 move to the beginning of the region. */
3613 if (old_pos
>= XFASTINT (end
))
3614 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3615 else if (old_pos
> XFASTINT (beg
))
3616 old_pos
= XFASTINT (beg
);
3619 /* We return the length of the encoded text. */
3620 return make_number (encoded_length
);
3623 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3625 doc
: /* Base64-encode STRING and return the result.
3626 Optional second argument NO-LINE-BREAK means do not break long lines
3627 into shorter lines. */)
3628 (string
, no_line_break
)
3629 Lisp_Object string
, no_line_break
;
3631 int allength
, length
, encoded_length
;
3633 Lisp_Object encoded_string
;
3635 CHECK_STRING (string
);
3637 /* We need to allocate enough room for encoding the text.
3638 We need 33 1/3% more space, plus a newline every 76
3639 characters, and then we round up. */
3640 length
= SBYTES (string
);
3641 allength
= length
+ length
/3 + 1;
3642 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3644 /* We need to allocate enough room for decoding the text. */
3645 if (allength
<= MAX_ALLOCA
)
3646 encoded
= (char *) alloca (allength
);
3648 encoded
= (char *) xmalloc (allength
);
3650 encoded_length
= base64_encode_1 (SDATA (string
),
3651 encoded
, length
, NILP (no_line_break
),
3652 STRING_MULTIBYTE (string
));
3653 if (encoded_length
> allength
)
3656 if (encoded_length
< 0)
3658 /* The encoding wasn't possible. */
3659 if (length
> MAX_ALLOCA
)
3661 error ("Multibyte character in data for base64 encoding");
3664 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3665 if (allength
> MAX_ALLOCA
)
3668 return encoded_string
;
3672 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3679 int counter
= 0, i
= 0;
3689 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3697 /* Wrap line every 76 characters. */
3701 if (counter
< MIME_LINE_LENGTH
/ 4)
3710 /* Process first byte of a triplet. */
3712 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3713 value
= (0x03 & c
) << 4;
3715 /* Process second byte of a triplet. */
3719 *e
++ = base64_value_to_char
[value
];
3727 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3735 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3736 value
= (0x0f & c
) << 2;
3738 /* Process third byte of a triplet. */
3742 *e
++ = base64_value_to_char
[value
];
3749 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3757 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3758 *e
++ = base64_value_to_char
[0x3f & c
];
3765 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3767 doc
: /* Base64-decode the region between BEG and END.
3768 Return the length of the decoded text.
3769 If the region can't be decoded, signal an error and don't modify the buffer. */)
3771 Lisp_Object beg
, end
;
3773 int ibeg
, iend
, length
, allength
;
3778 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3780 validate_region (&beg
, &end
);
3782 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3783 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3785 length
= iend
- ibeg
;
3787 /* We need to allocate enough room for decoding the text. If we are
3788 working on a multibyte buffer, each decoded code may occupy at
3790 allength
= multibyte
? length
* 2 : length
;
3791 if (allength
<= MAX_ALLOCA
)
3792 decoded
= (char *) alloca (allength
);
3794 decoded
= (char *) xmalloc (allength
);
3796 move_gap_both (XFASTINT (beg
), ibeg
);
3797 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3798 multibyte
, &inserted_chars
);
3799 if (decoded_length
> allength
)
3802 if (decoded_length
< 0)
3804 /* The decoding wasn't possible. */
3805 if (allength
> MAX_ALLOCA
)
3807 error ("Invalid base64 data");
3810 /* Now we have decoded the region, so we insert the new contents
3811 and delete the old. (Insert first in order to preserve markers.) */
3812 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3813 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3814 if (allength
> MAX_ALLOCA
)
3816 /* Delete the original text. */
3817 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3818 iend
+ decoded_length
, 1);
3820 /* If point was outside of the region, restore it exactly; else just
3821 move to the beginning of the region. */
3822 if (old_pos
>= XFASTINT (end
))
3823 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3824 else if (old_pos
> XFASTINT (beg
))
3825 old_pos
= XFASTINT (beg
);
3826 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3828 return make_number (inserted_chars
);
3831 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3833 doc
: /* Base64-decode STRING and return the result. */)
3838 int length
, decoded_length
;
3839 Lisp_Object decoded_string
;
3841 CHECK_STRING (string
);
3843 length
= SBYTES (string
);
3844 /* We need to allocate enough room for decoding the text. */
3845 if (length
<= MAX_ALLOCA
)
3846 decoded
= (char *) alloca (length
);
3848 decoded
= (char *) xmalloc (length
);
3850 /* The decoded result should be unibyte. */
3851 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3853 if (decoded_length
> length
)
3855 else if (decoded_length
>= 0)
3856 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3858 decoded_string
= Qnil
;
3860 if (length
> MAX_ALLOCA
)
3862 if (!STRINGP (decoded_string
))
3863 error ("Invalid base64 data");
3865 return decoded_string
;
3868 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3869 MULTIBYTE is nonzero, the decoded result should be in multibyte
3870 form. If NCHARS_RETRUN is not NULL, store the number of produced
3871 characters in *NCHARS_RETURN. */
3874 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3884 unsigned long value
;
3889 /* Process first byte of a quadruplet. */
3891 READ_QUADRUPLET_BYTE (e
-to
);
3895 value
= base64_char_to_value
[c
] << 18;
3897 /* Process second byte of a quadruplet. */
3899 READ_QUADRUPLET_BYTE (-1);
3903 value
|= base64_char_to_value
[c
] << 12;
3905 c
= (unsigned char) (value
>> 16);
3907 e
+= CHAR_STRING (c
, e
);
3912 /* Process third byte of a quadruplet. */
3914 READ_QUADRUPLET_BYTE (-1);
3918 READ_QUADRUPLET_BYTE (-1);
3927 value
|= base64_char_to_value
[c
] << 6;
3929 c
= (unsigned char) (0xff & value
>> 8);
3931 e
+= CHAR_STRING (c
, e
);
3936 /* Process fourth byte of a quadruplet. */
3938 READ_QUADRUPLET_BYTE (-1);
3945 value
|= base64_char_to_value
[c
];
3947 c
= (unsigned char) (0xff & value
);
3949 e
+= CHAR_STRING (c
, e
);
3958 /***********************************************************************
3960 ***** Hash Tables *****
3962 ***********************************************************************/
3964 /* Implemented by gerd@gnu.org. This hash table implementation was
3965 inspired by CMUCL hash tables. */
3969 1. For small tables, association lists are probably faster than
3970 hash tables because they have lower overhead.
3972 For uses of hash tables where the O(1) behavior of table
3973 operations is not a requirement, it might therefore be a good idea
3974 not to hash. Instead, we could just do a linear search in the
3975 key_and_value vector of the hash table. This could be done
3976 if a `:linear-search t' argument is given to make-hash-table. */
3979 /* The list of all weak hash tables. Don't staticpro this one. */
3981 Lisp_Object Vweak_hash_tables
;
3983 /* Various symbols. */
3985 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3986 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3987 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3989 /* Function prototypes. */
3991 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3992 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3993 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3994 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3995 Lisp_Object
, unsigned));
3996 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3997 Lisp_Object
, unsigned));
3998 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3999 unsigned, Lisp_Object
, unsigned));
4000 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4001 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4002 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4003 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4005 static unsigned sxhash_string
P_ ((unsigned char *, int));
4006 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4007 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4008 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4009 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4013 /***********************************************************************
4015 ***********************************************************************/
4017 /* If OBJ is a Lisp hash table, return a pointer to its struct
4018 Lisp_Hash_Table. Otherwise, signal an error. */
4020 static struct Lisp_Hash_Table
*
4021 check_hash_table (obj
)
4024 CHECK_HASH_TABLE (obj
);
4025 return XHASH_TABLE (obj
);
4029 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4033 next_almost_prime (n
)
4046 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4047 which USED[I] is non-zero. If found at index I in ARGS, set
4048 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4049 -1. This function is used to extract a keyword/argument pair from
4050 a DEFUN parameter list. */
4053 get_key_arg (key
, nargs
, args
, used
)
4061 for (i
= 0; i
< nargs
- 1; ++i
)
4062 if (!used
[i
] && EQ (args
[i
], key
))
4077 /* Return a Lisp vector which has the same contents as VEC but has
4078 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4079 vector that are not copied from VEC are set to INIT. */
4082 larger_vector (vec
, new_size
, init
)
4087 struct Lisp_Vector
*v
;
4090 xassert (VECTORP (vec
));
4091 old_size
= XVECTOR (vec
)->size
;
4092 xassert (new_size
>= old_size
);
4094 v
= allocate_vector (new_size
);
4095 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4096 old_size
* sizeof *v
->contents
);
4097 for (i
= old_size
; i
< new_size
; ++i
)
4098 v
->contents
[i
] = init
;
4099 XSETVECTOR (vec
, v
);
4104 /***********************************************************************
4106 ***********************************************************************/
4108 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4109 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4110 KEY2 are the same. */
4113 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4114 struct Lisp_Hash_Table
*h
;
4115 Lisp_Object key1
, key2
;
4116 unsigned hash1
, hash2
;
4118 return (FLOATP (key1
)
4120 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4124 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4125 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4126 KEY2 are the same. */
4129 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4130 struct Lisp_Hash_Table
*h
;
4131 Lisp_Object key1
, key2
;
4132 unsigned hash1
, hash2
;
4134 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4138 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4139 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4140 if KEY1 and KEY2 are the same. */
4143 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4144 struct Lisp_Hash_Table
*h
;
4145 Lisp_Object key1
, key2
;
4146 unsigned hash1
, hash2
;
4150 Lisp_Object args
[3];
4152 args
[0] = h
->user_cmp_function
;
4155 return !NILP (Ffuncall (3, args
));
4162 /* Value is a hash code for KEY for use in hash table H which uses
4163 `eq' to compare keys. The hash code returned is guaranteed to fit
4164 in a Lisp integer. */
4168 struct Lisp_Hash_Table
*h
;
4171 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4172 xassert ((hash
& ~VALMASK
) == 0);
4177 /* Value is a hash code for KEY for use in hash table H which uses
4178 `eql' to compare keys. The hash code returned is guaranteed to fit
4179 in a Lisp integer. */
4183 struct Lisp_Hash_Table
*h
;
4188 hash
= sxhash (key
, 0);
4190 hash
= XUINT (key
) ^ XGCTYPE (key
);
4191 xassert ((hash
& ~VALMASK
) == 0);
4196 /* Value is a hash code for KEY for use in hash table H which uses
4197 `equal' to compare keys. The hash code returned is guaranteed to fit
4198 in a Lisp integer. */
4201 hashfn_equal (h
, key
)
4202 struct Lisp_Hash_Table
*h
;
4205 unsigned hash
= sxhash (key
, 0);
4206 xassert ((hash
& ~VALMASK
) == 0);
4211 /* Value is a hash code for KEY for use in hash table H which uses as
4212 user-defined function to compare keys. The hash code returned is
4213 guaranteed to fit in a Lisp integer. */
4216 hashfn_user_defined (h
, key
)
4217 struct Lisp_Hash_Table
*h
;
4220 Lisp_Object args
[2], hash
;
4222 args
[0] = h
->user_hash_function
;
4224 hash
= Ffuncall (2, args
);
4225 if (!INTEGERP (hash
))
4227 list2 (build_string ("Invalid hash code returned from \
4228 user-supplied hash function"),
4230 return XUINT (hash
);
4234 /* Create and initialize a new hash table.
4236 TEST specifies the test the hash table will use to compare keys.
4237 It must be either one of the predefined tests `eq', `eql' or
4238 `equal' or a symbol denoting a user-defined test named TEST with
4239 test and hash functions USER_TEST and USER_HASH.
4241 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4243 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4244 new size when it becomes full is computed by adding REHASH_SIZE to
4245 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4246 table's new size is computed by multiplying its old size with
4249 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4250 be resized when the ratio of (number of entries in the table) /
4251 (table size) is >= REHASH_THRESHOLD.
4253 WEAK specifies the weakness of the table. If non-nil, it must be
4254 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4257 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4258 user_test
, user_hash
)
4259 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4260 Lisp_Object user_test
, user_hash
;
4262 struct Lisp_Hash_Table
*h
;
4264 int index_size
, i
, sz
;
4266 /* Preconditions. */
4267 xassert (SYMBOLP (test
));
4268 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4269 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4270 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4271 xassert (FLOATP (rehash_threshold
)
4272 && XFLOATINT (rehash_threshold
) > 0
4273 && XFLOATINT (rehash_threshold
) <= 1.0);
4275 if (XFASTINT (size
) == 0)
4276 size
= make_number (1);
4278 /* Allocate a table and initialize it. */
4279 h
= allocate_hash_table ();
4281 /* Initialize hash table slots. */
4282 sz
= XFASTINT (size
);
4285 if (EQ (test
, Qeql
))
4287 h
->cmpfn
= cmpfn_eql
;
4288 h
->hashfn
= hashfn_eql
;
4290 else if (EQ (test
, Qeq
))
4293 h
->hashfn
= hashfn_eq
;
4295 else if (EQ (test
, Qequal
))
4297 h
->cmpfn
= cmpfn_equal
;
4298 h
->hashfn
= hashfn_equal
;
4302 h
->user_cmp_function
= user_test
;
4303 h
->user_hash_function
= user_hash
;
4304 h
->cmpfn
= cmpfn_user_defined
;
4305 h
->hashfn
= hashfn_user_defined
;
4309 h
->rehash_threshold
= rehash_threshold
;
4310 h
->rehash_size
= rehash_size
;
4311 h
->count
= make_number (0);
4312 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4313 h
->hash
= Fmake_vector (size
, Qnil
);
4314 h
->next
= Fmake_vector (size
, Qnil
);
4315 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4316 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4317 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4319 /* Set up the free list. */
4320 for (i
= 0; i
< sz
- 1; ++i
)
4321 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4322 h
->next_free
= make_number (0);
4324 XSET_HASH_TABLE (table
, h
);
4325 xassert (HASH_TABLE_P (table
));
4326 xassert (XHASH_TABLE (table
) == h
);
4328 /* Maybe add this hash table to the list of all weak hash tables. */
4330 h
->next_weak
= Qnil
;
4333 h
->next_weak
= Vweak_hash_tables
;
4334 Vweak_hash_tables
= table
;
4341 /* Return a copy of hash table H1. Keys and values are not copied,
4342 only the table itself is. */
4345 copy_hash_table (h1
)
4346 struct Lisp_Hash_Table
*h1
;
4349 struct Lisp_Hash_Table
*h2
;
4350 struct Lisp_Vector
*next
;
4352 h2
= allocate_hash_table ();
4353 next
= h2
->vec_next
;
4354 bcopy (h1
, h2
, sizeof *h2
);
4355 h2
->vec_next
= next
;
4356 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4357 h2
->hash
= Fcopy_sequence (h1
->hash
);
4358 h2
->next
= Fcopy_sequence (h1
->next
);
4359 h2
->index
= Fcopy_sequence (h1
->index
);
4360 XSET_HASH_TABLE (table
, h2
);
4362 /* Maybe add this hash table to the list of all weak hash tables. */
4363 if (!NILP (h2
->weak
))
4365 h2
->next_weak
= Vweak_hash_tables
;
4366 Vweak_hash_tables
= table
;
4373 /* Resize hash table H if it's too full. If H cannot be resized
4374 because it's already too large, throw an error. */
4377 maybe_resize_hash_table (h
)
4378 struct Lisp_Hash_Table
*h
;
4380 if (NILP (h
->next_free
))
4382 int old_size
= HASH_TABLE_SIZE (h
);
4383 int i
, new_size
, index_size
;
4385 if (INTEGERP (h
->rehash_size
))
4386 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4388 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4389 new_size
= max (old_size
+ 1, new_size
);
4390 index_size
= next_almost_prime ((int)
4392 / XFLOATINT (h
->rehash_threshold
)));
4393 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4394 error ("Hash table too large to resize");
4396 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4397 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4398 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4399 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4401 /* Update the free list. Do it so that new entries are added at
4402 the end of the free list. This makes some operations like
4404 for (i
= old_size
; i
< new_size
- 1; ++i
)
4405 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4407 if (!NILP (h
->next_free
))
4409 Lisp_Object last
, next
;
4411 last
= h
->next_free
;
4412 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4416 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4419 XSETFASTINT (h
->next_free
, old_size
);
4422 for (i
= 0; i
< old_size
; ++i
)
4423 if (!NILP (HASH_HASH (h
, i
)))
4425 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4426 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4427 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4428 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4434 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4435 the hash code of KEY. Value is the index of the entry in H
4436 matching KEY, or -1 if not found. */
4439 hash_lookup (h
, key
, hash
)
4440 struct Lisp_Hash_Table
*h
;
4445 int start_of_bucket
;
4448 hash_code
= h
->hashfn (h
, key
);
4452 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4453 idx
= HASH_INDEX (h
, start_of_bucket
);
4455 /* We need not gcpro idx since it's either an integer or nil. */
4458 int i
= XFASTINT (idx
);
4459 if (EQ (key
, HASH_KEY (h
, i
))
4461 && h
->cmpfn (h
, key
, hash_code
,
4462 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4464 idx
= HASH_NEXT (h
, i
);
4467 return NILP (idx
) ? -1 : XFASTINT (idx
);
4471 /* Put an entry into hash table H that associates KEY with VALUE.
4472 HASH is a previously computed hash code of KEY.
4473 Value is the index of the entry in H matching KEY. */
4476 hash_put (h
, key
, value
, hash
)
4477 struct Lisp_Hash_Table
*h
;
4478 Lisp_Object key
, value
;
4481 int start_of_bucket
, i
;
4483 xassert ((hash
& ~VALMASK
) == 0);
4485 /* Increment count after resizing because resizing may fail. */
4486 maybe_resize_hash_table (h
);
4487 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4489 /* Store key/value in the key_and_value vector. */
4490 i
= XFASTINT (h
->next_free
);
4491 h
->next_free
= HASH_NEXT (h
, i
);
4492 HASH_KEY (h
, i
) = key
;
4493 HASH_VALUE (h
, i
) = value
;
4495 /* Remember its hash code. */
4496 HASH_HASH (h
, i
) = make_number (hash
);
4498 /* Add new entry to its collision chain. */
4499 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4500 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4501 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4506 /* Remove the entry matching KEY from hash table H, if there is one. */
4509 hash_remove (h
, key
)
4510 struct Lisp_Hash_Table
*h
;
4514 int start_of_bucket
;
4515 Lisp_Object idx
, prev
;
4517 hash_code
= h
->hashfn (h
, key
);
4518 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4519 idx
= HASH_INDEX (h
, start_of_bucket
);
4522 /* We need not gcpro idx, prev since they're either integers or nil. */
4525 int i
= XFASTINT (idx
);
4527 if (EQ (key
, HASH_KEY (h
, i
))
4529 && h
->cmpfn (h
, key
, hash_code
,
4530 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4532 /* Take entry out of collision chain. */
4534 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4536 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4538 /* Clear slots in key_and_value and add the slots to
4540 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4541 HASH_NEXT (h
, i
) = h
->next_free
;
4542 h
->next_free
= make_number (i
);
4543 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4544 xassert (XINT (h
->count
) >= 0);
4550 idx
= HASH_NEXT (h
, i
);
4556 /* Clear hash table H. */
4560 struct Lisp_Hash_Table
*h
;
4562 if (XFASTINT (h
->count
) > 0)
4564 int i
, size
= HASH_TABLE_SIZE (h
);
4566 for (i
= 0; i
< size
; ++i
)
4568 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4569 HASH_KEY (h
, i
) = Qnil
;
4570 HASH_VALUE (h
, i
) = Qnil
;
4571 HASH_HASH (h
, i
) = Qnil
;
4574 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4575 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4577 h
->next_free
= make_number (0);
4578 h
->count
= make_number (0);
4584 /************************************************************************
4586 ************************************************************************/
4588 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4589 entries from the table that don't survive the current GC.
4590 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4591 non-zero if anything was marked. */
4594 sweep_weak_table (h
, remove_entries_p
)
4595 struct Lisp_Hash_Table
*h
;
4596 int remove_entries_p
;
4598 int bucket
, n
, marked
;
4600 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4603 for (bucket
= 0; bucket
< n
; ++bucket
)
4605 Lisp_Object idx
, next
, prev
;
4607 /* Follow collision chain, removing entries that
4608 don't survive this garbage collection. */
4610 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4612 int i
= XFASTINT (idx
);
4613 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4614 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4617 if (EQ (h
->weak
, Qkey
))
4618 remove_p
= !key_known_to_survive_p
;
4619 else if (EQ (h
->weak
, Qvalue
))
4620 remove_p
= !value_known_to_survive_p
;
4621 else if (EQ (h
->weak
, Qkey_or_value
))
4622 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4623 else if (EQ (h
->weak
, Qkey_and_value
))
4624 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4628 next
= HASH_NEXT (h
, i
);
4630 if (remove_entries_p
)
4634 /* Take out of collision chain. */
4636 HASH_INDEX (h
, bucket
) = next
;
4638 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4640 /* Add to free list. */
4641 HASH_NEXT (h
, i
) = h
->next_free
;
4644 /* Clear key, value, and hash. */
4645 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4646 HASH_HASH (h
, i
) = Qnil
;
4648 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4655 /* Make sure key and value survive. */
4656 if (!key_known_to_survive_p
)
4658 mark_object (&HASH_KEY (h
, i
));
4662 if (!value_known_to_survive_p
)
4664 mark_object (&HASH_VALUE (h
, i
));
4675 /* Remove elements from weak hash tables that don't survive the
4676 current garbage collection. Remove weak tables that don't survive
4677 from Vweak_hash_tables. Called from gc_sweep. */
4680 sweep_weak_hash_tables ()
4682 Lisp_Object table
, used
, next
;
4683 struct Lisp_Hash_Table
*h
;
4686 /* Mark all keys and values that are in use. Keep on marking until
4687 there is no more change. This is necessary for cases like
4688 value-weak table A containing an entry X -> Y, where Y is used in a
4689 key-weak table B, Z -> Y. If B comes after A in the list of weak
4690 tables, X -> Y might be removed from A, although when looking at B
4691 one finds that it shouldn't. */
4695 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4697 h
= XHASH_TABLE (table
);
4698 if (h
->size
& ARRAY_MARK_FLAG
)
4699 marked
|= sweep_weak_table (h
, 0);
4704 /* Remove tables and entries that aren't used. */
4705 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4707 h
= XHASH_TABLE (table
);
4708 next
= h
->next_weak
;
4710 if (h
->size
& ARRAY_MARK_FLAG
)
4712 /* TABLE is marked as used. Sweep its contents. */
4713 if (XFASTINT (h
->count
) > 0)
4714 sweep_weak_table (h
, 1);
4716 /* Add table to the list of used weak hash tables. */
4717 h
->next_weak
= used
;
4722 Vweak_hash_tables
= used
;
4727 /***********************************************************************
4728 Hash Code Computation
4729 ***********************************************************************/
4731 /* Maximum depth up to which to dive into Lisp structures. */
4733 #define SXHASH_MAX_DEPTH 3
4735 /* Maximum length up to which to take list and vector elements into
4738 #define SXHASH_MAX_LEN 7
4740 /* Combine two integers X and Y for hashing. */
4742 #define SXHASH_COMBINE(X, Y) \
4743 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4747 /* Return a hash for string PTR which has length LEN. The hash
4748 code returned is guaranteed to fit in a Lisp integer. */
4751 sxhash_string (ptr
, len
)
4755 unsigned char *p
= ptr
;
4756 unsigned char *end
= p
+ len
;
4765 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4768 return hash
& VALMASK
;
4772 /* Return a hash for list LIST. DEPTH is the current depth in the
4773 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4776 sxhash_list (list
, depth
)
4783 if (depth
< SXHASH_MAX_DEPTH
)
4785 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4786 list
= XCDR (list
), ++i
)
4788 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4789 hash
= SXHASH_COMBINE (hash
, hash2
);
4796 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4797 the Lisp structure. */
4800 sxhash_vector (vec
, depth
)
4804 unsigned hash
= XVECTOR (vec
)->size
;
4807 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4808 for (i
= 0; i
< n
; ++i
)
4810 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4811 hash
= SXHASH_COMBINE (hash
, hash2
);
4818 /* Return a hash for bool-vector VECTOR. */
4821 sxhash_bool_vector (vec
)
4824 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4827 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4828 for (i
= 0; i
< n
; ++i
)
4829 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4835 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4836 structure. Value is an unsigned integer clipped to VALMASK. */
4845 if (depth
> SXHASH_MAX_DEPTH
)
4848 switch (XTYPE (obj
))
4855 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4856 SCHARS (SYMBOL_NAME (obj
)));
4864 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4867 /* This can be everything from a vector to an overlay. */
4868 case Lisp_Vectorlike
:
4870 /* According to the CL HyperSpec, two arrays are equal only if
4871 they are `eq', except for strings and bit-vectors. In
4872 Emacs, this works differently. We have to compare element
4874 hash
= sxhash_vector (obj
, depth
);
4875 else if (BOOL_VECTOR_P (obj
))
4876 hash
= sxhash_bool_vector (obj
);
4878 /* Others are `equal' if they are `eq', so let's take their
4884 hash
= sxhash_list (obj
, depth
);
4889 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4890 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4891 for (hash
= 0; p
< e
; ++p
)
4892 hash
= SXHASH_COMBINE (hash
, *p
);
4900 return hash
& VALMASK
;
4905 /***********************************************************************
4907 ***********************************************************************/
4910 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4911 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4915 unsigned hash
= sxhash (obj
, 0);;
4916 return make_number (hash
);
4920 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4921 doc
: /* Create and return a new hash table.
4923 Arguments are specified as keyword/argument pairs. The following
4924 arguments are defined:
4926 :test TEST -- TEST must be a symbol that specifies how to compare
4927 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4928 `equal'. User-supplied test and hash functions can be specified via
4929 `define-hash-table-test'.
4931 :size SIZE -- A hint as to how many elements will be put in the table.
4934 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4935 fills up. If REHASH-SIZE is an integer, add that many space. If it
4936 is a float, it must be > 1.0, and the new size is computed by
4937 multiplying the old size with that factor. Default is 1.5.
4939 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4940 Resize the hash table when ratio of the number of entries in the
4941 table. Default is 0.8.
4943 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4944 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4945 returned is a weak table. Key/value pairs are removed from a weak
4946 hash table when there are no non-weak references pointing to their
4947 key, value, one of key or value, or both key and value, depending on
4948 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4951 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4956 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4957 Lisp_Object user_test
, user_hash
;
4961 /* The vector `used' is used to keep track of arguments that
4962 have been consumed. */
4963 used
= (char *) alloca (nargs
* sizeof *used
);
4964 bzero (used
, nargs
* sizeof *used
);
4966 /* See if there's a `:test TEST' among the arguments. */
4967 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4968 test
= i
< 0 ? Qeql
: args
[i
];
4969 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4971 /* See if it is a user-defined test. */
4974 prop
= Fget (test
, Qhash_table_test
);
4975 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4976 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4978 user_test
= XCAR (prop
);
4979 user_hash
= XCAR (XCDR (prop
));
4982 user_test
= user_hash
= Qnil
;
4984 /* See if there's a `:size SIZE' argument. */
4985 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4986 size
= i
< 0 ? Qnil
: args
[i
];
4988 size
= make_number (DEFAULT_HASH_SIZE
);
4989 else if (!INTEGERP (size
) || XINT (size
) < 0)
4991 list2 (build_string ("Invalid hash table size"),
4994 /* Look for `:rehash-size SIZE'. */
4995 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4996 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4997 if (!NUMBERP (rehash_size
)
4998 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4999 || XFLOATINT (rehash_size
) <= 1.0)
5001 list2 (build_string ("Invalid hash table rehash size"),
5004 /* Look for `:rehash-threshold THRESHOLD'. */
5005 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5006 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5007 if (!FLOATP (rehash_threshold
)
5008 || XFLOATINT (rehash_threshold
) <= 0.0
5009 || XFLOATINT (rehash_threshold
) > 1.0)
5011 list2 (build_string ("Invalid hash table rehash threshold"),
5014 /* Look for `:weakness WEAK'. */
5015 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5016 weak
= i
< 0 ? Qnil
: args
[i
];
5018 weak
= Qkey_and_value
;
5021 && !EQ (weak
, Qvalue
)
5022 && !EQ (weak
, Qkey_or_value
)
5023 && !EQ (weak
, Qkey_and_value
))
5024 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5027 /* Now, all args should have been used up, or there's a problem. */
5028 for (i
= 0; i
< nargs
; ++i
)
5031 list2 (build_string ("Invalid argument list"), args
[i
]));
5033 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5034 user_test
, user_hash
);
5038 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5039 doc
: /* Return a copy of hash table TABLE. */)
5043 return copy_hash_table (check_hash_table (table
));
5047 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5048 doc
: /* Return the number of elements in TABLE. */)
5052 return check_hash_table (table
)->count
;
5056 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5057 Shash_table_rehash_size
, 1, 1, 0,
5058 doc
: /* Return the current rehash size of TABLE. */)
5062 return check_hash_table (table
)->rehash_size
;
5066 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5067 Shash_table_rehash_threshold
, 1, 1, 0,
5068 doc
: /* Return the current rehash threshold of TABLE. */)
5072 return check_hash_table (table
)->rehash_threshold
;
5076 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5077 doc
: /* Return the size of TABLE.
5078 The size can be used as an argument to `make-hash-table' to create
5079 a hash table than can hold as many elements of TABLE holds
5080 without need for resizing. */)
5084 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5085 return make_number (HASH_TABLE_SIZE (h
));
5089 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5090 doc
: /* Return the test TABLE uses. */)
5094 return check_hash_table (table
)->test
;
5098 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5100 doc
: /* Return the weakness of TABLE. */)
5104 return check_hash_table (table
)->weak
;
5108 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5109 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5113 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5117 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5118 doc
: /* Clear hash table TABLE. */)
5122 hash_clear (check_hash_table (table
));
5127 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5128 doc
: /* Look up KEY in TABLE and return its associated value.
5129 If KEY is not found, return DFLT which defaults to nil. */)
5131 Lisp_Object key
, table
, dflt
;
5133 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5134 int i
= hash_lookup (h
, key
, NULL
);
5135 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5139 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5140 doc
: /* Associate KEY with VALUE in hash table TABLE.
5141 If KEY is already present in table, replace its current value with
5144 Lisp_Object key
, value
, table
;
5146 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5150 i
= hash_lookup (h
, key
, &hash
);
5152 HASH_VALUE (h
, i
) = value
;
5154 hash_put (h
, key
, value
, hash
);
5160 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5161 doc
: /* Remove KEY from TABLE. */)
5163 Lisp_Object key
, table
;
5165 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5166 hash_remove (h
, key
);
5171 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5172 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5173 FUNCTION is called with 2 arguments KEY and VALUE. */)
5175 Lisp_Object function
, table
;
5177 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5178 Lisp_Object args
[3];
5181 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5182 if (!NILP (HASH_HASH (h
, i
)))
5185 args
[1] = HASH_KEY (h
, i
);
5186 args
[2] = HASH_VALUE (h
, i
);
5194 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5195 Sdefine_hash_table_test
, 3, 3, 0,
5196 doc
: /* Define a new hash table test with name NAME, a symbol.
5198 In hash tables created with NAME specified as test, use TEST to
5199 compare keys, and HASH for computing hash codes of keys.
5201 TEST must be a function taking two arguments and returning non-nil if
5202 both arguments are the same. HASH must be a function taking one
5203 argument and return an integer that is the hash code of the argument.
5204 Hash code computation should use the whole value range of integers,
5205 including negative integers. */)
5207 Lisp_Object name
, test
, hash
;
5209 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5214 /************************************************************************
5216 ************************************************************************/
5221 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5222 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5224 A message digest is a cryptographic checksum of a document, and the
5225 algorithm to calculate it is defined in RFC 1321.
5227 The two optional arguments START and END are character positions
5228 specifying for which part of OBJECT the message digest should be
5229 computed. If nil or omitted, the digest is computed for the whole
5232 The MD5 message digest is computed from the result of encoding the
5233 text in a coding system, not directly from the internal Emacs form of
5234 the text. The optional fourth argument CODING-SYSTEM specifies which
5235 coding system to encode the text with. It should be the same coding
5236 system that you used or will use when actually writing the text into a
5239 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5240 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5241 system would be chosen by default for writing this text into a file.
5243 If OBJECT is a string, the most preferred coding system (see the
5244 command `prefer-coding-system') is used.
5246 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5247 guesswork fails. Normally, an error is signaled in such case. */)
5248 (object
, start
, end
, coding_system
, noerror
)
5249 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5251 unsigned char digest
[16];
5252 unsigned char value
[33];
5256 int start_char
= 0, end_char
= 0;
5257 int start_byte
= 0, end_byte
= 0;
5259 register struct buffer
*bp
;
5262 if (STRINGP (object
))
5264 if (NILP (coding_system
))
5266 /* Decide the coding-system to encode the data with. */
5268 if (STRING_MULTIBYTE (object
))
5269 /* use default, we can't guess correct value */
5270 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5272 coding_system
= Qraw_text
;
5275 if (NILP (Fcoding_system_p (coding_system
)))
5277 /* Invalid coding system. */
5279 if (!NILP (noerror
))
5280 coding_system
= Qraw_text
;
5283 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5286 if (STRING_MULTIBYTE (object
))
5287 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5289 size
= SCHARS (object
);
5290 size_byte
= SBYTES (object
);
5294 CHECK_NUMBER (start
);
5296 start_char
= XINT (start
);
5301 start_byte
= string_char_to_byte (object
, start_char
);
5307 end_byte
= size_byte
;
5313 end_char
= XINT (end
);
5318 end_byte
= string_char_to_byte (object
, end_char
);
5321 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5322 args_out_of_range_3 (object
, make_number (start_char
),
5323 make_number (end_char
));
5327 CHECK_BUFFER (object
);
5329 bp
= XBUFFER (object
);
5335 CHECK_NUMBER_COERCE_MARKER (start
);
5343 CHECK_NUMBER_COERCE_MARKER (end
);
5348 temp
= b
, b
= e
, e
= temp
;
5350 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5351 args_out_of_range (start
, end
);
5353 if (NILP (coding_system
))
5355 /* Decide the coding-system to encode the data with.
5356 See fileio.c:Fwrite-region */
5358 if (!NILP (Vcoding_system_for_write
))
5359 coding_system
= Vcoding_system_for_write
;
5362 int force_raw_text
= 0;
5364 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5365 if (NILP (coding_system
)
5366 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5368 coding_system
= Qnil
;
5369 if (NILP (current_buffer
->enable_multibyte_characters
))
5373 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5375 /* Check file-coding-system-alist. */
5376 Lisp_Object args
[4], val
;
5378 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5379 args
[3] = Fbuffer_file_name(object
);
5380 val
= Ffind_operation_coding_system (4, args
);
5381 if (CONSP (val
) && !NILP (XCDR (val
)))
5382 coding_system
= XCDR (val
);
5385 if (NILP (coding_system
)
5386 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5388 /* If we still have not decided a coding system, use the
5389 default value of buffer-file-coding-system. */
5390 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5394 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5395 /* Confirm that VAL can surely encode the current region. */
5396 coding_system
= call4 (Vselect_safe_coding_system_function
,
5397 make_number (b
), make_number (e
),
5398 coding_system
, Qnil
);
5401 coding_system
= Qraw_text
;
5404 if (NILP (Fcoding_system_p (coding_system
)))
5406 /* Invalid coding system. */
5408 if (!NILP (noerror
))
5409 coding_system
= Qraw_text
;
5412 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5416 object
= make_buffer_string (b
, e
, 0);
5418 if (STRING_MULTIBYTE (object
))
5419 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5422 md5_buffer (SDATA (object
) + start_byte
,
5423 SBYTES (object
) - (size_byte
- end_byte
),
5426 for (i
= 0; i
< 16; i
++)
5427 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5430 return make_string (value
, 32);
5437 /* Hash table stuff. */
5438 Qhash_table_p
= intern ("hash-table-p");
5439 staticpro (&Qhash_table_p
);
5440 Qeq
= intern ("eq");
5442 Qeql
= intern ("eql");
5444 Qequal
= intern ("equal");
5445 staticpro (&Qequal
);
5446 QCtest
= intern (":test");
5447 staticpro (&QCtest
);
5448 QCsize
= intern (":size");
5449 staticpro (&QCsize
);
5450 QCrehash_size
= intern (":rehash-size");
5451 staticpro (&QCrehash_size
);
5452 QCrehash_threshold
= intern (":rehash-threshold");
5453 staticpro (&QCrehash_threshold
);
5454 QCweakness
= intern (":weakness");
5455 staticpro (&QCweakness
);
5456 Qkey
= intern ("key");
5458 Qvalue
= intern ("value");
5459 staticpro (&Qvalue
);
5460 Qhash_table_test
= intern ("hash-table-test");
5461 staticpro (&Qhash_table_test
);
5462 Qkey_or_value
= intern ("key-or-value");
5463 staticpro (&Qkey_or_value
);
5464 Qkey_and_value
= intern ("key-and-value");
5465 staticpro (&Qkey_and_value
);
5468 defsubr (&Smake_hash_table
);
5469 defsubr (&Scopy_hash_table
);
5470 defsubr (&Shash_table_count
);
5471 defsubr (&Shash_table_rehash_size
);
5472 defsubr (&Shash_table_rehash_threshold
);
5473 defsubr (&Shash_table_size
);
5474 defsubr (&Shash_table_test
);
5475 defsubr (&Shash_table_weakness
);
5476 defsubr (&Shash_table_p
);
5477 defsubr (&Sclrhash
);
5478 defsubr (&Sgethash
);
5479 defsubr (&Sputhash
);
5480 defsubr (&Sremhash
);
5481 defsubr (&Smaphash
);
5482 defsubr (&Sdefine_hash_table_test
);
5484 Qstring_lessp
= intern ("string-lessp");
5485 staticpro (&Qstring_lessp
);
5486 Qprovide
= intern ("provide");
5487 staticpro (&Qprovide
);
5488 Qrequire
= intern ("require");
5489 staticpro (&Qrequire
);
5490 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5491 staticpro (&Qyes_or_no_p_history
);
5492 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5493 staticpro (&Qcursor_in_echo_area
);
5494 Qwidget_type
= intern ("widget-type");
5495 staticpro (&Qwidget_type
);
5497 staticpro (&string_char_byte_cache_string
);
5498 string_char_byte_cache_string
= Qnil
;
5500 require_nesting_list
= Qnil
;
5501 staticpro (&require_nesting_list
);
5503 Fset (Qyes_or_no_p_history
, Qnil
);
5505 DEFVAR_LISP ("features", &Vfeatures
,
5506 doc
: /* A list of symbols which are the features of the executing emacs.
5507 Used by `featurep' and `require', and altered by `provide'. */);
5509 Qsubfeatures
= intern ("subfeatures");
5510 staticpro (&Qsubfeatures
);
5512 #ifdef HAVE_LANGINFO_CODESET
5513 Qcodeset
= intern ("codeset");
5514 staticpro (&Qcodeset
);
5515 Qdays
= intern ("days");
5517 Qmonths
= intern ("months");
5518 staticpro (&Qmonths
);
5519 Qpaper
= intern ("paper");
5520 staticpro (&Qpaper
);
5521 #endif /* HAVE_LANGINFO_CODESET */
5523 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5524 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5525 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5526 invoked by mouse clicks and mouse menu items. */);
5529 defsubr (&Sidentity
);
5532 defsubr (&Ssafe_length
);
5533 defsubr (&Sstring_bytes
);
5534 defsubr (&Sstring_equal
);
5535 defsubr (&Scompare_strings
);
5536 defsubr (&Sstring_lessp
);
5539 defsubr (&Svconcat
);
5540 defsubr (&Scopy_sequence
);
5541 defsubr (&Sstring_make_multibyte
);
5542 defsubr (&Sstring_make_unibyte
);
5543 defsubr (&Sstring_as_multibyte
);
5544 defsubr (&Sstring_as_unibyte
);
5545 defsubr (&Scopy_alist
);
5546 defsubr (&Ssubstring
);
5547 defsubr (&Ssubstring_no_properties
);
5559 defsubr (&Snreverse
);
5560 defsubr (&Sreverse
);
5562 defsubr (&Splist_get
);
5564 defsubr (&Splist_put
);
5566 defsubr (&Slax_plist_get
);
5567 defsubr (&Slax_plist_put
);
5569 defsubr (&Sfillarray
);
5570 defsubr (&Schar_table_subtype
);
5571 defsubr (&Schar_table_parent
);
5572 defsubr (&Sset_char_table_parent
);
5573 defsubr (&Schar_table_extra_slot
);
5574 defsubr (&Sset_char_table_extra_slot
);
5575 defsubr (&Schar_table_range
);
5576 defsubr (&Sset_char_table_range
);
5577 defsubr (&Sset_char_table_default
);
5578 defsubr (&Soptimize_char_table
);
5579 defsubr (&Smap_char_table
);
5583 defsubr (&Smapconcat
);
5584 defsubr (&Sy_or_n_p
);
5585 defsubr (&Syes_or_no_p
);
5586 defsubr (&Sload_average
);
5587 defsubr (&Sfeaturep
);
5588 defsubr (&Srequire
);
5589 defsubr (&Sprovide
);
5590 defsubr (&Splist_member
);
5591 defsubr (&Swidget_put
);
5592 defsubr (&Swidget_get
);
5593 defsubr (&Swidget_apply
);
5594 defsubr (&Sbase64_encode_region
);
5595 defsubr (&Sbase64_decode_region
);
5596 defsubr (&Sbase64_encode_string
);
5597 defsubr (&Sbase64_decode_string
);
5599 defsubr (&Slanginfo
);
5606 Vweak_hash_tables
= Qnil
;