1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
41 #include "intervals.h"
44 #include "blockinput.h"
45 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
50 #define NULL (void *)0
54 #define min(a, b) ((a) < (b) ? (a) : (b))
55 #define max(a, b) ((a) > (b) ? (a) : (b))
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 extern int minibuffer_auto_raise
;
63 extern Lisp_Object minibuf_window
;
65 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
66 Lisp_Object Qyes_or_no_p_history
;
67 Lisp_Object Qcursor_in_echo_area
;
68 Lisp_Object Qwidget_type
;
70 extern Lisp_Object Qinput_method_function
;
72 static int internal_equal ();
74 extern long get_random ();
75 extern void seed_random ();
81 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
82 "Return the argument unchanged.")
89 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
90 "Return a pseudo-random number.\n\
91 All integers representable in Lisp are equally likely.\n\
92 On most systems, this is 28 bits' worth.\n\
93 With positive integer argument N, return random number in interval [0,N).\n\
94 With argument t, set the random number seed from the current time and pid.")
99 Lisp_Object lispy_val
;
100 unsigned long denominator
;
103 seed_random (getpid () + time (NULL
));
104 if (NATNUMP (n
) && XFASTINT (n
) != 0)
106 /* Try to take our random number from the higher bits of VAL,
107 not the lower, since (says Gentzel) the low bits of `random'
108 are less random than the higher ones. We do this by using the
109 quotient rather than the remainder. At the high end of the RNG
110 it's possible to get a quotient larger than n; discarding
111 these values eliminates the bias that would otherwise appear
112 when using a large n. */
113 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
115 val
= get_random () / denominator
;
116 while (val
>= XFASTINT (n
));
120 XSETINT (lispy_val
, val
);
124 /* Random data-structure functions */
126 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
127 "Return the length of vector, list or string SEQUENCE.\n\
128 A byte-code function object is also allowed.\n\
129 If the string contains multibyte characters, this is not the necessarily\n\
130 the number of bytes in the string; it is the number of characters.\n\
131 To get the number of bytes, use `string-bytes'")
133 register Lisp_Object sequence
;
135 register Lisp_Object val
;
139 if (STRINGP (sequence
))
140 XSETFASTINT (val
, XSTRING (sequence
)->size
);
141 else if (VECTORP (sequence
))
142 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
143 else if (CHAR_TABLE_P (sequence
))
144 XSETFASTINT (val
, MAX_CHAR
);
145 else if (BOOL_VECTOR_P (sequence
))
146 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
147 else if (COMPILEDP (sequence
))
148 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
149 else if (CONSP (sequence
))
152 while (CONSP (sequence
))
154 sequence
= XCDR (sequence
);
157 if (!CONSP (sequence
))
160 sequence
= XCDR (sequence
);
165 if (!NILP (sequence
))
166 wrong_type_argument (Qlistp
, sequence
);
168 val
= make_number (i
);
170 else if (NILP (sequence
))
171 XSETFASTINT (val
, 0);
174 sequence
= wrong_type_argument (Qsequencep
, sequence
);
180 /* This does not check for quits. That is safe
181 since it must terminate. */
183 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
184 "Return the length of a list, but avoid error or infinite loop.\n\
185 This function never gets an error. If LIST is not really a list,\n\
186 it returns 0. If LIST is circular, it returns a finite value\n\
187 which is at least the number of distinct elements.")
191 Lisp_Object tail
, halftail
, length
;
194 /* halftail is used to detect circular lists. */
196 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
198 if (EQ (tail
, halftail
) && len
!= 0)
202 halftail
= XCDR (halftail
);
205 XSETINT (length
, len
);
209 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
210 "Return the number of bytes in STRING.\n\
211 If STRING is a multibyte string, this is greater than the length of STRING.")
215 CHECK_STRING (string
, 1);
216 return make_number (STRING_BYTES (XSTRING (string
)));
219 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
220 "Return t if two strings have identical contents.\n\
221 Case is significant, but text properties are ignored.\n\
222 Symbols are also allowed; their print names are used instead.")
224 register Lisp_Object s1
, s2
;
227 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
229 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
230 CHECK_STRING (s1
, 0);
231 CHECK_STRING (s2
, 1);
233 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
234 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
235 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
240 DEFUN ("compare-strings", Fcompare_strings
,
241 Scompare_strings
, 6, 7, 0,
242 "Compare the contents of two strings, converting to multibyte if needed.\n\
243 In string STR1, skip the first START1 characters and stop at END1.\n\
244 In string STR2, skip the first START2 characters and stop at END2.\n\
245 END1 and END2 default to the full lengths of the respective strings.\n\
247 Case is significant in this comparison if IGNORE-CASE is nil.\n\
248 Unibyte strings are converted to multibyte for comparison.\n\
250 The value is t if the strings (or specified portions) match.\n\
251 If string STR1 is less, the value is a negative number N;\n\
252 - 1 - N is the number of characters that match at the beginning.\n\
253 If string STR1 is greater, the value is a positive number N;\n\
254 N - 1 is the number of characters that match at the beginning.")
255 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
256 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
258 register int end1_char
, end2_char
;
259 register int i1
, i1_byte
, i2
, i2_byte
;
261 CHECK_STRING (str1
, 0);
262 CHECK_STRING (str2
, 1);
264 start1
= make_number (0);
266 start2
= make_number (0);
267 CHECK_NATNUM (start1
, 2);
268 CHECK_NATNUM (start2
, 3);
270 CHECK_NATNUM (end1
, 4);
272 CHECK_NATNUM (end2
, 4);
277 i1_byte
= string_char_to_byte (str1
, i1
);
278 i2_byte
= string_char_to_byte (str2
, i2
);
280 end1_char
= XSTRING (str1
)->size
;
281 if (! NILP (end1
) && end1_char
> XINT (end1
))
282 end1_char
= XINT (end1
);
284 end2_char
= XSTRING (str2
)->size
;
285 if (! NILP (end2
) && end2_char
> XINT (end2
))
286 end2_char
= XINT (end2
);
288 while (i1
< end1_char
&& i2
< end2_char
)
290 /* When we find a mismatch, we must compare the
291 characters, not just the bytes. */
294 if (STRING_MULTIBYTE (str1
))
295 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
298 c1
= XSTRING (str1
)->data
[i1
++];
299 c1
= unibyte_char_to_multibyte (c1
);
302 if (STRING_MULTIBYTE (str2
))
303 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
306 c2
= XSTRING (str2
)->data
[i2
++];
307 c2
= unibyte_char_to_multibyte (c2
);
313 if (! NILP (ignore_case
))
317 tem
= Fupcase (make_number (c1
));
319 tem
= Fupcase (make_number (c2
));
326 /* Note that I1 has already been incremented
327 past the character that we are comparing;
328 hence we don't add or subtract 1 here. */
330 return make_number (- i1
+ XINT (start1
));
332 return make_number (i1
- XINT (start1
));
336 return make_number (i1
- XINT (start1
) + 1);
338 return make_number (- i1
+ XINT (start1
) - 1);
343 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
344 "Return t if first arg string is less than second in lexicographic order.\n\
345 Case is significant.\n\
346 Symbols are also allowed; their print names are used instead.")
348 register Lisp_Object s1
, s2
;
351 register int i1
, i1_byte
, i2
, i2_byte
;
354 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
356 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
357 CHECK_STRING (s1
, 0);
358 CHECK_STRING (s2
, 1);
360 i1
= i1_byte
= i2
= i2_byte
= 0;
362 end
= XSTRING (s1
)->size
;
363 if (end
> XSTRING (s2
)->size
)
364 end
= XSTRING (s2
)->size
;
368 /* When we find a mismatch, we must compare the
369 characters, not just the bytes. */
372 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
373 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
376 return c1
< c2
? Qt
: Qnil
;
378 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
381 static Lisp_Object
concat ();
392 return concat (2, args
, Lisp_String
, 0);
394 return concat (2, &s1
, Lisp_String
, 0);
395 #endif /* NO_ARG_ARRAY */
401 Lisp_Object s1
, s2
, s3
;
408 return concat (3, args
, Lisp_String
, 0);
410 return concat (3, &s1
, Lisp_String
, 0);
411 #endif /* NO_ARG_ARRAY */
414 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
415 "Concatenate all the arguments and make the result a list.\n\
416 The result is a list whose elements are the elements of all the arguments.\n\
417 Each argument may be a list, vector or string.\n\
418 The last argument is not copied, just used as the tail of the new list.")
423 return concat (nargs
, args
, Lisp_Cons
, 1);
426 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
427 "Concatenate all the arguments and make the result a string.\n\
428 The result is a string whose elements are the elements of all the arguments.\n\
429 Each argument may be a string or a list or vector of characters (integers).")
434 return concat (nargs
, args
, Lisp_String
, 0);
437 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
438 "Concatenate all the arguments and make the result a vector.\n\
439 The result is a vector whose elements are the elements of all the arguments.\n\
440 Each argument may be a list, vector or string.")
445 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
448 /* Retrun a copy of a sub char table ARG. The elements except for a
449 nested sub char table are not copied. */
451 copy_sub_char_table (arg
)
454 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
457 /* Copy all the contents. */
458 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
459 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
460 /* Recursively copy any sub char-tables in the ordinary slots. */
461 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
462 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
463 XCHAR_TABLE (copy
)->contents
[i
]
464 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
470 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
471 "Return a copy of a list, vector or string.\n\
472 The elements of a list or vector are not copied; they are shared\n\
477 if (NILP (arg
)) return arg
;
479 if (CHAR_TABLE_P (arg
))
484 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
485 /* Copy all the slots, including the extra ones. */
486 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
487 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
488 * sizeof (Lisp_Object
)));
490 /* Recursively copy any sub char tables in the ordinary slots
491 for multibyte characters. */
492 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
493 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
494 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
495 XCHAR_TABLE (copy
)->contents
[i
]
496 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
501 if (BOOL_VECTOR_P (arg
))
505 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
507 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
508 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
513 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
514 arg
= wrong_type_argument (Qsequencep
, arg
);
515 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
518 /* In string STR of length LEN, see if bytes before STR[I] combine
519 with bytes after STR[I] to form a single character. If so, return
520 the number of bytes after STR[I] which combine in this way.
521 Otherwize, return 0. */
524 count_combining (str
, len
, i
)
528 int j
= i
- 1, bytes
;
530 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
532 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
533 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
535 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
536 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
539 /* This structure holds information of an argument of `concat' that is
540 a string and has text properties to be copied. */
543 int argnum
; /* refer to ARGS (arguments of `concat') */
544 int from
; /* refer to ARGS[argnum] (argument string) */
545 int to
; /* refer to VAL (the target string) */
549 concat (nargs
, args
, target_type
, last_special
)
552 enum Lisp_Type target_type
;
556 register Lisp_Object tail
;
557 register Lisp_Object
this;
559 int toindex_byte
= 0;
560 register int result_len
;
561 register int result_len_byte
;
563 Lisp_Object last_tail
;
566 /* When we make a multibyte string, we can't copy text properties
567 while concatinating each string because the length of resulting
568 string can't be decided until we finish the whole concatination.
569 So, we record strings that have text properties to be copied
570 here, and copy the text properties after the concatination. */
571 struct textprop_rec
*textprops
= NULL
;
572 /* Number of elments in textprops. */
573 int num_textprops
= 0;
577 /* In append, the last arg isn't treated like the others */
578 if (last_special
&& nargs
> 0)
581 last_tail
= args
[nargs
];
586 /* Canonicalize each argument. */
587 for (argnum
= 0; argnum
< nargs
; argnum
++)
590 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
591 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
593 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
597 /* Compute total length in chars of arguments in RESULT_LEN.
598 If desired output is a string, also compute length in bytes
599 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
600 whether the result should be a multibyte string. */
604 for (argnum
= 0; argnum
< nargs
; argnum
++)
608 len
= XFASTINT (Flength (this));
609 if (target_type
== Lisp_String
)
611 /* We must count the number of bytes needed in the string
612 as well as the number of characters. */
618 for (i
= 0; i
< len
; i
++)
620 ch
= XVECTOR (this)->contents
[i
];
622 wrong_type_argument (Qintegerp
, ch
);
623 this_len_byte
= CHAR_BYTES (XINT (ch
));
624 result_len_byte
+= this_len_byte
;
625 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
628 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
629 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
630 else if (CONSP (this))
631 for (; CONSP (this); this = XCDR (this))
635 wrong_type_argument (Qintegerp
, ch
);
636 this_len_byte
= CHAR_BYTES (XINT (ch
));
637 result_len_byte
+= this_len_byte
;
638 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
641 else if (STRINGP (this))
643 if (STRING_MULTIBYTE (this))
646 result_len_byte
+= STRING_BYTES (XSTRING (this));
649 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
650 XSTRING (this)->size
);
657 if (! some_multibyte
)
658 result_len_byte
= result_len
;
660 /* Create the output object. */
661 if (target_type
== Lisp_Cons
)
662 val
= Fmake_list (make_number (result_len
), Qnil
);
663 else if (target_type
== Lisp_Vectorlike
)
664 val
= Fmake_vector (make_number (result_len
), Qnil
);
665 else if (some_multibyte
)
666 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
668 val
= make_uninit_string (result_len
);
670 /* In `append', if all but last arg are nil, return last arg. */
671 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
674 /* Copy the contents of the args into the result. */
676 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
678 toindex
= 0, toindex_byte
= 0;
683 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
685 for (argnum
= 0; argnum
< nargs
; argnum
++)
689 register unsigned int thisindex
= 0;
690 register unsigned int thisindex_byte
= 0;
694 thislen
= Flength (this), thisleni
= XINT (thislen
);
696 /* Between strings of the same kind, copy fast. */
697 if (STRINGP (this) && STRINGP (val
)
698 && STRING_MULTIBYTE (this) == some_multibyte
)
700 int thislen_byte
= STRING_BYTES (XSTRING (this));
703 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
704 STRING_BYTES (XSTRING (this)));
705 combined
= (some_multibyte
&& toindex_byte
> 0
706 ? count_combining (XSTRING (val
)->data
,
707 toindex_byte
+ thislen_byte
,
710 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
712 textprops
[num_textprops
].argnum
= argnum
;
713 /* We ignore text properties on characters being combined. */
714 textprops
[num_textprops
].from
= combined
;
715 textprops
[num_textprops
++].to
= toindex
;
717 toindex_byte
+= thislen_byte
;
718 toindex
+= thisleni
- combined
;
719 XSTRING (val
)->size
-= combined
;
721 /* Copy a single-byte string to a multibyte string. */
722 else if (STRINGP (this) && STRINGP (val
))
724 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
726 textprops
[num_textprops
].argnum
= argnum
;
727 textprops
[num_textprops
].from
= 0;
728 textprops
[num_textprops
++].to
= toindex
;
730 toindex_byte
+= copy_text (XSTRING (this)->data
,
731 XSTRING (val
)->data
+ toindex_byte
,
732 XSTRING (this)->size
, 0, 1);
736 /* Copy element by element. */
739 register Lisp_Object elt
;
741 /* Fetch next element of `this' arg into `elt', or break if
742 `this' is exhausted. */
743 if (NILP (this)) break;
745 elt
= XCAR (this), this = XCDR (this);
746 else if (thisindex
>= thisleni
)
748 else if (STRINGP (this))
751 if (STRING_MULTIBYTE (this))
753 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
756 XSETFASTINT (elt
, c
);
760 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
762 && (XINT (elt
) >= 0240
763 || (XINT (elt
) >= 0200
764 && ! NILP (Vnonascii_translation_table
)))
765 && XINT (elt
) < 0400)
767 c
= unibyte_char_to_multibyte (XINT (elt
));
772 else if (BOOL_VECTOR_P (this))
775 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
776 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
783 elt
= XVECTOR (this)->contents
[thisindex
++];
785 /* Store this element into the result. */
792 else if (VECTORP (val
))
793 XVECTOR (val
)->contents
[toindex
++] = elt
;
796 CHECK_NUMBER (elt
, 0);
797 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
801 += CHAR_STRING (XINT (elt
),
802 XSTRING (val
)->data
+ toindex_byte
);
804 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
807 && count_combining (XSTRING (val
)->data
,
808 toindex_byte
, toindex_byte
- 1))
809 XSTRING (val
)->size
--;
814 /* If we have any multibyte characters,
815 we already decided to make a multibyte string. */
818 /* P exists as a variable
819 to avoid a bug on the Masscomp C compiler. */
820 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
822 toindex_byte
+= CHAR_STRING (c
, p
);
829 XCDR (prev
) = last_tail
;
831 if (num_textprops
> 0)
834 int last_to_end
= -1;
836 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
838 this = args
[textprops
[argnum
].argnum
];
839 props
= text_property_list (this,
841 make_number (XSTRING (this)->size
),
843 /* If successive arguments have properites, be sure that the
844 value of `composition' property be the copy. */
845 if (last_to_end
== textprops
[argnum
].to
)
846 make_composition_value_copy (props
);
847 add_text_properties_from_list (val
, props
,
848 make_number (textprops
[argnum
].to
));
849 last_to_end
= textprops
[argnum
].to
+ XSTRING (this)->size
;
855 static Lisp_Object string_char_byte_cache_string
;
856 static int string_char_byte_cache_charpos
;
857 static int string_char_byte_cache_bytepos
;
860 clear_string_char_byte_cache ()
862 string_char_byte_cache_string
= Qnil
;
865 /* Return the character index corresponding to CHAR_INDEX in STRING. */
868 string_char_to_byte (string
, char_index
)
873 int best_below
, best_below_byte
;
874 int best_above
, best_above_byte
;
876 if (! STRING_MULTIBYTE (string
))
879 best_below
= best_below_byte
= 0;
880 best_above
= XSTRING (string
)->size
;
881 best_above_byte
= STRING_BYTES (XSTRING (string
));
883 if (EQ (string
, string_char_byte_cache_string
))
885 if (string_char_byte_cache_charpos
< char_index
)
887 best_below
= string_char_byte_cache_charpos
;
888 best_below_byte
= string_char_byte_cache_bytepos
;
892 best_above
= string_char_byte_cache_charpos
;
893 best_above_byte
= string_char_byte_cache_bytepos
;
897 if (char_index
- best_below
< best_above
- char_index
)
899 while (best_below
< char_index
)
902 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
903 best_below
, best_below_byte
);
906 i_byte
= best_below_byte
;
910 while (best_above
> char_index
)
912 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
913 unsigned char *pbeg
= pend
- best_above_byte
;
914 unsigned char *p
= pend
- 1;
917 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
918 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
919 if (bytes
== pend
- p
)
920 best_above_byte
-= bytes
;
921 else if (bytes
> pend
- p
)
922 best_above_byte
-= (pend
- p
);
928 i_byte
= best_above_byte
;
931 string_char_byte_cache_bytepos
= i_byte
;
932 string_char_byte_cache_charpos
= i
;
933 string_char_byte_cache_string
= string
;
938 /* Return the character index corresponding to BYTE_INDEX in STRING. */
941 string_byte_to_char (string
, byte_index
)
946 int best_below
, best_below_byte
;
947 int best_above
, best_above_byte
;
949 if (! STRING_MULTIBYTE (string
))
952 best_below
= best_below_byte
= 0;
953 best_above
= XSTRING (string
)->size
;
954 best_above_byte
= STRING_BYTES (XSTRING (string
));
956 if (EQ (string
, string_char_byte_cache_string
))
958 if (string_char_byte_cache_bytepos
< byte_index
)
960 best_below
= string_char_byte_cache_charpos
;
961 best_below_byte
= string_char_byte_cache_bytepos
;
965 best_above
= string_char_byte_cache_charpos
;
966 best_above_byte
= string_char_byte_cache_bytepos
;
970 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
972 while (best_below_byte
< byte_index
)
975 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
976 best_below
, best_below_byte
);
979 i_byte
= best_below_byte
;
983 while (best_above_byte
> byte_index
)
985 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
986 unsigned char *pbeg
= pend
- best_above_byte
;
987 unsigned char *p
= pend
- 1;
990 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
991 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
992 if (bytes
== pend
- p
)
993 best_above_byte
-= bytes
;
994 else if (bytes
> pend
- p
)
995 best_above_byte
-= (pend
- p
);
1001 i_byte
= best_above_byte
;
1004 string_char_byte_cache_bytepos
= i_byte
;
1005 string_char_byte_cache_charpos
= i
;
1006 string_char_byte_cache_string
= string
;
1011 /* Convert STRING to a multibyte string.
1012 Single-byte characters 0240 through 0377 are converted
1013 by adding nonascii_insert_offset to each. */
1016 string_make_multibyte (string
)
1022 if (STRING_MULTIBYTE (string
))
1025 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1026 XSTRING (string
)->size
);
1027 /* If all the chars are ASCII, they won't need any more bytes
1028 once converted. In that case, we can return STRING itself. */
1029 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1032 buf
= (unsigned char *) alloca (nbytes
);
1033 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1036 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1039 /* Convert STRING to a single-byte string. */
1042 string_make_unibyte (string
)
1047 if (! STRING_MULTIBYTE (string
))
1050 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1052 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1055 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1058 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1060 "Return the multibyte equivalent of STRING.\n\
1061 The function `unibyte-char-to-multibyte' is used to convert\n\
1062 each unibyte character to a multibyte character.")
1066 CHECK_STRING (string
, 0);
1068 return string_make_multibyte (string
);
1071 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1073 "Return the unibyte equivalent of STRING.\n\
1074 Multibyte character codes are converted to unibyte\n\
1075 by using just the low 8 bits.")
1079 CHECK_STRING (string
, 0);
1081 return string_make_unibyte (string
);
1084 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1086 "Return a unibyte string with the same individual bytes as STRING.\n\
1087 If STRING is unibyte, the result is STRING itself.\n\
1088 Otherwise it is a newly created string, with no text properties.\n\
1089 If STRING is multibyte and contains a character of charset\n\
1090 `eight-bit-control' or `eight-bit-graphic', it is converted to the\n\
1091 corresponding single byte.")
1095 CHECK_STRING (string
, 0);
1097 if (STRING_MULTIBYTE (string
))
1099 int bytes
= STRING_BYTES (XSTRING (string
));
1100 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1102 bcopy (XSTRING (string
)->data
, str
, bytes
);
1103 bytes
= str_as_unibyte (str
, bytes
);
1104 string
= make_unibyte_string (str
, bytes
);
1110 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1112 "Return a multibyte string with the same individual bytes as STRING.\n\
1113 If STRING is multibyte, the result is STRING itself.\n\
1114 Otherwise it is a newly created string, with no text properties.\n\
1115 If STRING is unibyte and contains an individual 8-bit byte (i.e. not\n\
1116 part of a multibyte form), it is converted to the corresponding\n\
1117 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.")
1121 CHECK_STRING (string
, 0);
1123 if (! STRING_MULTIBYTE (string
))
1125 Lisp_Object new_string
;
1128 parse_str_as_multibyte (XSTRING (string
)->data
,
1129 STRING_BYTES (XSTRING (string
)),
1131 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1132 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1133 STRING_BYTES (XSTRING (string
)));
1134 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1135 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1136 STRING_BYTES (XSTRING (string
)), NULL
);
1137 string
= new_string
;
1138 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1143 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1144 "Return a copy of ALIST.\n\
1145 This is an alist which represents the same mapping from objects to objects,\n\
1146 but does not share the alist structure with ALIST.\n\
1147 The objects mapped (cars and cdrs of elements of the alist)\n\
1148 are shared, however.\n\
1149 Elements of ALIST that are not conses are also shared.")
1153 register Lisp_Object tem
;
1155 CHECK_LIST (alist
, 0);
1158 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1159 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1161 register Lisp_Object car
;
1165 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1170 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1171 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1172 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1173 If FROM or TO is negative, it counts from the end.\n\
1175 This function allows vectors as well as strings.")
1178 register Lisp_Object from
, to
;
1183 int from_char
, to_char
;
1184 int from_byte
= 0, to_byte
= 0;
1186 if (! (STRINGP (string
) || VECTORP (string
)))
1187 wrong_type_argument (Qarrayp
, string
);
1189 CHECK_NUMBER (from
, 1);
1191 if (STRINGP (string
))
1193 size
= XSTRING (string
)->size
;
1194 size_byte
= STRING_BYTES (XSTRING (string
));
1197 size
= XVECTOR (string
)->size
;
1202 to_byte
= size_byte
;
1206 CHECK_NUMBER (to
, 2);
1208 to_char
= XINT (to
);
1212 if (STRINGP (string
))
1213 to_byte
= string_char_to_byte (string
, to_char
);
1216 from_char
= XINT (from
);
1219 if (STRINGP (string
))
1220 from_byte
= string_char_to_byte (string
, from_char
);
1222 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1223 args_out_of_range_3 (string
, make_number (from_char
),
1224 make_number (to_char
));
1226 if (STRINGP (string
))
1228 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1229 to_char
- from_char
, to_byte
- from_byte
,
1230 STRING_MULTIBYTE (string
));
1231 copy_text_properties (make_number (from_char
), make_number (to_char
),
1232 string
, make_number (0), res
, Qnil
);
1235 res
= Fvector (to_char
- from_char
,
1236 XVECTOR (string
)->contents
+ from_char
);
1241 /* Extract a substring of STRING, giving start and end positions
1242 both in characters and in bytes. */
1245 substring_both (string
, from
, from_byte
, to
, to_byte
)
1247 int from
, from_byte
, to
, to_byte
;
1253 if (! (STRINGP (string
) || VECTORP (string
)))
1254 wrong_type_argument (Qarrayp
, string
);
1256 if (STRINGP (string
))
1258 size
= XSTRING (string
)->size
;
1259 size_byte
= STRING_BYTES (XSTRING (string
));
1262 size
= XVECTOR (string
)->size
;
1264 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1265 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1267 if (STRINGP (string
))
1269 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1270 to
- from
, to_byte
- from_byte
,
1271 STRING_MULTIBYTE (string
));
1272 copy_text_properties (make_number (from
), make_number (to
),
1273 string
, make_number (0), res
, Qnil
);
1276 res
= Fvector (to
- from
,
1277 XVECTOR (string
)->contents
+ from
);
1282 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1283 "Take cdr N times on LIST, returns the result.")
1286 register Lisp_Object list
;
1288 register int i
, num
;
1289 CHECK_NUMBER (n
, 0);
1291 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1295 wrong_type_argument (Qlistp
, list
);
1301 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1302 "Return the Nth element of LIST.\n\
1303 N counts from zero. If LIST is not that long, nil is returned.")
1305 Lisp_Object n
, list
;
1307 return Fcar (Fnthcdr (n
, list
));
1310 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1311 "Return element of SEQUENCE at index N.")
1313 register Lisp_Object sequence
, n
;
1315 CHECK_NUMBER (n
, 0);
1318 if (CONSP (sequence
) || NILP (sequence
))
1319 return Fcar (Fnthcdr (n
, sequence
));
1320 else if (STRINGP (sequence
) || VECTORP (sequence
)
1321 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1322 return Faref (sequence
, n
);
1324 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1328 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1329 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1330 The value is actually the tail of LIST whose car is ELT.")
1332 register Lisp_Object elt
;
1335 register Lisp_Object tail
;
1336 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1338 register Lisp_Object tem
;
1340 wrong_type_argument (Qlistp
, list
);
1342 if (! NILP (Fequal (elt
, tem
)))
1349 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1350 "Return non-nil if ELT is an element of LIST.\n\
1351 Comparison done with EQ. The value is actually the tail of LIST\n\
1354 Lisp_Object elt
, list
;
1358 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1362 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1366 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1373 if (!CONSP (list
) && !NILP (list
))
1374 list
= wrong_type_argument (Qlistp
, list
);
1379 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1380 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1381 The value is actually the element of LIST whose car is KEY.\n\
1382 Elements of LIST that are not conses are ignored.")
1384 Lisp_Object key
, list
;
1391 || (CONSP (XCAR (list
))
1392 && EQ (XCAR (XCAR (list
)), key
)))
1397 || (CONSP (XCAR (list
))
1398 && EQ (XCAR (XCAR (list
)), key
)))
1403 || (CONSP (XCAR (list
))
1404 && EQ (XCAR (XCAR (list
)), key
)))
1412 result
= XCAR (list
);
1413 else if (NILP (list
))
1416 result
= wrong_type_argument (Qlistp
, list
);
1421 /* Like Fassq but never report an error and do not allow quits.
1422 Use only on lists known never to be circular. */
1425 assq_no_quit (key
, list
)
1426 Lisp_Object key
, list
;
1429 && (!CONSP (XCAR (list
))
1430 || !EQ (XCAR (XCAR (list
)), key
)))
1433 return CONSP (list
) ? XCAR (list
) : Qnil
;
1436 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1437 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1438 The value is actually the element of LIST whose car equals KEY.")
1440 Lisp_Object key
, list
;
1442 Lisp_Object result
, car
;
1447 || (CONSP (XCAR (list
))
1448 && (car
= XCAR (XCAR (list
)),
1449 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1454 || (CONSP (XCAR (list
))
1455 && (car
= XCAR (XCAR (list
)),
1456 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1461 || (CONSP (XCAR (list
))
1462 && (car
= XCAR (XCAR (list
)),
1463 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1471 result
= XCAR (list
);
1472 else if (NILP (list
))
1475 result
= wrong_type_argument (Qlistp
, list
);
1480 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1481 "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
1482 The value is actually the element of LIST whose cdr is KEY.")
1484 register Lisp_Object key
;
1492 || (CONSP (XCAR (list
))
1493 && EQ (XCDR (XCAR (list
)), key
)))
1498 || (CONSP (XCAR (list
))
1499 && EQ (XCDR (XCAR (list
)), key
)))
1504 || (CONSP (XCAR (list
))
1505 && EQ (XCDR (XCAR (list
)), key
)))
1514 else if (CONSP (list
))
1515 result
= XCAR (list
);
1517 result
= wrong_type_argument (Qlistp
, list
);
1522 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1523 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1524 The value is actually the element of LIST whose cdr equals KEY.")
1526 Lisp_Object key
, list
;
1528 Lisp_Object result
, cdr
;
1533 || (CONSP (XCAR (list
))
1534 && (cdr
= XCDR (XCAR (list
)),
1535 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1540 || (CONSP (XCAR (list
))
1541 && (cdr
= XCDR (XCAR (list
)),
1542 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1547 || (CONSP (XCAR (list
))
1548 && (cdr
= XCDR (XCAR (list
)),
1549 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1557 result
= XCAR (list
);
1558 else if (NILP (list
))
1561 result
= wrong_type_argument (Qlistp
, list
);
1566 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1567 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1568 The modified LIST is returned. Comparison is done with `eq'.\n\
1569 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1570 therefore, write `(setq foo (delq element foo))'\n\
1571 to be sure of changing the value of `foo'.")
1573 register Lisp_Object elt
;
1576 register Lisp_Object tail
, prev
;
1577 register Lisp_Object tem
;
1581 while (!NILP (tail
))
1584 wrong_type_argument (Qlistp
, list
);
1591 Fsetcdr (prev
, XCDR (tail
));
1601 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1602 "Delete by side effect any occurrences of ELT as a member of SEQ.\n\
1603 SEQ must be a list, a vector, or a string.\n\
1604 The modified SEQ is returned. Comparison is done with `equal'.\n\
1605 If SEQ is not a list, or the first member of SEQ is ELT, deleting it\n\
1606 is not a side effect; it is simply using a different sequence.\n\
1607 Therefore, write `(setq foo (delete element foo))'\n\
1608 to be sure of changing the value of `foo'.")
1610 Lisp_Object elt
, seq
;
1616 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1617 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1620 if (n
!= ASIZE (seq
))
1622 struct Lisp_Vector
*p
= allocate_vector (n
);
1624 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1625 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1626 p
->contents
[n
++] = AREF (seq
, i
);
1628 XSETVECTOR (seq
, p
);
1631 else if (STRINGP (seq
))
1633 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1636 for (i
= nchars
= nbytes
= ibyte
= 0;
1637 i
< XSTRING (seq
)->size
;
1638 ++i
, ibyte
+= cbytes
)
1640 if (STRING_MULTIBYTE (seq
))
1642 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1643 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1644 cbytes
= CHAR_BYTES (c
);
1648 c
= XSTRING (seq
)->data
[i
];
1652 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1659 if (nchars
!= XSTRING (seq
)->size
)
1663 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1664 if (!STRING_MULTIBYTE (seq
))
1665 SET_STRING_BYTES (XSTRING (tem
), -1);
1667 for (i
= nchars
= nbytes
= ibyte
= 0;
1668 i
< XSTRING (seq
)->size
;
1669 ++i
, ibyte
+= cbytes
)
1671 if (STRING_MULTIBYTE (seq
))
1673 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1674 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1675 cbytes
= CHAR_BYTES (c
);
1679 c
= XSTRING (seq
)->data
[i
];
1683 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1685 unsigned char *from
= &XSTRING (seq
)->data
[ibyte
];
1686 unsigned char *to
= &XSTRING (tem
)->data
[nbytes
];
1692 for (n
= cbytes
; n
--; )
1702 Lisp_Object tail
, prev
;
1704 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1707 wrong_type_argument (Qlistp
, seq
);
1709 if (!NILP (Fequal (elt
, XCAR (tail
))))
1714 Fsetcdr (prev
, XCDR (tail
));
1725 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1726 "Reverse LIST by modifying cdr pointers.\n\
1727 Returns the beginning of the reversed list.")
1731 register Lisp_Object prev
, tail
, next
;
1733 if (NILP (list
)) return list
;
1736 while (!NILP (tail
))
1740 wrong_type_argument (Qlistp
, list
);
1742 Fsetcdr (tail
, prev
);
1749 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1750 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1751 See also the function `nreverse', which is used more often.")
1757 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1758 new = Fcons (XCAR (list
), new);
1760 wrong_type_argument (Qconsp
, list
);
1764 Lisp_Object
merge ();
1766 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1767 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1768 Returns the sorted list. LIST is modified by side effects.\n\
1769 PREDICATE is called with two elements of LIST, and should return T\n\
1770 if the first element is \"less\" than the second.")
1772 Lisp_Object list
, predicate
;
1774 Lisp_Object front
, back
;
1775 register Lisp_Object len
, tem
;
1776 struct gcpro gcpro1
, gcpro2
;
1777 register int length
;
1780 len
= Flength (list
);
1781 length
= XINT (len
);
1785 XSETINT (len
, (length
/ 2) - 1);
1786 tem
= Fnthcdr (len
, list
);
1788 Fsetcdr (tem
, Qnil
);
1790 GCPRO2 (front
, back
);
1791 front
= Fsort (front
, predicate
);
1792 back
= Fsort (back
, predicate
);
1794 return merge (front
, back
, predicate
);
1798 merge (org_l1
, org_l2
, pred
)
1799 Lisp_Object org_l1
, org_l2
;
1803 register Lisp_Object tail
;
1805 register Lisp_Object l1
, l2
;
1806 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1813 /* It is sufficient to protect org_l1 and org_l2.
1814 When l1 and l2 are updated, we copy the new values
1815 back into the org_ vars. */
1816 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1836 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1852 Fsetcdr (tail
, tem
);
1858 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1859 "Extract a value from a property list.\n\
1860 PLIST is a property list, which is a list of the form\n\
1861 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1862 corresponding to the given PROP, or nil if PROP is not\n\
1863 one of the properties on the list.")
1871 CONSP (tail
) && CONSP (XCDR (tail
));
1872 tail
= XCDR (XCDR (tail
)))
1874 if (EQ (prop
, XCAR (tail
)))
1875 return XCAR (XCDR (tail
));
1877 /* This function can be called asynchronously
1878 (setup_coding_system). Don't QUIT in that case. */
1879 if (!interrupt_input_blocked
)
1884 wrong_type_argument (Qlistp
, prop
);
1889 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1890 "Return the value of SYMBOL's PROPNAME property.\n\
1891 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1893 Lisp_Object symbol
, propname
;
1895 CHECK_SYMBOL (symbol
, 0);
1896 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1899 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1900 "Change value in PLIST of PROP to VAL.\n\
1901 PLIST is a property list, which is a list of the form\n\
1902 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1903 If PROP is already a property on the list, its value is set to VAL,\n\
1904 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1905 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1906 The PLIST is modified by side effects.")
1909 register Lisp_Object prop
;
1912 register Lisp_Object tail
, prev
;
1913 Lisp_Object newcell
;
1915 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1916 tail
= XCDR (XCDR (tail
)))
1918 if (EQ (prop
, XCAR (tail
)))
1920 Fsetcar (XCDR (tail
), val
);
1927 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1931 Fsetcdr (XCDR (prev
), newcell
);
1935 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1936 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1937 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1938 (symbol
, propname
, value
)
1939 Lisp_Object symbol
, propname
, value
;
1941 CHECK_SYMBOL (symbol
, 0);
1942 XSYMBOL (symbol
)->plist
1943 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1947 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1948 "Return t if two Lisp objects have similar structure and contents.\n\
1949 They must have the same data type.\n\
1950 Conses are compared by comparing the cars and the cdrs.\n\
1951 Vectors and strings are compared element by element.\n\
1952 Numbers are compared by value, but integers cannot equal floats.\n\
1953 (Use `=' if you want integers and floats to be able to be equal.)\n\
1954 Symbols must match exactly.")
1956 register Lisp_Object o1
, o2
;
1958 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1962 internal_equal (o1
, o2
, depth
)
1963 register Lisp_Object o1
, o2
;
1967 error ("Stack overflow in equal");
1973 if (XTYPE (o1
) != XTYPE (o2
))
1979 return (extract_float (o1
) == extract_float (o2
));
1982 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1989 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1993 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1995 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1998 o1
= XOVERLAY (o1
)->plist
;
1999 o2
= XOVERLAY (o2
)->plist
;
2004 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2005 && (XMARKER (o1
)->buffer
== 0
2006 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2010 case Lisp_Vectorlike
:
2012 register int i
, size
;
2013 size
= XVECTOR (o1
)->size
;
2014 /* Pseudovectors have the type encoded in the size field, so this test
2015 actually checks that the objects have the same type as well as the
2017 if (XVECTOR (o2
)->size
!= size
)
2019 /* Boolvectors are compared much like strings. */
2020 if (BOOL_VECTOR_P (o1
))
2023 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2025 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2027 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2032 if (WINDOW_CONFIGURATIONP (o1
))
2033 return compare_window_configurations (o1
, o2
, 0);
2035 /* Aside from them, only true vectors, char-tables, and compiled
2036 functions are sensible to compare, so eliminate the others now. */
2037 if (size
& PSEUDOVECTOR_FLAG
)
2039 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2041 size
&= PSEUDOVECTOR_SIZE_MASK
;
2043 for (i
= 0; i
< size
; i
++)
2046 v1
= XVECTOR (o1
)->contents
[i
];
2047 v2
= XVECTOR (o2
)->contents
[i
];
2048 if (!internal_equal (v1
, v2
, depth
+ 1))
2056 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
2058 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
2060 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
2061 STRING_BYTES (XSTRING (o1
))))
2067 case Lisp_Type_Limit
:
2074 extern Lisp_Object
Fmake_char_internal ();
2076 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2077 "Store each element of ARRAY with ITEM.\n\
2078 ARRAY is a vector, string, char-table, or bool-vector.")
2080 Lisp_Object array
, item
;
2082 register int size
, index
, charval
;
2084 if (VECTORP (array
))
2086 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2087 size
= XVECTOR (array
)->size
;
2088 for (index
= 0; index
< size
; index
++)
2091 else if (CHAR_TABLE_P (array
))
2093 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2094 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2095 for (index
= 0; index
< size
; index
++)
2097 XCHAR_TABLE (array
)->defalt
= Qnil
;
2099 else if (STRINGP (array
))
2101 register unsigned char *p
= XSTRING (array
)->data
;
2102 CHECK_NUMBER (item
, 1);
2103 charval
= XINT (item
);
2104 size
= XSTRING (array
)->size
;
2105 if (STRING_MULTIBYTE (array
))
2107 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2108 int len
= CHAR_STRING (charval
, str
);
2109 int size_byte
= STRING_BYTES (XSTRING (array
));
2110 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2113 if (size
!= size_byte
)
2116 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2117 if (len
!= this_len
)
2118 error ("Attempt to change byte length of a string");
2121 for (i
= 0; i
< size_byte
; i
++)
2122 *p
++ = str
[i
% len
];
2125 for (index
= 0; index
< size
; index
++)
2128 else if (BOOL_VECTOR_P (array
))
2130 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2132 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2134 charval
= (! NILP (item
) ? -1 : 0);
2135 for (index
= 0; index
< size_in_chars
; index
++)
2140 array
= wrong_type_argument (Qarrayp
, array
);
2146 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2148 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
2150 Lisp_Object char_table
;
2152 CHECK_CHAR_TABLE (char_table
, 0);
2154 return XCHAR_TABLE (char_table
)->purpose
;
2157 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2159 "Return the parent char-table of CHAR-TABLE.\n\
2160 The value is either nil or another char-table.\n\
2161 If CHAR-TABLE holds nil for a given character,\n\
2162 then the actual applicable value is inherited from the parent char-table\n\
2163 \(or from its parents, if necessary).")
2165 Lisp_Object char_table
;
2167 CHECK_CHAR_TABLE (char_table
, 0);
2169 return XCHAR_TABLE (char_table
)->parent
;
2172 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2174 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
2175 PARENT must be either nil or another char-table.")
2176 (char_table
, parent
)
2177 Lisp_Object char_table
, parent
;
2181 CHECK_CHAR_TABLE (char_table
, 0);
2185 CHECK_CHAR_TABLE (parent
, 0);
2187 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2188 if (EQ (temp
, char_table
))
2189 error ("Attempt to make a chartable be its own parent");
2192 XCHAR_TABLE (char_table
)->parent
= parent
;
2197 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2199 "Return the value of CHAR-TABLE's extra-slot number N.")
2201 Lisp_Object char_table
, n
;
2203 CHECK_CHAR_TABLE (char_table
, 1);
2204 CHECK_NUMBER (n
, 2);
2206 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2207 args_out_of_range (char_table
, n
);
2209 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2212 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2213 Sset_char_table_extra_slot
,
2215 "Set CHAR-TABLE's extra-slot number N to VALUE.")
2216 (char_table
, n
, value
)
2217 Lisp_Object char_table
, n
, value
;
2219 CHECK_CHAR_TABLE (char_table
, 1);
2220 CHECK_NUMBER (n
, 2);
2222 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2223 args_out_of_range (char_table
, n
);
2225 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2228 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2230 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
2231 RANGE should be nil (for the default value)\n\
2232 a vector which identifies a character set or a row of a character set,\n\
2233 a character set name, or a character code.")
2235 Lisp_Object char_table
, range
;
2237 CHECK_CHAR_TABLE (char_table
, 0);
2239 if (EQ (range
, Qnil
))
2240 return XCHAR_TABLE (char_table
)->defalt
;
2241 else if (INTEGERP (range
))
2242 return Faref (char_table
, range
);
2243 else if (SYMBOLP (range
))
2245 Lisp_Object charset_info
;
2247 charset_info
= Fget (range
, Qcharset
);
2248 CHECK_VECTOR (charset_info
, 0);
2250 return Faref (char_table
,
2251 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2254 else if (VECTORP (range
))
2256 if (XVECTOR (range
)->size
== 1)
2257 return Faref (char_table
,
2258 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2261 int size
= XVECTOR (range
)->size
;
2262 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2263 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2264 size
<= 1 ? Qnil
: val
[1],
2265 size
<= 2 ? Qnil
: val
[2]);
2266 return Faref (char_table
, ch
);
2270 error ("Invalid RANGE argument to `char-table-range'");
2274 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2276 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2277 RANGE should be t (for all characters), nil (for the default value)\n\
2278 a vector which identifies a character set or a row of a character set,\n\
2279 a coding system, or a character code.")
2280 (char_table
, range
, value
)
2281 Lisp_Object char_table
, range
, value
;
2285 CHECK_CHAR_TABLE (char_table
, 0);
2288 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2289 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2290 else if (EQ (range
, Qnil
))
2291 XCHAR_TABLE (char_table
)->defalt
= value
;
2292 else if (SYMBOLP (range
))
2294 Lisp_Object charset_info
;
2296 charset_info
= Fget (range
, Qcharset
);
2297 CHECK_VECTOR (charset_info
, 0);
2299 return Faset (char_table
,
2300 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2304 else if (INTEGERP (range
))
2305 Faset (char_table
, range
, value
);
2306 else if (VECTORP (range
))
2308 if (XVECTOR (range
)->size
== 1)
2309 return Faset (char_table
,
2310 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2314 int size
= XVECTOR (range
)->size
;
2315 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2316 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2317 size
<= 1 ? Qnil
: val
[1],
2318 size
<= 2 ? Qnil
: val
[2]);
2319 return Faset (char_table
, ch
, value
);
2323 error ("Invalid RANGE argument to `set-char-table-range'");
2328 DEFUN ("set-char-table-default", Fset_char_table_default
,
2329 Sset_char_table_default
, 3, 3, 0,
2330 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2331 The generic character specifies the group of characters.\n\
2332 See also the documentation of make-char.")
2333 (char_table
, ch
, value
)
2334 Lisp_Object char_table
, ch
, value
;
2336 int c
, charset
, code1
, code2
;
2339 CHECK_CHAR_TABLE (char_table
, 0);
2340 CHECK_NUMBER (ch
, 1);
2343 SPLIT_CHAR (c
, charset
, code1
, code2
);
2345 /* Since we may want to set the default value for a character set
2346 not yet defined, we check only if the character set is in the
2347 valid range or not, instead of it is already defined or not. */
2348 if (! CHARSET_VALID_P (charset
))
2349 invalid_character (c
);
2351 if (charset
== CHARSET_ASCII
)
2352 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2354 /* Even if C is not a generic char, we had better behave as if a
2355 generic char is specified. */
2356 if (CHARSET_DIMENSION (charset
) == 1)
2358 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2361 if (SUB_CHAR_TABLE_P (temp
))
2362 XCHAR_TABLE (temp
)->defalt
= value
;
2364 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2367 if (SUB_CHAR_TABLE_P (temp
))
2370 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2371 = make_sub_char_table (temp
));
2372 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2373 if (SUB_CHAR_TABLE_P (temp
))
2374 XCHAR_TABLE (temp
)->defalt
= value
;
2376 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2380 /* Look up the element in TABLE at index CH,
2381 and return it as an integer.
2382 If the element is nil, return CH itself.
2383 (Actually we do that for any non-integer.) */
2386 char_table_translate (table
, ch
)
2391 value
= Faref (table
, make_number (ch
));
2392 if (! INTEGERP (value
))
2394 return XINT (value
);
2398 optimize_sub_char_table (table
, chars
)
2406 from
= 33, to
= 127;
2408 from
= 32, to
= 128;
2410 if (!SUB_CHAR_TABLE_P (*table
))
2412 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2413 for (; from
< to
; from
++)
2414 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2419 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2421 "Optimize char table TABLE.")
2429 CHECK_CHAR_TABLE (table
, 0);
2431 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2433 elt
= XCHAR_TABLE (table
)->contents
[i
];
2434 if (!SUB_CHAR_TABLE_P (elt
))
2436 dim
= CHARSET_DIMENSION (i
- 128);
2438 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2439 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2440 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2446 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2447 character or group of characters that share a value.
2448 DEPTH is the current depth in the originally specified
2449 chartable, and INDICES contains the vector indices
2450 for the levels our callers have descended.
2452 ARG is passed to C_FUNCTION when that is called. */
2455 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2456 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2457 Lisp_Object function
, subtable
, arg
, *indices
;
2464 /* At first, handle ASCII and 8-bit European characters. */
2465 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2467 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2469 (*c_function
) (arg
, make_number (i
), elt
);
2471 call2 (function
, make_number (i
), elt
);
2473 #if 0 /* If the char table has entries for higher characters,
2474 we should report them. */
2475 if (NILP (current_buffer
->enable_multibyte_characters
))
2478 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2482 int charset
= XFASTINT (indices
[0]) - 128;
2485 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2486 if (CHARSET_CHARS (charset
) == 94)
2495 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2496 XSETFASTINT (indices
[depth
], i
);
2497 charset
= XFASTINT (indices
[0]) - 128;
2499 && (!CHARSET_DEFINED_P (charset
)
2500 || charset
== CHARSET_8_BIT_CONTROL
2501 || charset
== CHARSET_8_BIT_GRAPHIC
))
2504 if (SUB_CHAR_TABLE_P (elt
))
2507 error ("Too deep char table");
2508 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2515 elt
= XCHAR_TABLE (subtable
)->defalt
;
2516 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2517 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2518 c
= MAKE_CHAR (charset
, c1
, c2
);
2520 (*c_function
) (arg
, make_number (c
), elt
);
2522 call2 (function
, make_number (c
), elt
);
2527 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2529 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2530 FUNCTION is called with two arguments--a key and a value.\n\
2531 The key is always a possible IDX argument to `aref'.")
2532 (function
, char_table
)
2533 Lisp_Object function
, char_table
;
2535 /* The depth of char table is at most 3. */
2536 Lisp_Object indices
[3];
2538 CHECK_CHAR_TABLE (char_table
, 1);
2540 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2544 /* Return a value for character C in char-table TABLE. Store the
2545 actual index for that value in *IDX. Ignore the default value of
2549 char_table_ref_and_index (table
, c
, idx
)
2553 int charset
, c1
, c2
;
2556 if (SINGLE_BYTE_CHAR_P (c
))
2559 return XCHAR_TABLE (table
)->contents
[c
];
2561 SPLIT_CHAR (c
, charset
, c1
, c2
);
2562 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2563 *idx
= MAKE_CHAR (charset
, 0, 0);
2564 if (!SUB_CHAR_TABLE_P (elt
))
2566 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2567 return XCHAR_TABLE (elt
)->defalt
;
2568 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2569 *idx
= MAKE_CHAR (charset
, c1
, 0);
2570 if (!SUB_CHAR_TABLE_P (elt
))
2572 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2573 return XCHAR_TABLE (elt
)->defalt
;
2575 return XCHAR_TABLE (elt
)->contents
[c2
];
2585 Lisp_Object args
[2];
2588 return Fnconc (2, args
);
2590 return Fnconc (2, &s1
);
2591 #endif /* NO_ARG_ARRAY */
2594 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2595 "Concatenate any number of lists by altering them.\n\
2596 Only the last argument is not altered, and need not be a list.")
2601 register int argnum
;
2602 register Lisp_Object tail
, tem
, val
;
2606 for (argnum
= 0; argnum
< nargs
; argnum
++)
2609 if (NILP (tem
)) continue;
2614 if (argnum
+ 1 == nargs
) break;
2617 tem
= wrong_type_argument (Qlistp
, tem
);
2626 tem
= args
[argnum
+ 1];
2627 Fsetcdr (tail
, tem
);
2629 args
[argnum
+ 1] = tail
;
2635 /* This is the guts of all mapping functions.
2636 Apply FN to each element of SEQ, one by one,
2637 storing the results into elements of VALS, a C vector of Lisp_Objects.
2638 LENI is the length of VALS, which should also be the length of SEQ. */
2641 mapcar1 (leni
, vals
, fn
, seq
)
2644 Lisp_Object fn
, seq
;
2646 register Lisp_Object tail
;
2649 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2653 /* Don't let vals contain any garbage when GC happens. */
2654 for (i
= 0; i
< leni
; i
++)
2657 GCPRO3 (dummy
, fn
, seq
);
2659 gcpro1
.nvars
= leni
;
2663 /* We need not explicitly protect `tail' because it is used only on lists, and
2664 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2668 for (i
= 0; i
< leni
; i
++)
2670 dummy
= XVECTOR (seq
)->contents
[i
];
2671 dummy
= call1 (fn
, dummy
);
2676 else if (BOOL_VECTOR_P (seq
))
2678 for (i
= 0; i
< leni
; i
++)
2681 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2682 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2687 dummy
= call1 (fn
, dummy
);
2692 else if (STRINGP (seq
))
2696 for (i
= 0, i_byte
= 0; i
< leni
;)
2701 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2702 XSETFASTINT (dummy
, c
);
2703 dummy
= call1 (fn
, dummy
);
2705 vals
[i_before
] = dummy
;
2708 else /* Must be a list, since Flength did not get an error */
2711 for (i
= 0; i
< leni
; i
++)
2713 dummy
= call1 (fn
, Fcar (tail
));
2723 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2724 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2725 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2726 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2727 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2728 (function
, sequence
, separator
)
2729 Lisp_Object function
, sequence
, separator
;
2734 register Lisp_Object
*args
;
2736 struct gcpro gcpro1
;
2738 len
= Flength (sequence
);
2740 nargs
= leni
+ leni
- 1;
2741 if (nargs
< 0) return build_string ("");
2743 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2746 mapcar1 (leni
, args
, function
, sequence
);
2749 for (i
= leni
- 1; i
>= 0; i
--)
2750 args
[i
+ i
] = args
[i
];
2752 for (i
= 1; i
< nargs
; i
+= 2)
2753 args
[i
] = separator
;
2755 return Fconcat (nargs
, args
);
2758 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2759 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2760 The result is a list just as long as SEQUENCE.\n\
2761 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2762 (function
, sequence
)
2763 Lisp_Object function
, sequence
;
2765 register Lisp_Object len
;
2767 register Lisp_Object
*args
;
2769 len
= Flength (sequence
);
2770 leni
= XFASTINT (len
);
2771 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2773 mapcar1 (leni
, args
, function
, sequence
);
2775 return Flist (leni
, args
);
2778 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2779 "Apply FUNCTION to each element of SEQUENCE for side effects only.\n\
2780 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.\n\
2781 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2782 (function
, sequence
)
2783 Lisp_Object function
, sequence
;
2787 leni
= XFASTINT (Flength (sequence
));
2788 mapcar1 (leni
, 0, function
, sequence
);
2793 /* Anything that calls this function must protect from GC! */
2795 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2796 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2797 Takes one argument, which is the string to display to ask the question.\n\
2798 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2799 No confirmation of the answer is requested; a single character is enough.\n\
2800 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2801 the bindings in `query-replace-map'; see the documentation of that variable\n\
2802 for more information. In this case, the useful bindings are `act', `skip',\n\
2803 `recenter', and `quit'.\)\n\
2805 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2806 is nil and `use-dialog-box' is non-nil.")
2810 register Lisp_Object obj
, key
, def
, map
;
2811 register int answer
;
2812 Lisp_Object xprompt
;
2813 Lisp_Object args
[2];
2814 struct gcpro gcpro1
, gcpro2
;
2815 int count
= specpdl_ptr
- specpdl
;
2817 specbind (Qcursor_in_echo_area
, Qt
);
2819 map
= Fsymbol_value (intern ("query-replace-map"));
2821 CHECK_STRING (prompt
, 0);
2823 GCPRO2 (prompt
, xprompt
);
2825 #ifdef HAVE_X_WINDOWS
2826 if (display_hourglass_p
)
2827 cancel_hourglass ();
2834 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2838 Lisp_Object pane
, menu
;
2839 redisplay_preserve_echo_area (3);
2840 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2841 Fcons (Fcons (build_string ("No"), Qnil
),
2843 menu
= Fcons (prompt
, pane
);
2844 obj
= Fx_popup_dialog (Qt
, menu
);
2845 answer
= !NILP (obj
);
2848 #endif /* HAVE_MENUS */
2849 cursor_in_echo_area
= 1;
2850 choose_minibuf_frame ();
2851 message_with_string ("%s(y or n) ", xprompt
, 0);
2853 if (minibuffer_auto_raise
)
2855 Lisp_Object mini_frame
;
2857 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2859 Fraise_frame (mini_frame
);
2862 obj
= read_filtered_event (1, 0, 0, 0);
2863 cursor_in_echo_area
= 0;
2864 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2867 key
= Fmake_vector (make_number (1), obj
);
2868 def
= Flookup_key (map
, key
, Qt
);
2870 if (EQ (def
, intern ("skip")))
2875 else if (EQ (def
, intern ("act")))
2880 else if (EQ (def
, intern ("recenter")))
2886 else if (EQ (def
, intern ("quit")))
2888 /* We want to exit this command for exit-prefix,
2889 and this is the only way to do it. */
2890 else if (EQ (def
, intern ("exit-prefix")))
2895 /* If we don't clear this, then the next call to read_char will
2896 return quit_char again, and we'll enter an infinite loop. */
2901 if (EQ (xprompt
, prompt
))
2903 args
[0] = build_string ("Please answer y or n. ");
2905 xprompt
= Fconcat (2, args
);
2910 if (! noninteractive
)
2912 cursor_in_echo_area
= -1;
2913 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2917 unbind_to (count
, Qnil
);
2918 return answer
? Qt
: Qnil
;
2921 /* This is how C code calls `yes-or-no-p' and allows the user
2924 Anything that calls this function must protect from GC! */
2927 do_yes_or_no_p (prompt
)
2930 return call1 (intern ("yes-or-no-p"), prompt
);
2933 /* Anything that calls this function must protect from GC! */
2935 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2936 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2937 Takes one argument, which is the string to display to ask the question.\n\
2938 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2939 The user must confirm the answer with RET,\n\
2940 and can edit it until it has been confirmed.\n\
2942 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2943 is nil, and `use-dialog-box' is non-nil.")
2947 register Lisp_Object ans
;
2948 Lisp_Object args
[2];
2949 struct gcpro gcpro1
;
2951 CHECK_STRING (prompt
, 0);
2954 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2958 Lisp_Object pane
, menu
, obj
;
2959 redisplay_preserve_echo_area (4);
2960 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2961 Fcons (Fcons (build_string ("No"), Qnil
),
2964 menu
= Fcons (prompt
, pane
);
2965 obj
= Fx_popup_dialog (Qt
, menu
);
2969 #endif /* HAVE_MENUS */
2972 args
[1] = build_string ("(yes or no) ");
2973 prompt
= Fconcat (2, args
);
2979 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2980 Qyes_or_no_p_history
, Qnil
,
2982 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2987 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2995 message ("Please answer yes or no.");
2996 Fsleep_for (make_number (2), Qnil
);
3000 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3001 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
3002 Each of the three load averages is multiplied by 100,\n\
3003 then converted to integer.\n\
3004 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
3005 These floats are not multiplied by 100.\n\n\
3006 If the 5-minute or 15-minute load averages are not available, return a\n\
3007 shortened list, containing only those averages which are available.")
3009 Lisp_Object use_floats
;
3012 int loads
= getloadavg (load_ave
, 3);
3013 Lisp_Object ret
= Qnil
;
3016 error ("load-average not implemented for this operating system");
3020 Lisp_Object load
= (NILP (use_floats
) ?
3021 make_number ((int) (100.0 * load_ave
[loads
]))
3022 : make_float (load_ave
[loads
]));
3023 ret
= Fcons (load
, ret
);
3029 Lisp_Object Vfeatures
;
3031 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
3032 "Returns t if FEATURE is present in this Emacs.\n\
3033 Use this to conditionalize execution of lisp code based on the presence or\n\
3034 absence of emacs or environment extensions.\n\
3035 Use `provide' to declare that a feature is available.\n\
3036 This function looks at the value of the variable `features'.")
3038 Lisp_Object feature
;
3040 register Lisp_Object tem
;
3041 CHECK_SYMBOL (feature
, 0);
3042 tem
= Fmemq (feature
, Vfeatures
);
3043 return (NILP (tem
)) ? Qnil
: Qt
;
3046 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
3047 "Announce that FEATURE is a feature of the current Emacs.")
3049 Lisp_Object feature
;
3051 register Lisp_Object tem
;
3052 CHECK_SYMBOL (feature
, 0);
3053 if (!NILP (Vautoload_queue
))
3054 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3055 tem
= Fmemq (feature
, Vfeatures
);
3057 Vfeatures
= Fcons (feature
, Vfeatures
);
3058 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3062 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3063 "If feature FEATURE is not loaded, load it from FILENAME.\n\
3064 If FEATURE is not a member of the list `features', then the feature\n\
3065 is not loaded; so load the file FILENAME.\n\
3066 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
3067 and `load' will try to load this name appended with the suffix `.elc',\n\
3068 `.el' or the unmodified name, in that order.\n\
3069 If the optional third argument NOERROR is non-nil,\n\
3070 then return nil if the file is not found instead of signaling an error.\n\
3071 Normally the return value is FEATURE.\n\
3072 The normal messages at start and end of loading FILENAME are suppressed.")
3073 (feature
, filename
, noerror
)
3074 Lisp_Object feature
, filename
, noerror
;
3076 register Lisp_Object tem
;
3077 CHECK_SYMBOL (feature
, 0);
3078 tem
= Fmemq (feature
, Vfeatures
);
3080 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3084 int count
= specpdl_ptr
- specpdl
;
3086 /* Value saved here is to be restored into Vautoload_queue */
3087 record_unwind_protect (un_autoload
, Vautoload_queue
);
3088 Vautoload_queue
= Qt
;
3090 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3091 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3092 /* If load failed entirely, return nil. */
3094 return unbind_to (count
, Qnil
);
3096 tem
= Fmemq (feature
, Vfeatures
);
3098 error ("Required feature %s was not provided",
3099 XSYMBOL (feature
)->name
->data
);
3101 /* Once loading finishes, don't undo it. */
3102 Vautoload_queue
= Qt
;
3103 feature
= unbind_to (count
, feature
);
3108 /* Primitives for work of the "widget" library.
3109 In an ideal world, this section would not have been necessary.
3110 However, lisp function calls being as slow as they are, it turns
3111 out that some functions in the widget library (wid-edit.el) are the
3112 bottleneck of Widget operation. Here is their translation to C,
3113 for the sole reason of efficiency. */
3115 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3116 "Return non-nil if PLIST has the property PROP.\n\
3117 PLIST is a property list, which is a list of the form\n\
3118 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
3119 Unlike `plist-get', this allows you to distinguish between a missing\n\
3120 property and a property with the value nil.\n\
3121 The value is actually the tail of PLIST whose car is PROP.")
3123 Lisp_Object plist
, prop
;
3125 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3128 plist
= XCDR (plist
);
3129 plist
= CDR (plist
);
3134 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3135 "In WIDGET, set PROPERTY to VALUE.\n\
3136 The value can later be retrieved with `widget-get'.")
3137 (widget
, property
, value
)
3138 Lisp_Object widget
, property
, value
;
3140 CHECK_CONS (widget
, 1);
3141 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
3145 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3146 "In WIDGET, get the value of PROPERTY.\n\
3147 The value could either be specified when the widget was created, or\n\
3148 later with `widget-put'.")
3150 Lisp_Object widget
, property
;
3158 CHECK_CONS (widget
, 1);
3159 tmp
= Fplist_member (XCDR (widget
), property
);
3165 tmp
= XCAR (widget
);
3168 widget
= Fget (tmp
, Qwidget_type
);
3172 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3173 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
3174 ARGS are passed as extra arguments to the function.")
3179 /* This function can GC. */
3180 Lisp_Object newargs
[3];
3181 struct gcpro gcpro1
, gcpro2
;
3184 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3185 newargs
[1] = args
[0];
3186 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3187 GCPRO2 (newargs
[0], newargs
[2]);
3188 result
= Fapply (3, newargs
);
3193 /* base64 encode/decode functions (RFC 2045).
3194 Based on code from GNU recode. */
3196 #define MIME_LINE_LENGTH 76
3198 #define IS_ASCII(Character) \
3200 #define IS_BASE64(Character) \
3201 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3202 #define IS_BASE64_IGNORABLE(Character) \
3203 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3204 || (Character) == '\f' || (Character) == '\r')
3206 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3207 character or return retval if there are no characters left to
3209 #define READ_QUADRUPLET_BYTE(retval) \
3214 if (nchars_return) \
3215 *nchars_return = nchars; \
3220 while (IS_BASE64_IGNORABLE (c))
3222 /* Don't use alloca for regions larger than this, lest we overflow
3224 #define MAX_ALLOCA 16*1024
3226 /* Table of characters coding the 64 values. */
3227 static char base64_value_to_char
[64] =
3229 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3230 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3231 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3232 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3233 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3234 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3235 '8', '9', '+', '/' /* 60-63 */
3238 /* Table of base64 values for first 128 characters. */
3239 static short base64_char_to_value
[128] =
3241 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3242 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3243 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3244 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3245 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3246 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3247 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3248 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3249 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3250 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3251 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3252 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3253 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3256 /* The following diagram shows the logical steps by which three octets
3257 get transformed into four base64 characters.
3259 .--------. .--------. .--------.
3260 |aaaaaabb| |bbbbcccc| |ccdddddd|
3261 `--------' `--------' `--------'
3263 .--------+--------+--------+--------.
3264 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3265 `--------+--------+--------+--------'
3267 .--------+--------+--------+--------.
3268 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3269 `--------+--------+--------+--------'
3271 The octets are divided into 6 bit chunks, which are then encoded into
3272 base64 characters. */
3275 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3276 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3278 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3280 "Base64-encode the region between BEG and END.\n\
3281 Return the length of the encoded text.\n\
3282 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3283 into shorter lines.")
3284 (beg
, end
, no_line_break
)
3285 Lisp_Object beg
, end
, no_line_break
;
3288 int allength
, length
;
3289 int ibeg
, iend
, encoded_length
;
3292 validate_region (&beg
, &end
);
3294 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3295 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3296 move_gap_both (XFASTINT (beg
), ibeg
);
3298 /* We need to allocate enough room for encoding the text.
3299 We need 33 1/3% more space, plus a newline every 76
3300 characters, and then we round up. */
3301 length
= iend
- ibeg
;
3302 allength
= length
+ length
/3 + 1;
3303 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3305 if (allength
<= MAX_ALLOCA
)
3306 encoded
= (char *) alloca (allength
);
3308 encoded
= (char *) xmalloc (allength
);
3309 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3310 NILP (no_line_break
),
3311 !NILP (current_buffer
->enable_multibyte_characters
));
3312 if (encoded_length
> allength
)
3315 if (encoded_length
< 0)
3317 /* The encoding wasn't possible. */
3318 if (length
> MAX_ALLOCA
)
3320 error ("Multibyte character in data for base64 encoding");
3323 /* Now we have encoded the region, so we insert the new contents
3324 and delete the old. (Insert first in order to preserve markers.) */
3325 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3326 insert (encoded
, encoded_length
);
3327 if (allength
> MAX_ALLOCA
)
3329 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3331 /* If point was outside of the region, restore it exactly; else just
3332 move to the beginning of the region. */
3333 if (old_pos
>= XFASTINT (end
))
3334 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3335 else if (old_pos
> XFASTINT (beg
))
3336 old_pos
= XFASTINT (beg
);
3339 /* We return the length of the encoded text. */
3340 return make_number (encoded_length
);
3343 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3345 "Base64-encode STRING and return the result.\n\
3346 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3347 into shorter lines.")
3348 (string
, no_line_break
)
3349 Lisp_Object string
, no_line_break
;
3351 int allength
, length
, encoded_length
;
3353 Lisp_Object encoded_string
;
3355 CHECK_STRING (string
, 1);
3357 /* We need to allocate enough room for encoding the text.
3358 We need 33 1/3% more space, plus a newline every 76
3359 characters, and then we round up. */
3360 length
= STRING_BYTES (XSTRING (string
));
3361 allength
= length
+ length
/3 + 1;
3362 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3364 /* We need to allocate enough room for decoding the text. */
3365 if (allength
<= MAX_ALLOCA
)
3366 encoded
= (char *) alloca (allength
);
3368 encoded
= (char *) xmalloc (allength
);
3370 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3371 encoded
, length
, NILP (no_line_break
),
3372 STRING_MULTIBYTE (string
));
3373 if (encoded_length
> allength
)
3376 if (encoded_length
< 0)
3378 /* The encoding wasn't possible. */
3379 if (length
> MAX_ALLOCA
)
3381 error ("Multibyte character in data for base64 encoding");
3384 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3385 if (allength
> MAX_ALLOCA
)
3388 return encoded_string
;
3392 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3399 int counter
= 0, i
= 0;
3409 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3417 /* Wrap line every 76 characters. */
3421 if (counter
< MIME_LINE_LENGTH
/ 4)
3430 /* Process first byte of a triplet. */
3432 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3433 value
= (0x03 & c
) << 4;
3435 /* Process second byte of a triplet. */
3439 *e
++ = base64_value_to_char
[value
];
3447 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3455 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3456 value
= (0x0f & c
) << 2;
3458 /* Process third byte of a triplet. */
3462 *e
++ = base64_value_to_char
[value
];
3469 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3477 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3478 *e
++ = base64_value_to_char
[0x3f & c
];
3485 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3487 "Base64-decode the region between BEG and END.\n\
3488 Return the length of the decoded text.\n\
3489 If the region can't be decoded, signal an error and don't modify the buffer.")
3491 Lisp_Object beg
, end
;
3493 int ibeg
, iend
, length
, allength
;
3498 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3500 validate_region (&beg
, &end
);
3502 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3503 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3505 length
= iend
- ibeg
;
3507 /* We need to allocate enough room for decoding the text. If we are
3508 working on a multibyte buffer, each decoded code may occupy at
3510 allength
= multibyte
? length
* 2 : length
;
3511 if (allength
<= MAX_ALLOCA
)
3512 decoded
= (char *) alloca (allength
);
3514 decoded
= (char *) xmalloc (allength
);
3516 move_gap_both (XFASTINT (beg
), ibeg
);
3517 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3518 multibyte
, &inserted_chars
);
3519 if (decoded_length
> allength
)
3522 if (decoded_length
< 0)
3524 /* The decoding wasn't possible. */
3525 if (allength
> MAX_ALLOCA
)
3527 error ("Invalid base64 data");
3530 /* Now we have decoded the region, so we insert the new contents
3531 and delete the old. (Insert first in order to preserve markers.) */
3532 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3533 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3534 if (allength
> MAX_ALLOCA
)
3536 /* Delete the original text. */
3537 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3538 iend
+ decoded_length
, 1);
3540 /* If point was outside of the region, restore it exactly; else just
3541 move to the beginning of the region. */
3542 if (old_pos
>= XFASTINT (end
))
3543 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3544 else if (old_pos
> XFASTINT (beg
))
3545 old_pos
= XFASTINT (beg
);
3546 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3548 return make_number (inserted_chars
);
3551 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3553 "Base64-decode STRING and return the result.")
3558 int length
, decoded_length
;
3559 Lisp_Object decoded_string
;
3561 CHECK_STRING (string
, 1);
3563 length
= STRING_BYTES (XSTRING (string
));
3564 /* We need to allocate enough room for decoding the text. */
3565 if (length
<= MAX_ALLOCA
)
3566 decoded
= (char *) alloca (length
);
3568 decoded
= (char *) xmalloc (length
);
3570 /* The decoded result should be unibyte. */
3571 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3573 if (decoded_length
> length
)
3575 else if (decoded_length
>= 0)
3576 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3578 decoded_string
= Qnil
;
3580 if (length
> MAX_ALLOCA
)
3582 if (!STRINGP (decoded_string
))
3583 error ("Invalid base64 data");
3585 return decoded_string
;
3588 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3589 MULTIBYTE is nonzero, the decoded result should be in multibyte
3590 form. If NCHARS_RETRUN is not NULL, store the number of produced
3591 characters in *NCHARS_RETURN. */
3594 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3604 unsigned long value
;
3609 /* Process first byte of a quadruplet. */
3611 READ_QUADRUPLET_BYTE (e
-to
);
3615 value
= base64_char_to_value
[c
] << 18;
3617 /* Process second byte of a quadruplet. */
3619 READ_QUADRUPLET_BYTE (-1);
3623 value
|= base64_char_to_value
[c
] << 12;
3625 c
= (unsigned char) (value
>> 16);
3627 e
+= CHAR_STRING (c
, e
);
3632 /* Process third byte of a quadruplet. */
3634 READ_QUADRUPLET_BYTE (-1);
3638 READ_QUADRUPLET_BYTE (-1);
3647 value
|= base64_char_to_value
[c
] << 6;
3649 c
= (unsigned char) (0xff & value
>> 8);
3651 e
+= CHAR_STRING (c
, e
);
3656 /* Process fourth byte of a quadruplet. */
3658 READ_QUADRUPLET_BYTE (-1);
3665 value
|= base64_char_to_value
[c
];
3667 c
= (unsigned char) (0xff & value
);
3669 e
+= CHAR_STRING (c
, e
);
3678 /***********************************************************************
3680 ***** Hash Tables *****
3682 ***********************************************************************/
3684 /* Implemented by gerd@gnu.org. This hash table implementation was
3685 inspired by CMUCL hash tables. */
3689 1. For small tables, association lists are probably faster than
3690 hash tables because they have lower overhead.
3692 For uses of hash tables where the O(1) behavior of table
3693 operations is not a requirement, it might therefore be a good idea
3694 not to hash. Instead, we could just do a linear search in the
3695 key_and_value vector of the hash table. This could be done
3696 if a `:linear-search t' argument is given to make-hash-table. */
3699 /* Value is the key part of entry IDX in hash table H. */
3701 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3703 /* Value is the value part of entry IDX in hash table H. */
3705 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3707 /* Value is the index of the next entry following the one at IDX
3710 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3712 /* Value is the hash code computed for entry IDX in hash table H. */
3714 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3716 /* Value is the index of the element in hash table H that is the
3717 start of the collision list at index IDX in the index vector of H. */
3719 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3721 /* Value is the size of hash table H. */
3723 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3725 /* The list of all weak hash tables. Don't staticpro this one. */
3727 Lisp_Object Vweak_hash_tables
;
3729 /* Various symbols. */
3731 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3732 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3733 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3735 /* Function prototypes. */
3737 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3738 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3739 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3740 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3741 Lisp_Object
, unsigned));
3742 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3743 Lisp_Object
, unsigned));
3744 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3745 unsigned, Lisp_Object
, unsigned));
3746 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3747 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3748 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3749 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3751 static unsigned sxhash_string
P_ ((unsigned char *, int));
3752 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3753 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3754 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3755 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3759 /***********************************************************************
3761 ***********************************************************************/
3763 /* If OBJ is a Lisp hash table, return a pointer to its struct
3764 Lisp_Hash_Table. Otherwise, signal an error. */
3766 static struct Lisp_Hash_Table
*
3767 check_hash_table (obj
)
3770 CHECK_HASH_TABLE (obj
, 0);
3771 return XHASH_TABLE (obj
);
3775 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3779 next_almost_prime (n
)
3792 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3793 which USED[I] is non-zero. If found at index I in ARGS, set
3794 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3795 -1. This function is used to extract a keyword/argument pair from
3796 a DEFUN parameter list. */
3799 get_key_arg (key
, nargs
, args
, used
)
3807 for (i
= 0; i
< nargs
- 1; ++i
)
3808 if (!used
[i
] && EQ (args
[i
], key
))
3823 /* Return a Lisp vector which has the same contents as VEC but has
3824 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3825 vector that are not copied from VEC are set to INIT. */
3828 larger_vector (vec
, new_size
, init
)
3833 struct Lisp_Vector
*v
;
3836 xassert (VECTORP (vec
));
3837 old_size
= XVECTOR (vec
)->size
;
3838 xassert (new_size
>= old_size
);
3840 v
= allocate_vector (new_size
);
3841 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3842 old_size
* sizeof *v
->contents
);
3843 for (i
= old_size
; i
< new_size
; ++i
)
3844 v
->contents
[i
] = init
;
3845 XSETVECTOR (vec
, v
);
3850 /***********************************************************************
3852 ***********************************************************************/
3854 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3855 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3856 KEY2 are the same. */
3859 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3860 struct Lisp_Hash_Table
*h
;
3861 Lisp_Object key1
, key2
;
3862 unsigned hash1
, hash2
;
3864 return (FLOATP (key1
)
3866 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3870 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3871 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3872 KEY2 are the same. */
3875 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3876 struct Lisp_Hash_Table
*h
;
3877 Lisp_Object key1
, key2
;
3878 unsigned hash1
, hash2
;
3880 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3884 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3885 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3886 if KEY1 and KEY2 are the same. */
3889 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3890 struct Lisp_Hash_Table
*h
;
3891 Lisp_Object key1
, key2
;
3892 unsigned hash1
, hash2
;
3896 Lisp_Object args
[3];
3898 args
[0] = h
->user_cmp_function
;
3901 return !NILP (Ffuncall (3, args
));
3908 /* Value is a hash code for KEY for use in hash table H which uses
3909 `eq' to compare keys. The hash code returned is guaranteed to fit
3910 in a Lisp integer. */
3914 struct Lisp_Hash_Table
*h
;
3917 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3918 xassert ((hash
& ~VALMASK
) == 0);
3923 /* Value is a hash code for KEY for use in hash table H which uses
3924 `eql' to compare keys. The hash code returned is guaranteed to fit
3925 in a Lisp integer. */
3929 struct Lisp_Hash_Table
*h
;
3934 hash
= sxhash (key
, 0);
3936 hash
= XUINT (key
) ^ XGCTYPE (key
);
3937 xassert ((hash
& ~VALMASK
) == 0);
3942 /* Value is a hash code for KEY for use in hash table H which uses
3943 `equal' to compare keys. The hash code returned is guaranteed to fit
3944 in a Lisp integer. */
3947 hashfn_equal (h
, key
)
3948 struct Lisp_Hash_Table
*h
;
3951 unsigned hash
= sxhash (key
, 0);
3952 xassert ((hash
& ~VALMASK
) == 0);
3957 /* Value is a hash code for KEY for use in hash table H which uses as
3958 user-defined function to compare keys. The hash code returned is
3959 guaranteed to fit in a Lisp integer. */
3962 hashfn_user_defined (h
, key
)
3963 struct Lisp_Hash_Table
*h
;
3966 Lisp_Object args
[2], hash
;
3968 args
[0] = h
->user_hash_function
;
3970 hash
= Ffuncall (2, args
);
3971 if (!INTEGERP (hash
))
3973 list2 (build_string ("Invalid hash code returned from \
3974 user-supplied hash function"),
3976 return XUINT (hash
);
3980 /* Create and initialize a new hash table.
3982 TEST specifies the test the hash table will use to compare keys.
3983 It must be either one of the predefined tests `eq', `eql' or
3984 `equal' or a symbol denoting a user-defined test named TEST with
3985 test and hash functions USER_TEST and USER_HASH.
3987 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3989 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3990 new size when it becomes full is computed by adding REHASH_SIZE to
3991 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3992 table's new size is computed by multiplying its old size with
3995 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3996 be resized when the ratio of (number of entries in the table) /
3997 (table size) is >= REHASH_THRESHOLD.
3999 WEAK specifies the weakness of the table. If non-nil, it must be
4000 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4003 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4004 user_test
, user_hash
)
4005 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4006 Lisp_Object user_test
, user_hash
;
4008 struct Lisp_Hash_Table
*h
;
4010 int index_size
, i
, sz
;
4012 /* Preconditions. */
4013 xassert (SYMBOLP (test
));
4014 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4015 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4016 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4017 xassert (FLOATP (rehash_threshold
)
4018 && XFLOATINT (rehash_threshold
) > 0
4019 && XFLOATINT (rehash_threshold
) <= 1.0);
4021 if (XFASTINT (size
) == 0)
4022 size
= make_number (1);
4024 /* Allocate a table and initialize it. */
4025 h
= allocate_hash_table ();
4027 /* Initialize hash table slots. */
4028 sz
= XFASTINT (size
);
4031 if (EQ (test
, Qeql
))
4033 h
->cmpfn
= cmpfn_eql
;
4034 h
->hashfn
= hashfn_eql
;
4036 else if (EQ (test
, Qeq
))
4039 h
->hashfn
= hashfn_eq
;
4041 else if (EQ (test
, Qequal
))
4043 h
->cmpfn
= cmpfn_equal
;
4044 h
->hashfn
= hashfn_equal
;
4048 h
->user_cmp_function
= user_test
;
4049 h
->user_hash_function
= user_hash
;
4050 h
->cmpfn
= cmpfn_user_defined
;
4051 h
->hashfn
= hashfn_user_defined
;
4055 h
->rehash_threshold
= rehash_threshold
;
4056 h
->rehash_size
= rehash_size
;
4057 h
->count
= make_number (0);
4058 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4059 h
->hash
= Fmake_vector (size
, Qnil
);
4060 h
->next
= Fmake_vector (size
, Qnil
);
4061 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4062 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4063 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4065 /* Set up the free list. */
4066 for (i
= 0; i
< sz
- 1; ++i
)
4067 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4068 h
->next_free
= make_number (0);
4070 XSET_HASH_TABLE (table
, h
);
4071 xassert (HASH_TABLE_P (table
));
4072 xassert (XHASH_TABLE (table
) == h
);
4074 /* Maybe add this hash table to the list of all weak hash tables. */
4076 h
->next_weak
= Qnil
;
4079 h
->next_weak
= Vweak_hash_tables
;
4080 Vweak_hash_tables
= table
;
4087 /* Return a copy of hash table H1. Keys and values are not copied,
4088 only the table itself is. */
4091 copy_hash_table (h1
)
4092 struct Lisp_Hash_Table
*h1
;
4095 struct Lisp_Hash_Table
*h2
;
4096 struct Lisp_Vector
*v
, *next
;
4098 h2
= allocate_hash_table ();
4099 next
= h2
->vec_next
;
4100 bcopy (h1
, h2
, sizeof *h2
);
4101 h2
->vec_next
= next
;
4102 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4103 h2
->hash
= Fcopy_sequence (h1
->hash
);
4104 h2
->next
= Fcopy_sequence (h1
->next
);
4105 h2
->index
= Fcopy_sequence (h1
->index
);
4106 XSET_HASH_TABLE (table
, h2
);
4108 /* Maybe add this hash table to the list of all weak hash tables. */
4109 if (!NILP (h2
->weak
))
4111 h2
->next_weak
= Vweak_hash_tables
;
4112 Vweak_hash_tables
= table
;
4119 /* Resize hash table H if it's too full. If H cannot be resized
4120 because it's already too large, throw an error. */
4123 maybe_resize_hash_table (h
)
4124 struct Lisp_Hash_Table
*h
;
4126 if (NILP (h
->next_free
))
4128 int old_size
= HASH_TABLE_SIZE (h
);
4129 int i
, new_size
, index_size
;
4131 if (INTEGERP (h
->rehash_size
))
4132 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4134 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4135 new_size
= max (old_size
+ 1, new_size
);
4136 index_size
= next_almost_prime ((int)
4138 / XFLOATINT (h
->rehash_threshold
)));
4139 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4140 error ("Hash table too large to resize");
4142 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4143 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4144 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4145 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4147 /* Update the free list. Do it so that new entries are added at
4148 the end of the free list. This makes some operations like
4150 for (i
= old_size
; i
< new_size
- 1; ++i
)
4151 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4153 if (!NILP (h
->next_free
))
4155 Lisp_Object last
, next
;
4157 last
= h
->next_free
;
4158 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4162 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4165 XSETFASTINT (h
->next_free
, old_size
);
4168 for (i
= 0; i
< old_size
; ++i
)
4169 if (!NILP (HASH_HASH (h
, i
)))
4171 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4172 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4173 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4174 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4180 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4181 the hash code of KEY. Value is the index of the entry in H
4182 matching KEY, or -1 if not found. */
4185 hash_lookup (h
, key
, hash
)
4186 struct Lisp_Hash_Table
*h
;
4191 int start_of_bucket
;
4194 hash_code
= h
->hashfn (h
, key
);
4198 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4199 idx
= HASH_INDEX (h
, start_of_bucket
);
4201 /* We need not gcpro idx since it's either an integer or nil. */
4204 int i
= XFASTINT (idx
);
4205 if (EQ (key
, HASH_KEY (h
, i
))
4207 && h
->cmpfn (h
, key
, hash_code
,
4208 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4210 idx
= HASH_NEXT (h
, i
);
4213 return NILP (idx
) ? -1 : XFASTINT (idx
);
4217 /* Put an entry into hash table H that associates KEY with VALUE.
4218 HASH is a previously computed hash code of KEY.
4219 Value is the index of the entry in H matching KEY. */
4222 hash_put (h
, key
, value
, hash
)
4223 struct Lisp_Hash_Table
*h
;
4224 Lisp_Object key
, value
;
4227 int start_of_bucket
, i
;
4229 xassert ((hash
& ~VALMASK
) == 0);
4231 /* Increment count after resizing because resizing may fail. */
4232 maybe_resize_hash_table (h
);
4233 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4235 /* Store key/value in the key_and_value vector. */
4236 i
= XFASTINT (h
->next_free
);
4237 h
->next_free
= HASH_NEXT (h
, i
);
4238 HASH_KEY (h
, i
) = key
;
4239 HASH_VALUE (h
, i
) = value
;
4241 /* Remember its hash code. */
4242 HASH_HASH (h
, i
) = make_number (hash
);
4244 /* Add new entry to its collision chain. */
4245 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4246 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4247 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4252 /* Remove the entry matching KEY from hash table H, if there is one. */
4255 hash_remove (h
, key
)
4256 struct Lisp_Hash_Table
*h
;
4260 int start_of_bucket
;
4261 Lisp_Object idx
, prev
;
4263 hash_code
= h
->hashfn (h
, key
);
4264 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4265 idx
= HASH_INDEX (h
, start_of_bucket
);
4268 /* We need not gcpro idx, prev since they're either integers or nil. */
4271 int i
= XFASTINT (idx
);
4273 if (EQ (key
, HASH_KEY (h
, i
))
4275 && h
->cmpfn (h
, key
, hash_code
,
4276 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4278 /* Take entry out of collision chain. */
4280 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4282 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4284 /* Clear slots in key_and_value and add the slots to
4286 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4287 HASH_NEXT (h
, i
) = h
->next_free
;
4288 h
->next_free
= make_number (i
);
4289 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4290 xassert (XINT (h
->count
) >= 0);
4296 idx
= HASH_NEXT (h
, i
);
4302 /* Clear hash table H. */
4306 struct Lisp_Hash_Table
*h
;
4308 if (XFASTINT (h
->count
) > 0)
4310 int i
, size
= HASH_TABLE_SIZE (h
);
4312 for (i
= 0; i
< size
; ++i
)
4314 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4315 HASH_KEY (h
, i
) = Qnil
;
4316 HASH_VALUE (h
, i
) = Qnil
;
4317 HASH_HASH (h
, i
) = Qnil
;
4320 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4321 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4323 h
->next_free
= make_number (0);
4324 h
->count
= make_number (0);
4330 /************************************************************************
4332 ************************************************************************/
4334 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4335 entries from the table that don't survive the current GC.
4336 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4337 non-zero if anything was marked. */
4340 sweep_weak_table (h
, remove_entries_p
)
4341 struct Lisp_Hash_Table
*h
;
4342 int remove_entries_p
;
4344 int bucket
, n
, marked
;
4346 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4349 for (bucket
= 0; bucket
< n
; ++bucket
)
4351 Lisp_Object idx
, next
, prev
;
4353 /* Follow collision chain, removing entries that
4354 don't survive this garbage collection. */
4356 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4358 int i
= XFASTINT (idx
);
4359 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4360 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4363 if (EQ (h
->weak
, Qkey
))
4364 remove_p
= !key_known_to_survive_p
;
4365 else if (EQ (h
->weak
, Qvalue
))
4366 remove_p
= !value_known_to_survive_p
;
4367 else if (EQ (h
->weak
, Qkey_or_value
))
4368 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4369 else if (EQ (h
->weak
, Qkey_and_value
))
4370 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4374 next
= HASH_NEXT (h
, i
);
4376 if (remove_entries_p
)
4380 /* Take out of collision chain. */
4382 HASH_INDEX (h
, bucket
) = next
;
4384 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4386 /* Add to free list. */
4387 HASH_NEXT (h
, i
) = h
->next_free
;
4390 /* Clear key, value, and hash. */
4391 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4392 HASH_HASH (h
, i
) = Qnil
;
4394 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4401 /* Make sure key and value survive. */
4402 if (!key_known_to_survive_p
)
4404 mark_object (&HASH_KEY (h
, i
));
4408 if (!value_known_to_survive_p
)
4410 mark_object (&HASH_VALUE (h
, i
));
4421 /* Remove elements from weak hash tables that don't survive the
4422 current garbage collection. Remove weak tables that don't survive
4423 from Vweak_hash_tables. Called from gc_sweep. */
4426 sweep_weak_hash_tables ()
4428 Lisp_Object table
, used
, next
;
4429 struct Lisp_Hash_Table
*h
;
4432 /* Mark all keys and values that are in use. Keep on marking until
4433 there is no more change. This is necessary for cases like
4434 value-weak table A containing an entry X -> Y, where Y is used in a
4435 key-weak table B, Z -> Y. If B comes after A in the list of weak
4436 tables, X -> Y might be removed from A, although when looking at B
4437 one finds that it shouldn't. */
4441 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4443 h
= XHASH_TABLE (table
);
4444 if (h
->size
& ARRAY_MARK_FLAG
)
4445 marked
|= sweep_weak_table (h
, 0);
4450 /* Remove tables and entries that aren't used. */
4451 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4453 h
= XHASH_TABLE (table
);
4454 next
= h
->next_weak
;
4456 if (h
->size
& ARRAY_MARK_FLAG
)
4458 /* TABLE is marked as used. Sweep its contents. */
4459 if (XFASTINT (h
->count
) > 0)
4460 sweep_weak_table (h
, 1);
4462 /* Add table to the list of used weak hash tables. */
4463 h
->next_weak
= used
;
4468 Vweak_hash_tables
= used
;
4473 /***********************************************************************
4474 Hash Code Computation
4475 ***********************************************************************/
4477 /* Maximum depth up to which to dive into Lisp structures. */
4479 #define SXHASH_MAX_DEPTH 3
4481 /* Maximum length up to which to take list and vector elements into
4484 #define SXHASH_MAX_LEN 7
4486 /* Combine two integers X and Y for hashing. */
4488 #define SXHASH_COMBINE(X, Y) \
4489 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4493 /* Return a hash for string PTR which has length LEN. The hash
4494 code returned is guaranteed to fit in a Lisp integer. */
4497 sxhash_string (ptr
, len
)
4501 unsigned char *p
= ptr
;
4502 unsigned char *end
= p
+ len
;
4511 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4514 return hash
& VALMASK
;
4518 /* Return a hash for list LIST. DEPTH is the current depth in the
4519 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4522 sxhash_list (list
, depth
)
4529 if (depth
< SXHASH_MAX_DEPTH
)
4531 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4532 list
= XCDR (list
), ++i
)
4534 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4535 hash
= SXHASH_COMBINE (hash
, hash2
);
4542 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4543 the Lisp structure. */
4546 sxhash_vector (vec
, depth
)
4550 unsigned hash
= XVECTOR (vec
)->size
;
4553 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4554 for (i
= 0; i
< n
; ++i
)
4556 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4557 hash
= SXHASH_COMBINE (hash
, hash2
);
4564 /* Return a hash for bool-vector VECTOR. */
4567 sxhash_bool_vector (vec
)
4570 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4573 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4574 for (i
= 0; i
< n
; ++i
)
4575 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4581 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4582 structure. Value is an unsigned integer clipped to VALMASK. */
4591 if (depth
> SXHASH_MAX_DEPTH
)
4594 switch (XTYPE (obj
))
4601 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4602 XSYMBOL (obj
)->name
->size
);
4610 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4613 /* This can be everything from a vector to an overlay. */
4614 case Lisp_Vectorlike
:
4616 /* According to the CL HyperSpec, two arrays are equal only if
4617 they are `eq', except for strings and bit-vectors. In
4618 Emacs, this works differently. We have to compare element
4620 hash
= sxhash_vector (obj
, depth
);
4621 else if (BOOL_VECTOR_P (obj
))
4622 hash
= sxhash_bool_vector (obj
);
4624 /* Others are `equal' if they are `eq', so let's take their
4630 hash
= sxhash_list (obj
, depth
);
4635 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4636 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4637 for (hash
= 0; p
< e
; ++p
)
4638 hash
= SXHASH_COMBINE (hash
, *p
);
4646 return hash
& VALMASK
;
4651 /***********************************************************************
4653 ***********************************************************************/
4656 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4657 "Compute a hash code for OBJ and return it as integer.")
4661 unsigned hash
= sxhash (obj
, 0);;
4662 return make_number (hash
);
4666 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4667 "Create and return a new hash table.\n\
4668 Arguments are specified as keyword/argument pairs. The following\n\
4669 arguments are defined:\n\
4671 :test TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4672 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4673 User-supplied test and hash functions can be specified via\n\
4674 `define-hash-table-test'.\n\
4676 :size SIZE -- A hint as to how many elements will be put in the table.\n\
4679 :rehash-size REHASH-SIZE - Indicates how to expand the table when\n\
4680 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4681 If it is a float, it must be > 1.0, and the new size is computed by\n\
4682 multiplying the old size with that factor. Default is 1.5.\n\
4684 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4685 Resize the hash table when ratio of the number of entries in the table.\n\
4688 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',\n\
4689 `key-or-value', or `key-and-value'. If WEAK is not nil, the table returned\n\
4690 is a weak table. Key/value pairs are removed from a weak hash table when\n\
4691 there are no non-weak references pointing to their key, value, one of key\n\
4692 or value, or both key and value, depending on WEAK. WEAK t is equivalent\n\
4693 to `key-and-value'. Default value of WEAK is nil.")
4698 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4699 Lisp_Object user_test
, user_hash
;
4703 /* The vector `used' is used to keep track of arguments that
4704 have been consumed. */
4705 used
= (char *) alloca (nargs
* sizeof *used
);
4706 bzero (used
, nargs
* sizeof *used
);
4708 /* See if there's a `:test TEST' among the arguments. */
4709 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4710 test
= i
< 0 ? Qeql
: args
[i
];
4711 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4713 /* See if it is a user-defined test. */
4716 prop
= Fget (test
, Qhash_table_test
);
4717 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4718 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4720 user_test
= Fnth (make_number (0), prop
);
4721 user_hash
= Fnth (make_number (1), prop
);
4724 user_test
= user_hash
= Qnil
;
4726 /* See if there's a `:size SIZE' argument. */
4727 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4728 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4729 if (!INTEGERP (size
) || XINT (size
) < 0)
4731 list2 (build_string ("Invalid hash table size"),
4734 /* Look for `:rehash-size SIZE'. */
4735 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4736 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4737 if (!NUMBERP (rehash_size
)
4738 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4739 || XFLOATINT (rehash_size
) <= 1.0)
4741 list2 (build_string ("Invalid hash table rehash size"),
4744 /* Look for `:rehash-threshold THRESHOLD'. */
4745 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4746 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4747 if (!FLOATP (rehash_threshold
)
4748 || XFLOATINT (rehash_threshold
) <= 0.0
4749 || XFLOATINT (rehash_threshold
) > 1.0)
4751 list2 (build_string ("Invalid hash table rehash threshold"),
4754 /* Look for `:weakness WEAK'. */
4755 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4756 weak
= i
< 0 ? Qnil
: args
[i
];
4758 weak
= Qkey_and_value
;
4761 && !EQ (weak
, Qvalue
)
4762 && !EQ (weak
, Qkey_or_value
)
4763 && !EQ (weak
, Qkey_and_value
))
4764 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4767 /* Now, all args should have been used up, or there's a problem. */
4768 for (i
= 0; i
< nargs
; ++i
)
4771 list2 (build_string ("Invalid argument list"), args
[i
]));
4773 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4774 user_test
, user_hash
);
4778 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4779 "Return a copy of hash table TABLE.")
4783 return copy_hash_table (check_hash_table (table
));
4787 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4788 "Create a new hash table.\n\
4789 Optional first argument TEST specifies how to compare keys in\n\
4790 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4791 is `eql'. New tests can be defined with `define-hash-table-test'.")
4795 Lisp_Object args
[2];
4797 args
[1] = NILP (test
) ? Qeql
: test
;
4798 return Fmake_hash_table (2, args
);
4802 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4803 "Return the number of elements in TABLE.")
4807 return check_hash_table (table
)->count
;
4811 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4812 Shash_table_rehash_size
, 1, 1, 0,
4813 "Return the current rehash size of TABLE.")
4817 return check_hash_table (table
)->rehash_size
;
4821 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4822 Shash_table_rehash_threshold
, 1, 1, 0,
4823 "Return the current rehash threshold of TABLE.")
4827 return check_hash_table (table
)->rehash_threshold
;
4831 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4832 "Return the size of TABLE.\n\
4833 The size can be used as an argument to `make-hash-table' to create\n\
4834 a hash table than can hold as many elements of TABLE holds\n\
4835 without need for resizing.")
4839 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4840 return make_number (HASH_TABLE_SIZE (h
));
4844 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4845 "Return the test TABLE uses.")
4849 return check_hash_table (table
)->test
;
4853 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4855 "Return the weakness of TABLE.")
4859 return check_hash_table (table
)->weak
;
4863 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4864 "Return t if OBJ is a Lisp hash table object.")
4868 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4872 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4873 "Clear hash table TABLE.")
4877 hash_clear (check_hash_table (table
));
4882 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4883 "Look up KEY in TABLE and return its associated value.\n\
4884 If KEY is not found, return DFLT which defaults to nil.")
4886 Lisp_Object key
, table
, dflt
;
4888 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4889 int i
= hash_lookup (h
, key
, NULL
);
4890 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4894 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4895 "Associate KEY with VALUE in hash table TABLE.\n\
4896 If KEY is already present in table, replace its current value with\n\
4899 Lisp_Object key
, value
, table
;
4901 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4905 i
= hash_lookup (h
, key
, &hash
);
4907 HASH_VALUE (h
, i
) = value
;
4909 hash_put (h
, key
, value
, hash
);
4915 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4916 "Remove KEY from TABLE.")
4918 Lisp_Object key
, table
;
4920 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4921 hash_remove (h
, key
);
4926 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4927 "Call FUNCTION for all entries in hash table TABLE.\n\
4928 FUNCTION is called with 2 arguments KEY and VALUE.")
4930 Lisp_Object function
, table
;
4932 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4933 Lisp_Object args
[3];
4936 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4937 if (!NILP (HASH_HASH (h
, i
)))
4940 args
[1] = HASH_KEY (h
, i
);
4941 args
[2] = HASH_VALUE (h
, i
);
4949 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4950 Sdefine_hash_table_test
, 3, 3, 0,
4951 "Define a new hash table test with name NAME, a symbol.\n\
4952 In hash tables create with NAME specified as test, use TEST to compare\n\
4953 keys, and HASH for computing hash codes of keys.\n\
4955 TEST must be a function taking two arguments and returning non-nil\n\
4956 if both arguments are the same. HASH must be a function taking\n\
4957 one argument and return an integer that is the hash code of the\n\
4958 argument. Hash code computation should use the whole value range of\n\
4959 integers, including negative integers.")
4961 Lisp_Object name
, test
, hash
;
4963 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4968 /************************************************************************
4970 ************************************************************************/
4975 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4976 "Return MD5 message digest of OBJECT, a buffer or string.\n\
4977 A message digest is a cryptographic checksum of a document,\n\
4978 and the algorithm to calculate it is defined in RFC 1321.\n\
4980 The two optional arguments START and END are character positions\n\
4981 specifying for which part of OBJECT the message digest should be computed.\n\
4982 If nil or omitted, the digest is computed for the whole OBJECT.\n\
4984 The MD5 message digest is computed from the result of encoding the\n\
4985 text in a coding system, not directly from the internal Emacs form\n\
4986 of the text. The optional fourth argument CODING-SYSTEM specifies\n\
4987 which coding system to encode the text with. It should be the same\n\
4988 coding system that you used or will use when actually writing the text\n\
4991 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT.\n\
4992 If OBJECT is a buffer, the default for CODING-SYSTEM is whatever\n\
4993 coding system would be chosen by default for writing this text\n\
4996 If OBJECT is a string, the most preferred coding system (see the\n\
4997 command `prefer-coding-system') is used.\n\
4999 If NOERROR is non-nil, silently assume the `raw_text' coding if the\n\
5000 guesswork fails. Normally, an error is signaled in such case.")
5001 (object
, start
, end
, coding_system
, noerror
)
5002 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5004 unsigned char digest
[16];
5005 unsigned char value
[33];
5009 int start_char
= 0, end_char
= 0;
5010 int start_byte
= 0, end_byte
= 0;
5012 register struct buffer
*bp
;
5015 if (STRINGP (object
))
5017 if (NILP (coding_system
))
5019 /* Decide the coding-system to encode the data with. */
5021 if (STRING_MULTIBYTE (object
))
5022 /* use default, we can't guess correct value */
5023 coding_system
= XSYMBOL (XCAR (Vcoding_category_list
))->value
;
5025 coding_system
= Qraw_text
;
5028 if (NILP (Fcoding_system_p (coding_system
)))
5030 /* Invalid coding system. */
5032 if (!NILP (noerror
))
5033 coding_system
= Qraw_text
;
5036 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5039 if (STRING_MULTIBYTE (object
))
5040 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5042 size
= XSTRING (object
)->size
;
5043 size_byte
= STRING_BYTES (XSTRING (object
));
5047 CHECK_NUMBER (start
, 1);
5049 start_char
= XINT (start
);
5054 start_byte
= string_char_to_byte (object
, start_char
);
5060 end_byte
= size_byte
;
5064 CHECK_NUMBER (end
, 2);
5066 end_char
= XINT (end
);
5071 end_byte
= string_char_to_byte (object
, end_char
);
5074 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5075 args_out_of_range_3 (object
, make_number (start_char
),
5076 make_number (end_char
));
5080 CHECK_BUFFER (object
, 0);
5082 bp
= XBUFFER (object
);
5088 CHECK_NUMBER_COERCE_MARKER (start
, 0);
5096 CHECK_NUMBER_COERCE_MARKER (end
, 1);
5101 temp
= b
, b
= e
, e
= temp
;
5103 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5104 args_out_of_range (start
, end
);
5106 if (NILP (coding_system
))
5108 /* Decide the coding-system to encode the data with.
5109 See fileio.c:Fwrite-region */
5111 if (!NILP (Vcoding_system_for_write
))
5112 coding_system
= Vcoding_system_for_write
;
5115 int force_raw_text
= 0;
5117 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5118 if (NILP (coding_system
)
5119 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5121 coding_system
= Qnil
;
5122 if (NILP (current_buffer
->enable_multibyte_characters
))
5126 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5128 /* Check file-coding-system-alist. */
5129 Lisp_Object args
[4], val
;
5131 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5132 args
[3] = Fbuffer_file_name(object
);
5133 val
= Ffind_operation_coding_system (4, args
);
5134 if (CONSP (val
) && !NILP (XCDR (val
)))
5135 coding_system
= XCDR (val
);
5138 if (NILP (coding_system
)
5139 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5141 /* If we still have not decided a coding system, use the
5142 default value of buffer-file-coding-system. */
5143 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5147 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5148 /* Confirm that VAL can surely encode the current region. */
5149 coding_system
= call3 (Vselect_safe_coding_system_function
,
5150 make_number (b
), make_number (e
),
5154 coding_system
= Qraw_text
;
5157 if (NILP (Fcoding_system_p (coding_system
)))
5159 /* Invalid coding system. */
5161 if (!NILP (noerror
))
5162 coding_system
= Qraw_text
;
5165 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5169 object
= make_buffer_string (b
, e
, 0);
5171 if (STRING_MULTIBYTE (object
))
5172 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5175 md5_buffer (XSTRING (object
)->data
+ start_byte
,
5176 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
5179 for (i
= 0; i
< 16; i
++)
5180 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5183 return make_string (value
, 32);
5190 /* Hash table stuff. */
5191 Qhash_table_p
= intern ("hash-table-p");
5192 staticpro (&Qhash_table_p
);
5193 Qeq
= intern ("eq");
5195 Qeql
= intern ("eql");
5197 Qequal
= intern ("equal");
5198 staticpro (&Qequal
);
5199 QCtest
= intern (":test");
5200 staticpro (&QCtest
);
5201 QCsize
= intern (":size");
5202 staticpro (&QCsize
);
5203 QCrehash_size
= intern (":rehash-size");
5204 staticpro (&QCrehash_size
);
5205 QCrehash_threshold
= intern (":rehash-threshold");
5206 staticpro (&QCrehash_threshold
);
5207 QCweakness
= intern (":weakness");
5208 staticpro (&QCweakness
);
5209 Qkey
= intern ("key");
5211 Qvalue
= intern ("value");
5212 staticpro (&Qvalue
);
5213 Qhash_table_test
= intern ("hash-table-test");
5214 staticpro (&Qhash_table_test
);
5215 Qkey_or_value
= intern ("key-or-value");
5216 staticpro (&Qkey_or_value
);
5217 Qkey_and_value
= intern ("key-and-value");
5218 staticpro (&Qkey_and_value
);
5221 defsubr (&Smake_hash_table
);
5222 defsubr (&Scopy_hash_table
);
5223 defsubr (&Smakehash
);
5224 defsubr (&Shash_table_count
);
5225 defsubr (&Shash_table_rehash_size
);
5226 defsubr (&Shash_table_rehash_threshold
);
5227 defsubr (&Shash_table_size
);
5228 defsubr (&Shash_table_test
);
5229 defsubr (&Shash_table_weakness
);
5230 defsubr (&Shash_table_p
);
5231 defsubr (&Sclrhash
);
5232 defsubr (&Sgethash
);
5233 defsubr (&Sputhash
);
5234 defsubr (&Sremhash
);
5235 defsubr (&Smaphash
);
5236 defsubr (&Sdefine_hash_table_test
);
5238 Qstring_lessp
= intern ("string-lessp");
5239 staticpro (&Qstring_lessp
);
5240 Qprovide
= intern ("provide");
5241 staticpro (&Qprovide
);
5242 Qrequire
= intern ("require");
5243 staticpro (&Qrequire
);
5244 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5245 staticpro (&Qyes_or_no_p_history
);
5246 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5247 staticpro (&Qcursor_in_echo_area
);
5248 Qwidget_type
= intern ("widget-type");
5249 staticpro (&Qwidget_type
);
5251 staticpro (&string_char_byte_cache_string
);
5252 string_char_byte_cache_string
= Qnil
;
5254 Fset (Qyes_or_no_p_history
, Qnil
);
5256 DEFVAR_LISP ("features", &Vfeatures
,
5257 "A list of symbols which are the features of the executing emacs.\n\
5258 Used by `featurep' and `require', and altered by `provide'.");
5261 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5262 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
5263 This applies to y-or-n and yes-or-no questions asked by commands\n\
5264 invoked by mouse clicks and mouse menu items.");
5267 defsubr (&Sidentity
);
5270 defsubr (&Ssafe_length
);
5271 defsubr (&Sstring_bytes
);
5272 defsubr (&Sstring_equal
);
5273 defsubr (&Scompare_strings
);
5274 defsubr (&Sstring_lessp
);
5277 defsubr (&Svconcat
);
5278 defsubr (&Scopy_sequence
);
5279 defsubr (&Sstring_make_multibyte
);
5280 defsubr (&Sstring_make_unibyte
);
5281 defsubr (&Sstring_as_multibyte
);
5282 defsubr (&Sstring_as_unibyte
);
5283 defsubr (&Scopy_alist
);
5284 defsubr (&Ssubstring
);
5296 defsubr (&Snreverse
);
5297 defsubr (&Sreverse
);
5299 defsubr (&Splist_get
);
5301 defsubr (&Splist_put
);
5304 defsubr (&Sfillarray
);
5305 defsubr (&Schar_table_subtype
);
5306 defsubr (&Schar_table_parent
);
5307 defsubr (&Sset_char_table_parent
);
5308 defsubr (&Schar_table_extra_slot
);
5309 defsubr (&Sset_char_table_extra_slot
);
5310 defsubr (&Schar_table_range
);
5311 defsubr (&Sset_char_table_range
);
5312 defsubr (&Sset_char_table_default
);
5313 defsubr (&Soptimize_char_table
);
5314 defsubr (&Smap_char_table
);
5318 defsubr (&Smapconcat
);
5319 defsubr (&Sy_or_n_p
);
5320 defsubr (&Syes_or_no_p
);
5321 defsubr (&Sload_average
);
5322 defsubr (&Sfeaturep
);
5323 defsubr (&Srequire
);
5324 defsubr (&Sprovide
);
5325 defsubr (&Splist_member
);
5326 defsubr (&Swidget_put
);
5327 defsubr (&Swidget_get
);
5328 defsubr (&Swidget_apply
);
5329 defsubr (&Sbase64_encode_region
);
5330 defsubr (&Sbase64_decode_region
);
5331 defsubr (&Sbase64_encode_string
);
5332 defsubr (&Sbase64_decode_string
);
5340 Vweak_hash_tables
= Qnil
;