1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000
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 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
49 #define NULL (void *)0
53 #define min(a, b) ((a) < (b) ? (a) : (b))
54 #define max(a, b) ((a) > (b) ? (a) : (b))
57 /* Nonzero enables use of dialog boxes for questions
58 asked by mouse commands. */
61 extern int minibuffer_auto_raise
;
62 extern Lisp_Object minibuf_window
;
64 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
65 Lisp_Object Qyes_or_no_p_history
;
66 Lisp_Object Qcursor_in_echo_area
;
67 Lisp_Object Qwidget_type
;
69 extern Lisp_Object Qinput_method_function
;
71 static int internal_equal ();
73 extern long get_random ();
74 extern void seed_random ();
80 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
81 "Return the argument unchanged.")
88 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
89 "Return a pseudo-random number.\n\
90 All integers representable in Lisp are equally likely.\n\
91 On most systems, this is 28 bits' worth.\n\
92 With positive integer argument N, return random number in interval [0,N).\n\
93 With argument t, set the random number seed from the current time and pid.")
98 Lisp_Object lispy_val
;
99 unsigned long denominator
;
102 seed_random (getpid () + time (NULL
));
103 if (NATNUMP (n
) && XFASTINT (n
) != 0)
105 /* Try to take our random number from the higher bits of VAL,
106 not the lower, since (says Gentzel) the low bits of `random'
107 are less random than the higher ones. We do this by using the
108 quotient rather than the remainder. At the high end of the RNG
109 it's possible to get a quotient larger than n; discarding
110 these values eliminates the bias that would otherwise appear
111 when using a large n. */
112 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
114 val
= get_random () / denominator
;
115 while (val
>= XFASTINT (n
));
119 XSETINT (lispy_val
, val
);
123 /* Random data-structure functions */
125 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
126 "Return the length of vector, list or string SEQUENCE.\n\
127 A byte-code function object is also allowed.\n\
128 If the string contains multibyte characters, this is not the necessarily\n\
129 the number of bytes in the string; it is the number of characters.\n\
130 To get the number of bytes, use `string-bytes'")
132 register Lisp_Object sequence
;
134 register Lisp_Object val
;
138 if (STRINGP (sequence
))
139 XSETFASTINT (val
, XSTRING (sequence
)->size
);
140 else if (VECTORP (sequence
))
141 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
142 else if (CHAR_TABLE_P (sequence
))
143 XSETFASTINT (val
, MAX_CHAR
);
144 else if (BOOL_VECTOR_P (sequence
))
145 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
146 else if (COMPILEDP (sequence
))
147 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
148 else if (CONSP (sequence
))
151 while (CONSP (sequence
))
153 sequence
= XCDR (sequence
);
156 if (!CONSP (sequence
))
159 sequence
= XCDR (sequence
);
164 if (!NILP (sequence
))
165 wrong_type_argument (Qlistp
, sequence
);
167 val
= make_number (i
);
169 else if (NILP (sequence
))
170 XSETFASTINT (val
, 0);
173 sequence
= wrong_type_argument (Qsequencep
, sequence
);
179 /* This does not check for quits. That is safe
180 since it must terminate. */
182 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
183 "Return the length of a list, but avoid error or infinite loop.\n\
184 This function never gets an error. If LIST is not really a list,\n\
185 it returns 0. If LIST is circular, it returns a finite value\n\
186 which is at least the number of distinct elements.")
190 Lisp_Object tail
, halftail
, length
;
193 /* halftail is used to detect circular lists. */
195 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
197 if (EQ (tail
, halftail
) && len
!= 0)
201 halftail
= XCDR (halftail
);
204 XSETINT (length
, len
);
208 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
209 "Return the number of bytes in STRING.\n\
210 If STRING is a multibyte string, this is greater than the length of STRING.")
214 CHECK_STRING (string
, 1);
215 return make_number (STRING_BYTES (XSTRING (string
)));
218 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
219 "Return t if two strings have identical contents.\n\
220 Case is significant, but text properties are ignored.\n\
221 Symbols are also allowed; their print names are used instead.")
223 register Lisp_Object s1
, s2
;
226 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
228 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
229 CHECK_STRING (s1
, 0);
230 CHECK_STRING (s2
, 1);
232 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
233 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
234 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
239 DEFUN ("compare-strings", Fcompare_strings
,
240 Scompare_strings
, 6, 7, 0,
241 "Compare the contents of two strings, converting to multibyte if needed.\n\
242 In string STR1, skip the first START1 characters and stop at END1.\n\
243 In string STR2, skip the first START2 characters and stop at END2.\n\
244 END1 and END2 default to the full lengths of the respective strings.\n\
246 Case is significant in this comparison if IGNORE-CASE is nil.\n\
247 Unibyte strings are converted to multibyte for comparison.\n\
249 The value is t if the strings (or specified portions) match.\n\
250 If string STR1 is less, the value is a negative number N;\n\
251 - 1 - N is the number of characters that match at the beginning.\n\
252 If string STR1 is greater, the value is a positive number N;\n\
253 N - 1 is the number of characters that match at the beginning.")
254 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
255 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
257 register int end1_char
, end2_char
;
258 register int i1
, i1_byte
, i2
, i2_byte
;
260 CHECK_STRING (str1
, 0);
261 CHECK_STRING (str2
, 1);
263 start1
= make_number (0);
265 start2
= make_number (0);
266 CHECK_NATNUM (start1
, 2);
267 CHECK_NATNUM (start2
, 3);
269 CHECK_NATNUM (end1
, 4);
271 CHECK_NATNUM (end2
, 4);
276 i1_byte
= string_char_to_byte (str1
, i1
);
277 i2_byte
= string_char_to_byte (str2
, i2
);
279 end1_char
= XSTRING (str1
)->size
;
280 if (! NILP (end1
) && end1_char
> XINT (end1
))
281 end1_char
= XINT (end1
);
283 end2_char
= XSTRING (str2
)->size
;
284 if (! NILP (end2
) && end2_char
> XINT (end2
))
285 end2_char
= XINT (end2
);
287 while (i1
< end1_char
&& i2
< end2_char
)
289 /* When we find a mismatch, we must compare the
290 characters, not just the bytes. */
293 if (STRING_MULTIBYTE (str1
))
294 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
297 c1
= XSTRING (str1
)->data
[i1
++];
298 c1
= unibyte_char_to_multibyte (c1
);
301 if (STRING_MULTIBYTE (str2
))
302 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
305 c2
= XSTRING (str2
)->data
[i2
++];
306 c2
= unibyte_char_to_multibyte (c2
);
312 if (! NILP (ignore_case
))
316 tem
= Fupcase (make_number (c1
));
318 tem
= Fupcase (make_number (c2
));
325 /* Note that I1 has already been incremented
326 past the character that we are comparing;
327 hence we don't add or subtract 1 here. */
329 return make_number (- i1
);
331 return make_number (i1
);
335 return make_number (i1
- XINT (start1
) + 1);
337 return make_number (- i1
+ XINT (start1
) - 1);
342 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
343 "Return t if first arg string is less than second in lexicographic order.\n\
344 Case is significant.\n\
345 Symbols are also allowed; their print names are used instead.")
347 register Lisp_Object s1
, s2
;
350 register int i1
, i1_byte
, i2
, i2_byte
;
353 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
355 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
356 CHECK_STRING (s1
, 0);
357 CHECK_STRING (s2
, 1);
359 i1
= i1_byte
= i2
= i2_byte
= 0;
361 end
= XSTRING (s1
)->size
;
362 if (end
> XSTRING (s2
)->size
)
363 end
= XSTRING (s2
)->size
;
367 /* When we find a mismatch, we must compare the
368 characters, not just the bytes. */
371 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
372 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
375 return c1
< c2
? Qt
: Qnil
;
377 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
380 static Lisp_Object
concat ();
391 return concat (2, args
, Lisp_String
, 0);
393 return concat (2, &s1
, Lisp_String
, 0);
394 #endif /* NO_ARG_ARRAY */
400 Lisp_Object s1
, s2
, s3
;
407 return concat (3, args
, Lisp_String
, 0);
409 return concat (3, &s1
, Lisp_String
, 0);
410 #endif /* NO_ARG_ARRAY */
413 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
414 "Concatenate all the arguments and make the result a list.\n\
415 The result is a list whose elements are the elements of all the arguments.\n\
416 Each argument may be a list, vector or string.\n\
417 The last argument is not copied, just used as the tail of the new list.")
422 return concat (nargs
, args
, Lisp_Cons
, 1);
425 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
426 "Concatenate all the arguments and make the result a string.\n\
427 The result is a string whose elements are the elements of all the arguments.\n\
428 Each argument may be a string or a list or vector of characters (integers).")
433 return concat (nargs
, args
, Lisp_String
, 0);
436 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
437 "Concatenate all the arguments and make the result a vector.\n\
438 The result is a vector whose elements are the elements of all the arguments.\n\
439 Each argument may be a list, vector or string.")
444 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
447 /* Retrun a copy of a sub char table ARG. The elements except for a
448 nested sub char table are not copied. */
450 copy_sub_char_table (arg
)
453 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
456 /* Copy all the contents. */
457 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
458 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
459 /* Recursively copy any sub char-tables in the ordinary slots. */
460 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
461 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
462 XCHAR_TABLE (copy
)->contents
[i
]
463 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
469 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
470 "Return a copy of a list, vector or string.\n\
471 The elements of a list or vector are not copied; they are shared\n\
476 if (NILP (arg
)) return arg
;
478 if (CHAR_TABLE_P (arg
))
483 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
484 /* Copy all the slots, including the extra ones. */
485 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
486 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
487 * sizeof (Lisp_Object
)));
489 /* Recursively copy any sub char tables in the ordinary slots
490 for multibyte characters. */
491 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
492 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
493 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
494 XCHAR_TABLE (copy
)->contents
[i
]
495 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
500 if (BOOL_VECTOR_P (arg
))
504 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
506 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
507 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
512 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
513 arg
= wrong_type_argument (Qsequencep
, arg
);
514 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
517 /* In string STR of length LEN, see if bytes before STR[I] combine
518 with bytes after STR[I] to form a single character. If so, return
519 the number of bytes after STR[I] which combine in this way.
520 Otherwize, return 0. */
523 count_combining (str
, len
, i
)
527 int j
= i
- 1, bytes
;
529 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
531 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
532 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
534 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
535 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
538 /* This structure holds information of an argument of `concat' that is
539 a string and has text properties to be copied. */
542 int argnum
; /* refer to ARGS (arguments of `concat') */
543 int from
; /* refer to ARGS[argnum] (argument string) */
544 int to
; /* refer to VAL (the target string) */
548 concat (nargs
, args
, target_type
, last_special
)
551 enum Lisp_Type target_type
;
555 register Lisp_Object tail
;
556 register Lisp_Object
this;
558 int toindex_byte
= 0;
559 register int result_len
;
560 register int result_len_byte
;
562 Lisp_Object last_tail
;
565 /* When we make a multibyte string, we can't copy text properties
566 while concatinating each string because the length of resulting
567 string can't be decided until we finish the whole concatination.
568 So, we record strings that have text properties to be copied
569 here, and copy the text properties after the concatination. */
570 struct textprop_rec
*textprops
= NULL
;
571 /* Number of elments in textprops. */
572 int num_textprops
= 0;
576 /* In append, the last arg isn't treated like the others */
577 if (last_special
&& nargs
> 0)
580 last_tail
= args
[nargs
];
585 /* Canonicalize each argument. */
586 for (argnum
= 0; argnum
< nargs
; argnum
++)
589 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
590 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
592 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
596 /* Compute total length in chars of arguments in RESULT_LEN.
597 If desired output is a string, also compute length in bytes
598 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
599 whether the result should be a multibyte string. */
603 for (argnum
= 0; argnum
< nargs
; argnum
++)
607 len
= XFASTINT (Flength (this));
608 if (target_type
== Lisp_String
)
610 /* We must count the number of bytes needed in the string
611 as well as the number of characters. */
617 for (i
= 0; i
< len
; i
++)
619 ch
= XVECTOR (this)->contents
[i
];
621 wrong_type_argument (Qintegerp
, ch
);
622 this_len_byte
= CHAR_BYTES (XINT (ch
));
623 result_len_byte
+= this_len_byte
;
624 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
627 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
628 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
629 else if (CONSP (this))
630 for (; CONSP (this); this = XCDR (this))
634 wrong_type_argument (Qintegerp
, ch
);
635 this_len_byte
= CHAR_BYTES (XINT (ch
));
636 result_len_byte
+= this_len_byte
;
637 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
640 else if (STRINGP (this))
642 if (STRING_MULTIBYTE (this))
645 result_len_byte
+= STRING_BYTES (XSTRING (this));
648 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
649 XSTRING (this)->size
);
656 if (! some_multibyte
)
657 result_len_byte
= result_len
;
659 /* Create the output object. */
660 if (target_type
== Lisp_Cons
)
661 val
= Fmake_list (make_number (result_len
), Qnil
);
662 else if (target_type
== Lisp_Vectorlike
)
663 val
= Fmake_vector (make_number (result_len
), Qnil
);
664 else if (some_multibyte
)
665 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
667 val
= make_uninit_string (result_len
);
669 /* In `append', if all but last arg are nil, return last arg. */
670 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
673 /* Copy the contents of the args into the result. */
675 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
677 toindex
= 0, toindex_byte
= 0;
682 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
684 for (argnum
= 0; argnum
< nargs
; argnum
++)
688 register unsigned int thisindex
= 0;
689 register unsigned int thisindex_byte
= 0;
693 thislen
= Flength (this), thisleni
= XINT (thislen
);
695 /* Between strings of the same kind, copy fast. */
696 if (STRINGP (this) && STRINGP (val
)
697 && STRING_MULTIBYTE (this) == some_multibyte
)
699 int thislen_byte
= STRING_BYTES (XSTRING (this));
702 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
703 STRING_BYTES (XSTRING (this)));
704 combined
= (some_multibyte
&& toindex_byte
> 0
705 ? count_combining (XSTRING (val
)->data
,
706 toindex_byte
+ thislen_byte
,
709 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
711 textprops
[num_textprops
].argnum
= argnum
;
712 /* We ignore text properties on characters being combined. */
713 textprops
[num_textprops
].from
= combined
;
714 textprops
[num_textprops
++].to
= toindex
;
716 toindex_byte
+= thislen_byte
;
717 toindex
+= thisleni
- combined
;
718 XSTRING (val
)->size
-= combined
;
720 /* Copy a single-byte string to a multibyte string. */
721 else if (STRINGP (this) && STRINGP (val
))
723 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
725 textprops
[num_textprops
].argnum
= argnum
;
726 textprops
[num_textprops
].from
= 0;
727 textprops
[num_textprops
++].to
= toindex
;
729 toindex_byte
+= copy_text (XSTRING (this)->data
,
730 XSTRING (val
)->data
+ toindex_byte
,
731 XSTRING (this)->size
, 0, 1);
735 /* Copy element by element. */
738 register Lisp_Object elt
;
740 /* Fetch next element of `this' arg into `elt', or break if
741 `this' is exhausted. */
742 if (NILP (this)) break;
744 elt
= XCAR (this), this = XCDR (this);
745 else if (thisindex
>= thisleni
)
747 else if (STRINGP (this))
750 if (STRING_MULTIBYTE (this))
752 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
755 XSETFASTINT (elt
, c
);
759 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
761 && (XINT (elt
) >= 0240
762 || (XINT (elt
) >= 0200
763 && ! NILP (Vnonascii_translation_table
)))
764 && XINT (elt
) < 0400)
766 c
= unibyte_char_to_multibyte (XINT (elt
));
771 else if (BOOL_VECTOR_P (this))
774 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
775 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
782 elt
= XVECTOR (this)->contents
[thisindex
++];
784 /* Store this element into the result. */
791 else if (VECTORP (val
))
792 XVECTOR (val
)->contents
[toindex
++] = elt
;
795 CHECK_NUMBER (elt
, 0);
796 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
800 += CHAR_STRING (XINT (elt
),
801 XSTRING (val
)->data
+ toindex_byte
);
803 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
806 && count_combining (XSTRING (val
)->data
,
807 toindex_byte
, toindex_byte
- 1))
808 XSTRING (val
)->size
--;
813 /* If we have any multibyte characters,
814 we already decided to make a multibyte string. */
817 /* P exists as a variable
818 to avoid a bug on the Masscomp C compiler. */
819 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
821 toindex_byte
+= CHAR_STRING (c
, p
);
828 XCDR (prev
) = last_tail
;
830 if (num_textprops
> 0)
833 int last_to_end
= -1;
835 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
837 this = args
[textprops
[argnum
].argnum
];
838 props
= text_property_list (this,
840 make_number (XSTRING (this)->size
),
842 /* If successive arguments have properites, be sure that the
843 value of `composition' property be the copy. */
844 if (last_to_end
== textprops
[argnum
].to
)
845 make_composition_value_copy (props
);
846 add_text_properties_from_list (val
, props
,
847 make_number (textprops
[argnum
].to
));
848 last_to_end
= textprops
[argnum
].to
+ XSTRING (this)->size
;
854 static Lisp_Object string_char_byte_cache_string
;
855 static int string_char_byte_cache_charpos
;
856 static int string_char_byte_cache_bytepos
;
859 clear_string_char_byte_cache ()
861 string_char_byte_cache_string
= Qnil
;
864 /* Return the character index corresponding to CHAR_INDEX in STRING. */
867 string_char_to_byte (string
, char_index
)
872 int best_below
, best_below_byte
;
873 int best_above
, best_above_byte
;
875 if (! STRING_MULTIBYTE (string
))
878 best_below
= best_below_byte
= 0;
879 best_above
= XSTRING (string
)->size
;
880 best_above_byte
= STRING_BYTES (XSTRING (string
));
882 if (EQ (string
, string_char_byte_cache_string
))
884 if (string_char_byte_cache_charpos
< char_index
)
886 best_below
= string_char_byte_cache_charpos
;
887 best_below_byte
= string_char_byte_cache_bytepos
;
891 best_above
= string_char_byte_cache_charpos
;
892 best_above_byte
= string_char_byte_cache_bytepos
;
896 if (char_index
- best_below
< best_above
- char_index
)
898 while (best_below
< char_index
)
901 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
902 best_below
, best_below_byte
);
905 i_byte
= best_below_byte
;
909 while (best_above
> char_index
)
911 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
912 unsigned char *pbeg
= pend
- best_above_byte
;
913 unsigned char *p
= pend
- 1;
916 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
917 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
918 if (bytes
== pend
- p
)
919 best_above_byte
-= bytes
;
920 else if (bytes
> pend
- p
)
921 best_above_byte
-= (pend
- p
);
927 i_byte
= best_above_byte
;
930 string_char_byte_cache_bytepos
= i_byte
;
931 string_char_byte_cache_charpos
= i
;
932 string_char_byte_cache_string
= string
;
937 /* Return the character index corresponding to BYTE_INDEX in STRING. */
940 string_byte_to_char (string
, byte_index
)
945 int best_below
, best_below_byte
;
946 int best_above
, best_above_byte
;
948 if (! STRING_MULTIBYTE (string
))
951 best_below
= best_below_byte
= 0;
952 best_above
= XSTRING (string
)->size
;
953 best_above_byte
= STRING_BYTES (XSTRING (string
));
955 if (EQ (string
, string_char_byte_cache_string
))
957 if (string_char_byte_cache_bytepos
< byte_index
)
959 best_below
= string_char_byte_cache_charpos
;
960 best_below_byte
= string_char_byte_cache_bytepos
;
964 best_above
= string_char_byte_cache_charpos
;
965 best_above_byte
= string_char_byte_cache_bytepos
;
969 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
971 while (best_below_byte
< byte_index
)
974 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
975 best_below
, best_below_byte
);
978 i_byte
= best_below_byte
;
982 while (best_above_byte
> byte_index
)
984 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
985 unsigned char *pbeg
= pend
- best_above_byte
;
986 unsigned char *p
= pend
- 1;
989 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
990 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
991 if (bytes
== pend
- p
)
992 best_above_byte
-= bytes
;
993 else if (bytes
> pend
- p
)
994 best_above_byte
-= (pend
- p
);
1000 i_byte
= best_above_byte
;
1003 string_char_byte_cache_bytepos
= i_byte
;
1004 string_char_byte_cache_charpos
= i
;
1005 string_char_byte_cache_string
= string
;
1010 /* Convert STRING to a multibyte string.
1011 Single-byte characters 0240 through 0377 are converted
1012 by adding nonascii_insert_offset to each. */
1015 string_make_multibyte (string
)
1021 if (STRING_MULTIBYTE (string
))
1024 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1025 XSTRING (string
)->size
);
1026 /* If all the chars are ASCII, they won't need any more bytes
1027 once converted. In that case, we can return STRING itself. */
1028 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1031 buf
= (unsigned char *) alloca (nbytes
);
1032 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1035 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1038 /* Convert STRING to a single-byte string. */
1041 string_make_unibyte (string
)
1046 if (! STRING_MULTIBYTE (string
))
1049 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1051 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1054 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1057 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1059 "Return the multibyte equivalent of STRING.\n\
1060 The function `unibyte-char-to-multibyte' is used to convert\n\
1061 each unibyte character to a multibyte character.")
1065 CHECK_STRING (string
, 0);
1067 return string_make_multibyte (string
);
1070 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1072 "Return the unibyte equivalent of STRING.\n\
1073 Multibyte character codes are converted to unibyte\n\
1074 by using just the low 8 bits.")
1078 CHECK_STRING (string
, 0);
1080 return string_make_unibyte (string
);
1083 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1085 "Return a unibyte string with the same individual bytes as STRING.\n\
1086 If STRING is unibyte, the result is STRING itself.\n\
1087 Otherwise it is a newly created string, with no text properties.\n\
1088 If STRING is multibyte and contains a character of charset\n\
1089 `eight-bit-control' or `eight-bit-graphic', it is converted to the\n\
1090 corresponding single byte.")
1094 CHECK_STRING (string
, 0);
1096 if (STRING_MULTIBYTE (string
))
1098 int bytes
= STRING_BYTES (XSTRING (string
));
1099 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1101 bcopy (XSTRING (string
)->data
, str
, bytes
);
1102 bytes
= str_as_unibyte (str
, bytes
);
1103 string
= make_unibyte_string (str
, bytes
);
1109 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1111 "Return a multibyte string with the same individual bytes as STRING.\n\
1112 If STRING is multibyte, the result is STRING itself.\n\
1113 Otherwise it is a newly created string, with no text properties.\n\
1114 If STRING is unibyte and contains an individual 8-bit byte (i.e. not\n\
1115 part of a multibyte form), it is converted to the corresponding\n\
1116 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.")
1120 CHECK_STRING (string
, 0);
1122 if (! STRING_MULTIBYTE (string
))
1124 Lisp_Object new_string
;
1127 parse_str_as_multibyte (XSTRING (string
)->data
,
1128 STRING_BYTES (XSTRING (string
)),
1130 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1131 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1132 STRING_BYTES (XSTRING (string
)));
1133 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1134 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1135 STRING_BYTES (XSTRING (string
)), NULL
);
1136 string
= new_string
;
1137 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1142 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1143 "Return a copy of ALIST.\n\
1144 This is an alist which represents the same mapping from objects to objects,\n\
1145 but does not share the alist structure with ALIST.\n\
1146 The objects mapped (cars and cdrs of elements of the alist)\n\
1147 are shared, however.\n\
1148 Elements of ALIST that are not conses are also shared.")
1152 register Lisp_Object tem
;
1154 CHECK_LIST (alist
, 0);
1157 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1158 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1160 register Lisp_Object car
;
1164 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1169 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1170 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1171 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1172 If FROM or TO is negative, it counts from the end.\n\
1174 This function allows vectors as well as strings.")
1177 register Lisp_Object from
, to
;
1182 int from_char
, to_char
;
1183 int from_byte
= 0, to_byte
= 0;
1185 if (! (STRINGP (string
) || VECTORP (string
)))
1186 wrong_type_argument (Qarrayp
, string
);
1188 CHECK_NUMBER (from
, 1);
1190 if (STRINGP (string
))
1192 size
= XSTRING (string
)->size
;
1193 size_byte
= STRING_BYTES (XSTRING (string
));
1196 size
= XVECTOR (string
)->size
;
1201 to_byte
= size_byte
;
1205 CHECK_NUMBER (to
, 2);
1207 to_char
= XINT (to
);
1211 if (STRINGP (string
))
1212 to_byte
= string_char_to_byte (string
, to_char
);
1215 from_char
= XINT (from
);
1218 if (STRINGP (string
))
1219 from_byte
= string_char_to_byte (string
, from_char
);
1221 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1222 args_out_of_range_3 (string
, make_number (from_char
),
1223 make_number (to_char
));
1225 if (STRINGP (string
))
1227 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1228 to_char
- from_char
, to_byte
- from_byte
,
1229 STRING_MULTIBYTE (string
));
1230 copy_text_properties (make_number (from_char
), make_number (to_char
),
1231 string
, make_number (0), res
, Qnil
);
1234 res
= Fvector (to_char
- from_char
,
1235 XVECTOR (string
)->contents
+ from_char
);
1240 /* Extract a substring of STRING, giving start and end positions
1241 both in characters and in bytes. */
1244 substring_both (string
, from
, from_byte
, to
, to_byte
)
1246 int from
, from_byte
, to
, to_byte
;
1252 if (! (STRINGP (string
) || VECTORP (string
)))
1253 wrong_type_argument (Qarrayp
, string
);
1255 if (STRINGP (string
))
1257 size
= XSTRING (string
)->size
;
1258 size_byte
= STRING_BYTES (XSTRING (string
));
1261 size
= XVECTOR (string
)->size
;
1263 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1264 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1266 if (STRINGP (string
))
1268 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1269 to
- from
, to_byte
- from_byte
,
1270 STRING_MULTIBYTE (string
));
1271 copy_text_properties (make_number (from
), make_number (to
),
1272 string
, make_number (0), res
, Qnil
);
1275 res
= Fvector (to
- from
,
1276 XVECTOR (string
)->contents
+ from
);
1281 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1282 "Take cdr N times on LIST, returns the result.")
1285 register Lisp_Object list
;
1287 register int i
, num
;
1288 CHECK_NUMBER (n
, 0);
1290 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1294 wrong_type_argument (Qlistp
, list
);
1300 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1301 "Return the Nth element of LIST.\n\
1302 N counts from zero. If LIST is not that long, nil is returned.")
1304 Lisp_Object n
, list
;
1306 return Fcar (Fnthcdr (n
, list
));
1309 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1310 "Return element of SEQUENCE at index N.")
1312 register Lisp_Object sequence
, n
;
1314 CHECK_NUMBER (n
, 0);
1317 if (CONSP (sequence
) || NILP (sequence
))
1318 return Fcar (Fnthcdr (n
, sequence
));
1319 else if (STRINGP (sequence
) || VECTORP (sequence
)
1320 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1321 return Faref (sequence
, n
);
1323 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1327 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1328 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1329 The value is actually the tail of LIST whose car is ELT.")
1331 register Lisp_Object elt
;
1334 register Lisp_Object tail
;
1335 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1337 register Lisp_Object tem
;
1339 wrong_type_argument (Qlistp
, list
);
1341 if (! NILP (Fequal (elt
, tem
)))
1348 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1349 "Return non-nil if ELT is an element of LIST.\n\
1350 Comparison done with EQ. The value is actually the tail of LIST\n\
1353 Lisp_Object elt
, list
;
1357 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1361 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1365 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1372 if (!CONSP (list
) && !NILP (list
))
1373 list
= wrong_type_argument (Qlistp
, list
);
1378 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1379 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1380 The value is actually the element of LIST whose car is KEY.\n\
1381 Elements of LIST that are not conses are ignored.")
1383 Lisp_Object key
, list
;
1390 || (CONSP (XCAR (list
))
1391 && EQ (XCAR (XCAR (list
)), key
)))
1396 || (CONSP (XCAR (list
))
1397 && EQ (XCAR (XCAR (list
)), key
)))
1402 || (CONSP (XCAR (list
))
1403 && EQ (XCAR (XCAR (list
)), key
)))
1411 result
= XCAR (list
);
1412 else if (NILP (list
))
1415 result
= wrong_type_argument (Qlistp
, list
);
1420 /* Like Fassq but never report an error and do not allow quits.
1421 Use only on lists known never to be circular. */
1424 assq_no_quit (key
, list
)
1425 Lisp_Object key
, list
;
1428 && (!CONSP (XCAR (list
))
1429 || !EQ (XCAR (XCAR (list
)), key
)))
1432 return CONSP (list
) ? XCAR (list
) : Qnil
;
1435 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1436 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1437 The value is actually the element of LIST whose car equals KEY.")
1439 Lisp_Object key
, list
;
1441 Lisp_Object result
, car
;
1446 || (CONSP (XCAR (list
))
1447 && (car
= XCAR (XCAR (list
)),
1448 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1453 || (CONSP (XCAR (list
))
1454 && (car
= XCAR (XCAR (list
)),
1455 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1460 || (CONSP (XCAR (list
))
1461 && (car
= XCAR (XCAR (list
)),
1462 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1470 result
= XCAR (list
);
1471 else if (NILP (list
))
1474 result
= wrong_type_argument (Qlistp
, list
);
1479 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1480 "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
1481 The value is actually the element of LIST whose cdr is KEY.")
1483 register Lisp_Object key
;
1491 || (CONSP (XCAR (list
))
1492 && EQ (XCDR (XCAR (list
)), key
)))
1497 || (CONSP (XCAR (list
))
1498 && EQ (XCDR (XCAR (list
)), key
)))
1503 || (CONSP (XCAR (list
))
1504 && EQ (XCDR (XCAR (list
)), key
)))
1513 else if (CONSP (list
))
1514 result
= XCAR (list
);
1516 result
= wrong_type_argument (Qlistp
, list
);
1521 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1522 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1523 The value is actually the element of LIST whose cdr equals KEY.")
1525 Lisp_Object key
, list
;
1527 Lisp_Object result
, cdr
;
1532 || (CONSP (XCAR (list
))
1533 && (cdr
= XCDR (XCAR (list
)),
1534 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1539 || (CONSP (XCAR (list
))
1540 && (cdr
= XCDR (XCAR (list
)),
1541 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1546 || (CONSP (XCAR (list
))
1547 && (cdr
= XCDR (XCAR (list
)),
1548 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1556 result
= XCAR (list
);
1557 else if (NILP (list
))
1560 result
= wrong_type_argument (Qlistp
, list
);
1565 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1566 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1567 The modified LIST is returned. Comparison is done with `eq'.\n\
1568 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1569 therefore, write `(setq foo (delq element foo))'\n\
1570 to be sure of changing the value of `foo'.")
1572 register Lisp_Object elt
;
1575 register Lisp_Object tail
, prev
;
1576 register Lisp_Object tem
;
1580 while (!NILP (tail
))
1583 wrong_type_argument (Qlistp
, list
);
1590 Fsetcdr (prev
, XCDR (tail
));
1600 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1601 "Delete by side effect any occurrences of ELT as a member of SEQ.\n\
1602 SEQ must be a list, a vector, or a string.\n\
1603 The modified SEQ is returned. Comparison is done with `equal'.\n\
1604 If SEQ is not a list, or the first member of SEQ is ELT, deleting it\n\
1605 is not a side effect; it is simply using a different sequence.\n\
1606 Therefore, write `(setq foo (delete element foo))'\n\
1607 to be sure of changing the value of `foo'.")
1609 Lisp_Object elt
, seq
;
1615 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1616 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1619 if (n
!= ASIZE (seq
))
1621 struct Lisp_Vector
*p
= allocate_vectorlike (n
);
1623 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1624 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1625 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.")
1866 register Lisp_Object prop
;
1868 register Lisp_Object tail
;
1869 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCDR (tail
)))
1871 register Lisp_Object tem
;
1874 return Fcar (XCDR (tail
));
1879 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1880 "Return the value of SYMBOL's PROPNAME property.\n\
1881 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1883 Lisp_Object symbol
, propname
;
1885 CHECK_SYMBOL (symbol
, 0);
1886 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1889 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1890 "Change value in PLIST of PROP to VAL.\n\
1891 PLIST is a property list, which is a list of the form\n\
1892 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1893 If PROP is already a property on the list, its value is set to VAL,\n\
1894 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1895 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1896 The PLIST is modified by side effects.")
1899 register Lisp_Object prop
;
1902 register Lisp_Object tail
, prev
;
1903 Lisp_Object newcell
;
1905 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1906 tail
= XCDR (XCDR (tail
)))
1908 if (EQ (prop
, XCAR (tail
)))
1910 Fsetcar (XCDR (tail
), val
);
1915 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1919 Fsetcdr (XCDR (prev
), newcell
);
1923 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1924 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1925 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1926 (symbol
, propname
, value
)
1927 Lisp_Object symbol
, propname
, value
;
1929 CHECK_SYMBOL (symbol
, 0);
1930 XSYMBOL (symbol
)->plist
1931 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1935 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1936 "Return t if two Lisp objects have similar structure and contents.\n\
1937 They must have the same data type.\n\
1938 Conses are compared by comparing the cars and the cdrs.\n\
1939 Vectors and strings are compared element by element.\n\
1940 Numbers are compared by value, but integers cannot equal floats.\n\
1941 (Use `=' if you want integers and floats to be able to be equal.)\n\
1942 Symbols must match exactly.")
1944 register Lisp_Object o1
, o2
;
1946 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1950 internal_equal (o1
, o2
, depth
)
1951 register Lisp_Object o1
, o2
;
1955 error ("Stack overflow in equal");
1961 if (XTYPE (o1
) != XTYPE (o2
))
1967 return (extract_float (o1
) == extract_float (o2
));
1970 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1977 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1981 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1983 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1986 o1
= XOVERLAY (o1
)->plist
;
1987 o2
= XOVERLAY (o2
)->plist
;
1992 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1993 && (XMARKER (o1
)->buffer
== 0
1994 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1998 case Lisp_Vectorlike
:
2000 register int i
, size
;
2001 size
= XVECTOR (o1
)->size
;
2002 /* Pseudovectors have the type encoded in the size field, so this test
2003 actually checks that the objects have the same type as well as the
2005 if (XVECTOR (o2
)->size
!= size
)
2007 /* Boolvectors are compared much like strings. */
2008 if (BOOL_VECTOR_P (o1
))
2011 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2013 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2015 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2020 if (WINDOW_CONFIGURATIONP (o1
))
2021 return compare_window_configurations (o1
, o2
, 0);
2023 /* Aside from them, only true vectors, char-tables, and compiled
2024 functions are sensible to compare, so eliminate the others now. */
2025 if (size
& PSEUDOVECTOR_FLAG
)
2027 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2029 size
&= PSEUDOVECTOR_SIZE_MASK
;
2031 for (i
= 0; i
< size
; i
++)
2034 v1
= XVECTOR (o1
)->contents
[i
];
2035 v2
= XVECTOR (o2
)->contents
[i
];
2036 if (!internal_equal (v1
, v2
, depth
+ 1))
2044 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
2046 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
2048 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
2049 STRING_BYTES (XSTRING (o1
))))
2055 case Lisp_Type_Limit
:
2062 extern Lisp_Object
Fmake_char_internal ();
2064 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2065 "Store each element of ARRAY with ITEM.\n\
2066 ARRAY is a vector, string, char-table, or bool-vector.")
2068 Lisp_Object array
, item
;
2070 register int size
, index
, charval
;
2072 if (VECTORP (array
))
2074 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2075 size
= XVECTOR (array
)->size
;
2076 for (index
= 0; index
< size
; index
++)
2079 else if (CHAR_TABLE_P (array
))
2081 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2082 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2083 for (index
= 0; index
< size
; index
++)
2085 XCHAR_TABLE (array
)->defalt
= Qnil
;
2087 else if (STRINGP (array
))
2089 register unsigned char *p
= XSTRING (array
)->data
;
2090 CHECK_NUMBER (item
, 1);
2091 charval
= XINT (item
);
2092 size
= XSTRING (array
)->size
;
2093 if (STRING_MULTIBYTE (array
))
2095 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2096 int len
= CHAR_STRING (charval
, str
);
2097 int size_byte
= STRING_BYTES (XSTRING (array
));
2098 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2101 if (size
!= size_byte
)
2104 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2105 if (len
!= this_len
)
2106 error ("Attempt to change byte length of a string");
2109 for (i
= 0; i
< size_byte
; i
++)
2110 *p
++ = str
[i
% len
];
2113 for (index
= 0; index
< size
; index
++)
2116 else if (BOOL_VECTOR_P (array
))
2118 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2120 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2122 charval
= (! NILP (item
) ? -1 : 0);
2123 for (index
= 0; index
< size_in_chars
; index
++)
2128 array
= wrong_type_argument (Qarrayp
, array
);
2134 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2136 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
2138 Lisp_Object char_table
;
2140 CHECK_CHAR_TABLE (char_table
, 0);
2142 return XCHAR_TABLE (char_table
)->purpose
;
2145 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2147 "Return the parent char-table of CHAR-TABLE.\n\
2148 The value is either nil or another char-table.\n\
2149 If CHAR-TABLE holds nil for a given character,\n\
2150 then the actual applicable value is inherited from the parent char-table\n\
2151 \(or from its parents, if necessary).")
2153 Lisp_Object char_table
;
2155 CHECK_CHAR_TABLE (char_table
, 0);
2157 return XCHAR_TABLE (char_table
)->parent
;
2160 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2162 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
2163 PARENT must be either nil or another char-table.")
2164 (char_table
, parent
)
2165 Lisp_Object char_table
, parent
;
2169 CHECK_CHAR_TABLE (char_table
, 0);
2173 CHECK_CHAR_TABLE (parent
, 0);
2175 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2176 if (EQ (temp
, char_table
))
2177 error ("Attempt to make a chartable be its own parent");
2180 XCHAR_TABLE (char_table
)->parent
= parent
;
2185 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2187 "Return the value of CHAR-TABLE's extra-slot number N.")
2189 Lisp_Object char_table
, n
;
2191 CHECK_CHAR_TABLE (char_table
, 1);
2192 CHECK_NUMBER (n
, 2);
2194 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2195 args_out_of_range (char_table
, n
);
2197 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2200 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2201 Sset_char_table_extra_slot
,
2203 "Set CHAR-TABLE's extra-slot number N to VALUE.")
2204 (char_table
, n
, value
)
2205 Lisp_Object char_table
, n
, value
;
2207 CHECK_CHAR_TABLE (char_table
, 1);
2208 CHECK_NUMBER (n
, 2);
2210 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2211 args_out_of_range (char_table
, n
);
2213 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2216 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2218 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
2219 RANGE should be nil (for the default value)\n\
2220 a vector which identifies a character set or a row of a character set,\n\
2221 a character set name, or a character code.")
2223 Lisp_Object char_table
, range
;
2225 CHECK_CHAR_TABLE (char_table
, 0);
2227 if (EQ (range
, Qnil
))
2228 return XCHAR_TABLE (char_table
)->defalt
;
2229 else if (INTEGERP (range
))
2230 return Faref (char_table
, range
);
2231 else if (SYMBOLP (range
))
2233 Lisp_Object charset_info
;
2235 charset_info
= Fget (range
, Qcharset
);
2236 CHECK_VECTOR (charset_info
, 0);
2238 return Faref (char_table
,
2239 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2242 else if (VECTORP (range
))
2244 if (XVECTOR (range
)->size
== 1)
2245 return Faref (char_table
,
2246 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2249 int size
= XVECTOR (range
)->size
;
2250 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2251 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2252 size
<= 1 ? Qnil
: val
[1],
2253 size
<= 2 ? Qnil
: val
[2]);
2254 return Faref (char_table
, ch
);
2258 error ("Invalid RANGE argument to `char-table-range'");
2262 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2264 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2265 RANGE should be t (for all characters), nil (for the default value)\n\
2266 a vector which identifies a character set or a row of a character set,\n\
2267 a coding system, or a character code.")
2268 (char_table
, range
, value
)
2269 Lisp_Object char_table
, range
, value
;
2273 CHECK_CHAR_TABLE (char_table
, 0);
2276 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2277 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2278 else if (EQ (range
, Qnil
))
2279 XCHAR_TABLE (char_table
)->defalt
= value
;
2280 else if (SYMBOLP (range
))
2282 Lisp_Object charset_info
;
2284 charset_info
= Fget (range
, Qcharset
);
2285 CHECK_VECTOR (charset_info
, 0);
2287 return Faset (char_table
,
2288 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2292 else if (INTEGERP (range
))
2293 Faset (char_table
, range
, value
);
2294 else if (VECTORP (range
))
2296 if (XVECTOR (range
)->size
== 1)
2297 return Faset (char_table
,
2298 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2302 int size
= XVECTOR (range
)->size
;
2303 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2304 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2305 size
<= 1 ? Qnil
: val
[1],
2306 size
<= 2 ? Qnil
: val
[2]);
2307 return Faset (char_table
, ch
, value
);
2311 error ("Invalid RANGE argument to `set-char-table-range'");
2316 DEFUN ("set-char-table-default", Fset_char_table_default
,
2317 Sset_char_table_default
, 3, 3, 0,
2318 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2319 The generic character specifies the group of characters.\n\
2320 See also the documentation of make-char.")
2321 (char_table
, ch
, value
)
2322 Lisp_Object char_table
, ch
, value
;
2324 int c
, charset
, code1
, code2
;
2327 CHECK_CHAR_TABLE (char_table
, 0);
2328 CHECK_NUMBER (ch
, 1);
2331 SPLIT_CHAR (c
, charset
, code1
, code2
);
2333 /* Since we may want to set the default value for a character set
2334 not yet defined, we check only if the character set is in the
2335 valid range or not, instead of it is already defined or not. */
2336 if (! CHARSET_VALID_P (charset
))
2337 invalid_character (c
);
2339 if (charset
== CHARSET_ASCII
)
2340 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2342 /* Even if C is not a generic char, we had better behave as if a
2343 generic char is specified. */
2344 if (CHARSET_DIMENSION (charset
) == 1)
2346 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2349 if (SUB_CHAR_TABLE_P (temp
))
2350 XCHAR_TABLE (temp
)->defalt
= value
;
2352 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2356 if (! SUB_CHAR_TABLE_P (char_table
))
2357 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2358 = make_sub_char_table (temp
));
2359 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2360 if (SUB_CHAR_TABLE_P (temp
))
2361 XCHAR_TABLE (temp
)->defalt
= value
;
2363 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2367 /* Look up the element in TABLE at index CH,
2368 and return it as an integer.
2369 If the element is nil, return CH itself.
2370 (Actually we do that for any non-integer.) */
2373 char_table_translate (table
, ch
)
2378 value
= Faref (table
, make_number (ch
));
2379 if (! INTEGERP (value
))
2381 return XINT (value
);
2385 optimize_sub_char_table (table
, chars
)
2393 from
= 33, to
= 127;
2395 from
= 32, to
= 128;
2397 if (!SUB_CHAR_TABLE_P (*table
))
2399 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2400 for (; from
< to
; from
++)
2401 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2406 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2408 "Optimize char table TABLE.")
2416 CHECK_CHAR_TABLE (table
, 0);
2418 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2420 elt
= XCHAR_TABLE (table
)->contents
[i
];
2421 if (!SUB_CHAR_TABLE_P (elt
))
2423 dim
= CHARSET_DIMENSION (i
- 128);
2425 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2426 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2427 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2433 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2434 character or group of characters that share a value.
2435 DEPTH is the current depth in the originally specified
2436 chartable, and INDICES contains the vector indices
2437 for the levels our callers have descended.
2439 ARG is passed to C_FUNCTION when that is called. */
2442 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2443 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2444 Lisp_Object function
, subtable
, arg
, *indices
;
2451 /* At first, handle ASCII and 8-bit European characters. */
2452 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2454 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2456 (*c_function
) (arg
, make_number (i
), elt
);
2458 call2 (function
, make_number (i
), elt
);
2460 #if 0 /* If the char table has entries for higher characters,
2461 we should report them. */
2462 if (NILP (current_buffer
->enable_multibyte_characters
))
2465 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2469 int charset
= XFASTINT (indices
[0]) - 128;
2472 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2473 if (CHARSET_CHARS (charset
) == 94)
2482 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2483 XSETFASTINT (indices
[depth
], i
);
2484 charset
= XFASTINT (indices
[0]) - 128;
2486 && (!CHARSET_DEFINED_P (charset
)
2487 || charset
== CHARSET_8_BIT_CONTROL
2488 || charset
== CHARSET_8_BIT_GRAPHIC
))
2491 if (SUB_CHAR_TABLE_P (elt
))
2494 error ("Too deep char table");
2495 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2502 elt
= XCHAR_TABLE (subtable
)->defalt
;
2503 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2504 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2505 c
= MAKE_CHAR (charset
, c1
, c2
);
2507 (*c_function
) (arg
, make_number (c
), elt
);
2509 call2 (function
, make_number (c
), elt
);
2514 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2516 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2517 FUNCTION is called with two arguments--a key and a value.\n\
2518 The key is always a possible IDX argument to `aref'.")
2519 (function
, char_table
)
2520 Lisp_Object function
, char_table
;
2522 /* The depth of char table is at most 3. */
2523 Lisp_Object indices
[3];
2525 CHECK_CHAR_TABLE (char_table
, 1);
2527 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2531 /* Return a value for character C in char-table TABLE. Store the
2532 actual index for that value in *IDX. Ignore the default value of
2536 char_table_ref_and_index (table
, c
, idx
)
2540 int charset
, c1
, c2
;
2543 if (SINGLE_BYTE_CHAR_P (c
))
2546 return XCHAR_TABLE (table
)->contents
[c
];
2548 SPLIT_CHAR (c
, charset
, c1
, c2
);
2549 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2550 *idx
= MAKE_CHAR (charset
, 0, 0);
2551 if (!SUB_CHAR_TABLE_P (elt
))
2553 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2554 return XCHAR_TABLE (elt
)->defalt
;
2555 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2556 *idx
= MAKE_CHAR (charset
, c1
, 0);
2557 if (!SUB_CHAR_TABLE_P (elt
))
2559 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2560 return XCHAR_TABLE (elt
)->defalt
;
2562 return XCHAR_TABLE (elt
)->contents
[c2
];
2572 Lisp_Object args
[2];
2575 return Fnconc (2, args
);
2577 return Fnconc (2, &s1
);
2578 #endif /* NO_ARG_ARRAY */
2581 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2582 "Concatenate any number of lists by altering them.\n\
2583 Only the last argument is not altered, and need not be a list.")
2588 register int argnum
;
2589 register Lisp_Object tail
, tem
, val
;
2593 for (argnum
= 0; argnum
< nargs
; argnum
++)
2596 if (NILP (tem
)) continue;
2601 if (argnum
+ 1 == nargs
) break;
2604 tem
= wrong_type_argument (Qlistp
, tem
);
2613 tem
= args
[argnum
+ 1];
2614 Fsetcdr (tail
, tem
);
2616 args
[argnum
+ 1] = tail
;
2622 /* This is the guts of all mapping functions.
2623 Apply FN to each element of SEQ, one by one,
2624 storing the results into elements of VALS, a C vector of Lisp_Objects.
2625 LENI is the length of VALS, which should also be the length of SEQ. */
2628 mapcar1 (leni
, vals
, fn
, seq
)
2631 Lisp_Object fn
, seq
;
2633 register Lisp_Object tail
;
2636 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2640 /* Don't let vals contain any garbage when GC happens. */
2641 for (i
= 0; i
< leni
; i
++)
2644 GCPRO3 (dummy
, fn
, seq
);
2646 gcpro1
.nvars
= leni
;
2650 /* We need not explicitly protect `tail' because it is used only on lists, and
2651 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2655 for (i
= 0; i
< leni
; i
++)
2657 dummy
= XVECTOR (seq
)->contents
[i
];
2658 dummy
= call1 (fn
, dummy
);
2663 else if (BOOL_VECTOR_P (seq
))
2665 for (i
= 0; i
< leni
; i
++)
2668 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2669 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2674 dummy
= call1 (fn
, dummy
);
2679 else if (STRINGP (seq
))
2683 for (i
= 0, i_byte
= 0; i
< leni
;)
2688 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2689 XSETFASTINT (dummy
, c
);
2690 dummy
= call1 (fn
, dummy
);
2692 vals
[i_before
] = dummy
;
2695 else /* Must be a list, since Flength did not get an error */
2698 for (i
= 0; i
< leni
; i
++)
2700 dummy
= call1 (fn
, Fcar (tail
));
2710 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2711 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2712 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2713 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2714 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2715 (function
, sequence
, separator
)
2716 Lisp_Object function
, sequence
, separator
;
2721 register Lisp_Object
*args
;
2723 struct gcpro gcpro1
;
2725 len
= Flength (sequence
);
2727 nargs
= leni
+ leni
- 1;
2728 if (nargs
< 0) return build_string ("");
2730 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2733 mapcar1 (leni
, args
, function
, sequence
);
2736 for (i
= leni
- 1; i
>= 0; i
--)
2737 args
[i
+ i
] = args
[i
];
2739 for (i
= 1; i
< nargs
; i
+= 2)
2740 args
[i
] = separator
;
2742 return Fconcat (nargs
, args
);
2745 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2746 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2747 The result is a list just as long as SEQUENCE.\n\
2748 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2749 (function
, sequence
)
2750 Lisp_Object function
, sequence
;
2752 register Lisp_Object len
;
2754 register Lisp_Object
*args
;
2756 len
= Flength (sequence
);
2757 leni
= XFASTINT (len
);
2758 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2760 mapcar1 (leni
, args
, function
, sequence
);
2762 return Flist (leni
, args
);
2765 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2766 "Apply FUNCTION to each element of SEQUENCE for side effects only.\n\
2767 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.\n\
2768 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2769 (function
, sequence
)
2770 Lisp_Object function
, sequence
;
2774 leni
= XFASTINT (Flength (sequence
));
2775 mapcar1 (leni
, 0, function
, sequence
);
2780 /* Anything that calls this function must protect from GC! */
2782 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2783 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2784 Takes one argument, which is the string to display to ask the question.\n\
2785 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2786 No confirmation of the answer is requested; a single character is enough.\n\
2787 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2788 the bindings in `query-replace-map'; see the documentation of that variable\n\
2789 for more information. In this case, the useful bindings are `act', `skip',\n\
2790 `recenter', and `quit'.\)\n\
2792 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2793 is nil and `use-dialog-box' is non-nil.")
2797 register Lisp_Object obj
, key
, def
, map
;
2798 register int answer
;
2799 Lisp_Object xprompt
;
2800 Lisp_Object args
[2];
2801 struct gcpro gcpro1
, gcpro2
;
2802 int count
= specpdl_ptr
- specpdl
;
2804 specbind (Qcursor_in_echo_area
, Qt
);
2806 map
= Fsymbol_value (intern ("query-replace-map"));
2808 CHECK_STRING (prompt
, 0);
2810 GCPRO2 (prompt
, xprompt
);
2812 #ifdef HAVE_X_WINDOWS
2813 if (display_busy_cursor_p
)
2814 cancel_busy_cursor ();
2821 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2825 Lisp_Object pane
, menu
;
2826 redisplay_preserve_echo_area (3);
2827 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2828 Fcons (Fcons (build_string ("No"), Qnil
),
2830 menu
= Fcons (prompt
, pane
);
2831 obj
= Fx_popup_dialog (Qt
, menu
);
2832 answer
= !NILP (obj
);
2835 #endif /* HAVE_MENUS */
2836 cursor_in_echo_area
= 1;
2837 choose_minibuf_frame ();
2838 message_with_string ("%s(y or n) ", xprompt
, 0);
2840 if (minibuffer_auto_raise
)
2842 Lisp_Object mini_frame
;
2844 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2846 Fraise_frame (mini_frame
);
2849 obj
= read_filtered_event (1, 0, 0, 0);
2850 cursor_in_echo_area
= 0;
2851 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2854 key
= Fmake_vector (make_number (1), obj
);
2855 def
= Flookup_key (map
, key
, Qt
);
2857 if (EQ (def
, intern ("skip")))
2862 else if (EQ (def
, intern ("act")))
2867 else if (EQ (def
, intern ("recenter")))
2873 else if (EQ (def
, intern ("quit")))
2875 /* We want to exit this command for exit-prefix,
2876 and this is the only way to do it. */
2877 else if (EQ (def
, intern ("exit-prefix")))
2882 /* If we don't clear this, then the next call to read_char will
2883 return quit_char again, and we'll enter an infinite loop. */
2888 if (EQ (xprompt
, prompt
))
2890 args
[0] = build_string ("Please answer y or n. ");
2892 xprompt
= Fconcat (2, args
);
2897 if (! noninteractive
)
2899 cursor_in_echo_area
= -1;
2900 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2904 unbind_to (count
, Qnil
);
2905 return answer
? Qt
: Qnil
;
2908 /* This is how C code calls `yes-or-no-p' and allows the user
2911 Anything that calls this function must protect from GC! */
2914 do_yes_or_no_p (prompt
)
2917 return call1 (intern ("yes-or-no-p"), prompt
);
2920 /* Anything that calls this function must protect from GC! */
2922 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2923 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2924 Takes one argument, which is the string to display to ask the question.\n\
2925 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2926 The user must confirm the answer with RET,\n\
2927 and can edit it until it has been confirmed.\n\
2929 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2930 is nil, and `use-dialog-box' is non-nil.")
2934 register Lisp_Object ans
;
2935 Lisp_Object args
[2];
2936 struct gcpro gcpro1
;
2938 CHECK_STRING (prompt
, 0);
2941 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2945 Lisp_Object pane
, menu
, obj
;
2946 redisplay_preserve_echo_area (4);
2947 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2948 Fcons (Fcons (build_string ("No"), Qnil
),
2951 menu
= Fcons (prompt
, pane
);
2952 obj
= Fx_popup_dialog (Qt
, menu
);
2956 #endif /* HAVE_MENUS */
2959 args
[1] = build_string ("(yes or no) ");
2960 prompt
= Fconcat (2, args
);
2966 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2967 Qyes_or_no_p_history
, Qnil
,
2969 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2974 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2982 message ("Please answer yes or no.");
2983 Fsleep_for (make_number (2), Qnil
);
2987 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2988 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2989 Each of the three load averages is multiplied by 100,\n\
2990 then converted to integer.\n\
2991 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2992 These floats are not multiplied by 100.\n\n\
2993 If the 5-minute or 15-minute load averages are not available, return a\n\
2994 shortened list, containing only those averages which are available.")
2996 Lisp_Object use_floats
;
2999 int loads
= getloadavg (load_ave
, 3);
3000 Lisp_Object ret
= Qnil
;
3003 error ("load-average not implemented for this operating system");
3007 Lisp_Object load
= (NILP (use_floats
) ?
3008 make_number ((int) (100.0 * load_ave
[loads
]))
3009 : make_float (load_ave
[loads
]));
3010 ret
= Fcons (load
, ret
);
3016 Lisp_Object Vfeatures
;
3018 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
3019 "Returns t if FEATURE is present in this Emacs.\n\
3020 Use this to conditionalize execution of lisp code based on the presence or\n\
3021 absence of emacs or environment extensions.\n\
3022 Use `provide' to declare that a feature is available.\n\
3023 This function looks at the value of the variable `features'.")
3025 Lisp_Object feature
;
3027 register Lisp_Object tem
;
3028 CHECK_SYMBOL (feature
, 0);
3029 tem
= Fmemq (feature
, Vfeatures
);
3030 return (NILP (tem
)) ? Qnil
: Qt
;
3033 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
3034 "Announce that FEATURE is a feature of the current Emacs.")
3036 Lisp_Object feature
;
3038 register Lisp_Object tem
;
3039 CHECK_SYMBOL (feature
, 0);
3040 if (!NILP (Vautoload_queue
))
3041 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3042 tem
= Fmemq (feature
, Vfeatures
);
3044 Vfeatures
= Fcons (feature
, Vfeatures
);
3045 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3049 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3050 "If feature FEATURE is not loaded, load it from FILENAME.\n\
3051 If FEATURE is not a member of the list `features', then the feature\n\
3052 is not loaded; so load the file FILENAME.\n\
3053 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
3054 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
3055 If the optional third argument NOERROR is non-nil,\n\
3056 then return nil if the file is not found.\n\
3057 Normally the return value is FEATURE.\n\
3058 This normal messages at start and end of loading FILENAME are suppressed.")
3059 (feature
, file_name
, noerror
)
3060 Lisp_Object feature
, file_name
, noerror
;
3062 register Lisp_Object tem
;
3063 CHECK_SYMBOL (feature
, 0);
3064 tem
= Fmemq (feature
, Vfeatures
);
3066 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3070 int count
= specpdl_ptr
- specpdl
;
3072 /* Value saved here is to be restored into Vautoload_queue */
3073 record_unwind_protect (un_autoload
, Vautoload_queue
);
3074 Vautoload_queue
= Qt
;
3076 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
3077 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
3078 /* If load failed entirely, return nil. */
3080 return unbind_to (count
, Qnil
);
3082 tem
= Fmemq (feature
, Vfeatures
);
3084 error ("Required feature %s was not provided",
3085 XSYMBOL (feature
)->name
->data
);
3087 /* Once loading finishes, don't undo it. */
3088 Vautoload_queue
= Qt
;
3089 feature
= unbind_to (count
, feature
);
3094 /* Primitives for work of the "widget" library.
3095 In an ideal world, this section would not have been necessary.
3096 However, lisp function calls being as slow as they are, it turns
3097 out that some functions in the widget library (wid-edit.el) are the
3098 bottleneck of Widget operation. Here is their translation to C,
3099 for the sole reason of efficiency. */
3101 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3102 "Return non-nil if PLIST has the property PROP.\n\
3103 PLIST is a property list, which is a list of the form\n\
3104 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
3105 Unlike `plist-get', this allows you to distinguish between a missing\n\
3106 property and a property with the value nil.\n\
3107 The value is actually the tail of PLIST whose car is PROP.")
3109 Lisp_Object plist
, prop
;
3111 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3114 plist
= XCDR (plist
);
3115 plist
= CDR (plist
);
3120 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3121 "In WIDGET, set PROPERTY to VALUE.\n\
3122 The value can later be retrieved with `widget-get'.")
3123 (widget
, property
, value
)
3124 Lisp_Object widget
, property
, value
;
3126 CHECK_CONS (widget
, 1);
3127 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
3131 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3132 "In WIDGET, get the value of PROPERTY.\n\
3133 The value could either be specified when the widget was created, or\n\
3134 later with `widget-put'.")
3136 Lisp_Object widget
, property
;
3144 CHECK_CONS (widget
, 1);
3145 tmp
= Fplist_member (XCDR (widget
), property
);
3151 tmp
= XCAR (widget
);
3154 widget
= Fget (tmp
, Qwidget_type
);
3158 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3159 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
3160 ARGS are passed as extra arguments to the function.")
3165 /* This function can GC. */
3166 Lisp_Object newargs
[3];
3167 struct gcpro gcpro1
, gcpro2
;
3170 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3171 newargs
[1] = args
[0];
3172 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3173 GCPRO2 (newargs
[0], newargs
[2]);
3174 result
= Fapply (3, newargs
);
3179 /* base64 encode/decode functions (RFC 2045).
3180 Based on code from GNU recode. */
3182 #define MIME_LINE_LENGTH 76
3184 #define IS_ASCII(Character) \
3186 #define IS_BASE64(Character) \
3187 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3188 #define IS_BASE64_IGNORABLE(Character) \
3189 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3190 || (Character) == '\f' || (Character) == '\r')
3192 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3193 character or return retval if there are no characters left to
3195 #define READ_QUADRUPLET_BYTE(retval) \
3200 if (nchars_return) \
3201 *nchars_return = nchars; \
3206 while (IS_BASE64_IGNORABLE (c))
3208 /* Don't use alloca for regions larger than this, lest we overflow
3210 #define MAX_ALLOCA 16*1024
3212 /* Table of characters coding the 64 values. */
3213 static char base64_value_to_char
[64] =
3215 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3216 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3217 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3218 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3219 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3220 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3221 '8', '9', '+', '/' /* 60-63 */
3224 /* Table of base64 values for first 128 characters. */
3225 static short base64_char_to_value
[128] =
3227 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3228 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3229 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3230 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3231 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3232 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3233 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3234 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3235 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3236 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3237 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3238 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3239 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3242 /* The following diagram shows the logical steps by which three octets
3243 get transformed into four base64 characters.
3245 .--------. .--------. .--------.
3246 |aaaaaabb| |bbbbcccc| |ccdddddd|
3247 `--------' `--------' `--------'
3249 .--------+--------+--------+--------.
3250 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3251 `--------+--------+--------+--------'
3253 .--------+--------+--------+--------.
3254 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3255 `--------+--------+--------+--------'
3257 The octets are divided into 6 bit chunks, which are then encoded into
3258 base64 characters. */
3261 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3262 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3264 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3266 "Base64-encode the region between BEG and END.\n\
3267 Return the length of the encoded text.\n\
3268 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3269 into shorter lines.")
3270 (beg
, end
, no_line_break
)
3271 Lisp_Object beg
, end
, no_line_break
;
3274 int allength
, length
;
3275 int ibeg
, iend
, encoded_length
;
3278 validate_region (&beg
, &end
);
3280 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3281 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3282 move_gap_both (XFASTINT (beg
), ibeg
);
3284 /* We need to allocate enough room for encoding the text.
3285 We need 33 1/3% more space, plus a newline every 76
3286 characters, and then we round up. */
3287 length
= iend
- ibeg
;
3288 allength
= length
+ length
/3 + 1;
3289 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3291 if (allength
<= MAX_ALLOCA
)
3292 encoded
= (char *) alloca (allength
);
3294 encoded
= (char *) xmalloc (allength
);
3295 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3296 NILP (no_line_break
),
3297 !NILP (current_buffer
->enable_multibyte_characters
));
3298 if (encoded_length
> allength
)
3301 if (encoded_length
< 0)
3303 /* The encoding wasn't possible. */
3304 if (length
> MAX_ALLOCA
)
3306 error ("Multibyte character in data for base64 encoding");
3309 /* Now we have encoded the region, so we insert the new contents
3310 and delete the old. (Insert first in order to preserve markers.) */
3311 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3312 insert (encoded
, encoded_length
);
3313 if (allength
> MAX_ALLOCA
)
3315 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3317 /* If point was outside of the region, restore it exactly; else just
3318 move to the beginning of the region. */
3319 if (old_pos
>= XFASTINT (end
))
3320 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3321 else if (old_pos
> XFASTINT (beg
))
3322 old_pos
= XFASTINT (beg
);
3325 /* We return the length of the encoded text. */
3326 return make_number (encoded_length
);
3329 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3331 "Base64-encode STRING and return the result.\n\
3332 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3333 into shorter lines.")
3334 (string
, no_line_break
)
3335 Lisp_Object string
, no_line_break
;
3337 int allength
, length
, encoded_length
;
3339 Lisp_Object encoded_string
;
3341 CHECK_STRING (string
, 1);
3343 /* We need to allocate enough room for encoding the text.
3344 We need 33 1/3% more space, plus a newline every 76
3345 characters, and then we round up. */
3346 length
= STRING_BYTES (XSTRING (string
));
3347 allength
= length
+ length
/3 + 1;
3348 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3350 /* We need to allocate enough room for decoding the text. */
3351 if (allength
<= MAX_ALLOCA
)
3352 encoded
= (char *) alloca (allength
);
3354 encoded
= (char *) xmalloc (allength
);
3356 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3357 encoded
, length
, NILP (no_line_break
),
3358 STRING_MULTIBYTE (string
));
3359 if (encoded_length
> allength
)
3362 if (encoded_length
< 0)
3364 /* The encoding wasn't possible. */
3365 if (length
> MAX_ALLOCA
)
3367 error ("Multibyte character in data for base64 encoding");
3370 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3371 if (allength
> MAX_ALLOCA
)
3374 return encoded_string
;
3378 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3385 int counter
= 0, i
= 0;
3395 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3403 /* Wrap line every 76 characters. */
3407 if (counter
< MIME_LINE_LENGTH
/ 4)
3416 /* Process first byte of a triplet. */
3418 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3419 value
= (0x03 & c
) << 4;
3421 /* Process second byte of a triplet. */
3425 *e
++ = base64_value_to_char
[value
];
3433 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3441 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3442 value
= (0x0f & c
) << 2;
3444 /* Process third byte of a triplet. */
3448 *e
++ = base64_value_to_char
[value
];
3455 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3463 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3464 *e
++ = base64_value_to_char
[0x3f & c
];
3471 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3473 "Base64-decode the region between BEG and END.\n\
3474 Return the length of the decoded text.\n\
3475 If the region can't be decoded, signal an error and don't modify the buffer.")
3477 Lisp_Object beg
, end
;
3479 int ibeg
, iend
, length
, allength
;
3484 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3486 validate_region (&beg
, &end
);
3488 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3489 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3491 length
= iend
- ibeg
;
3493 /* We need to allocate enough room for decoding the text. If we are
3494 working on a multibyte buffer, each decoded code may occupy at
3496 allength
= multibyte
? length
* 2 : length
;
3497 if (allength
<= MAX_ALLOCA
)
3498 decoded
= (char *) alloca (allength
);
3500 decoded
= (char *) xmalloc (allength
);
3502 move_gap_both (XFASTINT (beg
), ibeg
);
3503 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3504 multibyte
, &inserted_chars
);
3505 if (decoded_length
> allength
)
3508 if (decoded_length
< 0)
3510 /* The decoding wasn't possible. */
3511 if (allength
> MAX_ALLOCA
)
3513 error ("Invalid base64 data");
3516 /* Now we have decoded the region, so we insert the new contents
3517 and delete the old. (Insert first in order to preserve markers.) */
3518 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3519 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3520 if (allength
> MAX_ALLOCA
)
3522 /* Delete the original text. */
3523 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3524 iend
+ decoded_length
, 1);
3526 /* If point was outside of the region, restore it exactly; else just
3527 move to the beginning of the region. */
3528 if (old_pos
>= XFASTINT (end
))
3529 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3530 else if (old_pos
> XFASTINT (beg
))
3531 old_pos
= XFASTINT (beg
);
3532 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3534 return make_number (inserted_chars
);
3537 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3539 "Base64-decode STRING and return the result.")
3544 int length
, decoded_length
;
3545 Lisp_Object decoded_string
;
3547 CHECK_STRING (string
, 1);
3549 length
= STRING_BYTES (XSTRING (string
));
3550 /* We need to allocate enough room for decoding the text. */
3551 if (length
<= MAX_ALLOCA
)
3552 decoded
= (char *) alloca (length
);
3554 decoded
= (char *) xmalloc (length
);
3556 /* The decoded result should be unibyte. */
3557 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3559 if (decoded_length
> length
)
3561 else if (decoded_length
>= 0)
3562 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3564 decoded_string
= Qnil
;
3566 if (length
> MAX_ALLOCA
)
3568 if (!STRINGP (decoded_string
))
3569 error ("Invalid base64 data");
3571 return decoded_string
;
3574 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3575 MULTIBYTE is nonzero, the decoded result should be in multibyte
3576 form. If NCHARS_RETRUN is not NULL, store the number of produced
3577 characters in *NCHARS_RETURN. */
3580 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3590 unsigned long value
;
3595 /* Process first byte of a quadruplet. */
3597 READ_QUADRUPLET_BYTE (e
-to
);
3601 value
= base64_char_to_value
[c
] << 18;
3603 /* Process second byte of a quadruplet. */
3605 READ_QUADRUPLET_BYTE (-1);
3609 value
|= base64_char_to_value
[c
] << 12;
3611 c
= (unsigned char) (value
>> 16);
3613 e
+= CHAR_STRING (c
, e
);
3618 /* Process third byte of a quadruplet. */
3620 READ_QUADRUPLET_BYTE (-1);
3624 READ_QUADRUPLET_BYTE (-1);
3633 value
|= base64_char_to_value
[c
] << 6;
3635 c
= (unsigned char) (0xff & value
>> 8);
3637 e
+= CHAR_STRING (c
, e
);
3642 /* Process fourth byte of a quadruplet. */
3644 READ_QUADRUPLET_BYTE (-1);
3651 value
|= base64_char_to_value
[c
];
3653 c
= (unsigned char) (0xff & value
);
3655 e
+= CHAR_STRING (c
, e
);
3664 /***********************************************************************
3666 ***** Hash Tables *****
3668 ***********************************************************************/
3670 /* Implemented by gerd@gnu.org. This hash table implementation was
3671 inspired by CMUCL hash tables. */
3675 1. For small tables, association lists are probably faster than
3676 hash tables because they have lower overhead.
3678 For uses of hash tables where the O(1) behavior of table
3679 operations is not a requirement, it might therefore be a good idea
3680 not to hash. Instead, we could just do a linear search in the
3681 key_and_value vector of the hash table. This could be done
3682 if a `:linear-search t' argument is given to make-hash-table. */
3685 /* Value is the key part of entry IDX in hash table H. */
3687 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3689 /* Value is the value part of entry IDX in hash table H. */
3691 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3693 /* Value is the index of the next entry following the one at IDX
3696 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3698 /* Value is the hash code computed for entry IDX in hash table H. */
3700 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3702 /* Value is the index of the element in hash table H that is the
3703 start of the collision list at index IDX in the index vector of H. */
3705 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3707 /* Value is the size of hash table H. */
3709 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3711 /* The list of all weak hash tables. Don't staticpro this one. */
3713 Lisp_Object Vweak_hash_tables
;
3715 /* Various symbols. */
3717 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3718 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3719 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3721 /* Function prototypes. */
3723 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3724 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3725 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3726 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3727 Lisp_Object
, unsigned));
3728 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3729 Lisp_Object
, unsigned));
3730 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3731 unsigned, Lisp_Object
, unsigned));
3732 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3733 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3734 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3735 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3737 static unsigned sxhash_string
P_ ((unsigned char *, int));
3738 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3739 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3740 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3741 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3745 /***********************************************************************
3747 ***********************************************************************/
3749 /* If OBJ is a Lisp hash table, return a pointer to its struct
3750 Lisp_Hash_Table. Otherwise, signal an error. */
3752 static struct Lisp_Hash_Table
*
3753 check_hash_table (obj
)
3756 CHECK_HASH_TABLE (obj
, 0);
3757 return XHASH_TABLE (obj
);
3761 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3765 next_almost_prime (n
)
3778 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3779 which USED[I] is non-zero. If found at index I in ARGS, set
3780 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3781 -1. This function is used to extract a keyword/argument pair from
3782 a DEFUN parameter list. */
3785 get_key_arg (key
, nargs
, args
, used
)
3793 for (i
= 0; i
< nargs
- 1; ++i
)
3794 if (!used
[i
] && EQ (args
[i
], key
))
3809 /* Return a Lisp vector which has the same contents as VEC but has
3810 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3811 vector that are not copied from VEC are set to INIT. */
3814 larger_vector (vec
, new_size
, init
)
3819 struct Lisp_Vector
*v
;
3822 xassert (VECTORP (vec
));
3823 old_size
= XVECTOR (vec
)->size
;
3824 xassert (new_size
>= old_size
);
3826 v
= allocate_vectorlike (new_size
);
3828 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3829 old_size
* sizeof *v
->contents
);
3830 for (i
= old_size
; i
< new_size
; ++i
)
3831 v
->contents
[i
] = init
;
3832 XSETVECTOR (vec
, v
);
3837 /***********************************************************************
3839 ***********************************************************************/
3841 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3842 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3843 KEY2 are the same. */
3846 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3847 struct Lisp_Hash_Table
*h
;
3848 Lisp_Object key1
, key2
;
3849 unsigned hash1
, hash2
;
3851 return (FLOATP (key1
)
3853 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3857 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3858 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3859 KEY2 are the same. */
3862 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3863 struct Lisp_Hash_Table
*h
;
3864 Lisp_Object key1
, key2
;
3865 unsigned hash1
, hash2
;
3867 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3871 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3872 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3873 if KEY1 and KEY2 are the same. */
3876 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3877 struct Lisp_Hash_Table
*h
;
3878 Lisp_Object key1
, key2
;
3879 unsigned hash1
, hash2
;
3883 Lisp_Object args
[3];
3885 args
[0] = h
->user_cmp_function
;
3888 return !NILP (Ffuncall (3, args
));
3895 /* Value is a hash code for KEY for use in hash table H which uses
3896 `eq' to compare keys. The hash code returned is guaranteed to fit
3897 in a Lisp integer. */
3901 struct Lisp_Hash_Table
*h
;
3904 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3905 xassert ((hash
& ~VALMASK
) == 0);
3910 /* Value is a hash code for KEY for use in hash table H which uses
3911 `eql' to compare keys. The hash code returned is guaranteed to fit
3912 in a Lisp integer. */
3916 struct Lisp_Hash_Table
*h
;
3921 hash
= sxhash (key
, 0);
3923 hash
= XUINT (key
) ^ XGCTYPE (key
);
3924 xassert ((hash
& ~VALMASK
) == 0);
3929 /* Value is a hash code for KEY for use in hash table H which uses
3930 `equal' to compare keys. The hash code returned is guaranteed to fit
3931 in a Lisp integer. */
3934 hashfn_equal (h
, key
)
3935 struct Lisp_Hash_Table
*h
;
3938 unsigned hash
= sxhash (key
, 0);
3939 xassert ((hash
& ~VALMASK
) == 0);
3944 /* Value is a hash code for KEY for use in hash table H which uses as
3945 user-defined function to compare keys. The hash code returned is
3946 guaranteed to fit in a Lisp integer. */
3949 hashfn_user_defined (h
, key
)
3950 struct Lisp_Hash_Table
*h
;
3953 Lisp_Object args
[2], hash
;
3955 args
[0] = h
->user_hash_function
;
3957 hash
= Ffuncall (2, args
);
3958 if (!INTEGERP (hash
))
3960 list2 (build_string ("Invalid hash code returned from \
3961 user-supplied hash function"),
3963 return XUINT (hash
);
3967 /* Create and initialize a new hash table.
3969 TEST specifies the test the hash table will use to compare keys.
3970 It must be either one of the predefined tests `eq', `eql' or
3971 `equal' or a symbol denoting a user-defined test named TEST with
3972 test and hash functions USER_TEST and USER_HASH.
3974 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3976 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3977 new size when it becomes full is computed by adding REHASH_SIZE to
3978 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3979 table's new size is computed by multiplying its old size with
3982 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3983 be resized when the ratio of (number of entries in the table) /
3984 (table size) is >= REHASH_THRESHOLD.
3986 WEAK specifies the weakness of the table. If non-nil, it must be
3987 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3990 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3991 user_test
, user_hash
)
3992 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3993 Lisp_Object user_test
, user_hash
;
3995 struct Lisp_Hash_Table
*h
;
3996 struct Lisp_Vector
*v
;
3998 int index_size
, i
, len
, sz
;
4000 /* Preconditions. */
4001 xassert (SYMBOLP (test
));
4002 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4003 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4004 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4005 xassert (FLOATP (rehash_threshold
)
4006 && XFLOATINT (rehash_threshold
) > 0
4007 && XFLOATINT (rehash_threshold
) <= 1.0);
4009 if (XFASTINT (size
) == 0)
4010 size
= make_number (1);
4012 /* Allocate a vector, and initialize it. */
4013 len
= VECSIZE (struct Lisp_Hash_Table
);
4014 v
= allocate_vectorlike (len
);
4016 for (i
= 0; i
< len
; ++i
)
4017 v
->contents
[i
] = Qnil
;
4019 /* Initialize hash table slots. */
4020 sz
= XFASTINT (size
);
4021 h
= (struct Lisp_Hash_Table
*) v
;
4024 if (EQ (test
, Qeql
))
4026 h
->cmpfn
= cmpfn_eql
;
4027 h
->hashfn
= hashfn_eql
;
4029 else if (EQ (test
, Qeq
))
4032 h
->hashfn
= hashfn_eq
;
4034 else if (EQ (test
, Qequal
))
4036 h
->cmpfn
= cmpfn_equal
;
4037 h
->hashfn
= hashfn_equal
;
4041 h
->user_cmp_function
= user_test
;
4042 h
->user_hash_function
= user_hash
;
4043 h
->cmpfn
= cmpfn_user_defined
;
4044 h
->hashfn
= hashfn_user_defined
;
4048 h
->rehash_threshold
= rehash_threshold
;
4049 h
->rehash_size
= rehash_size
;
4050 h
->count
= make_number (0);
4051 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4052 h
->hash
= Fmake_vector (size
, Qnil
);
4053 h
->next
= Fmake_vector (size
, Qnil
);
4054 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4055 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4056 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4058 /* Set up the free list. */
4059 for (i
= 0; i
< sz
- 1; ++i
)
4060 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4061 h
->next_free
= make_number (0);
4063 XSET_HASH_TABLE (table
, h
);
4064 xassert (HASH_TABLE_P (table
));
4065 xassert (XHASH_TABLE (table
) == h
);
4067 /* Maybe add this hash table to the list of all weak hash tables. */
4069 h
->next_weak
= Qnil
;
4072 h
->next_weak
= Vweak_hash_tables
;
4073 Vweak_hash_tables
= table
;
4080 /* Return a copy of hash table H1. Keys and values are not copied,
4081 only the table itself is. */
4084 copy_hash_table (h1
)
4085 struct Lisp_Hash_Table
*h1
;
4088 struct Lisp_Hash_Table
*h2
;
4089 struct Lisp_Vector
*v
, *next
;
4092 len
= VECSIZE (struct Lisp_Hash_Table
);
4093 v
= allocate_vectorlike (len
);
4094 h2
= (struct Lisp_Hash_Table
*) v
;
4095 next
= h2
->vec_next
;
4096 bcopy (h1
, h2
, sizeof *h2
);
4097 h2
->vec_next
= next
;
4098 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4099 h2
->hash
= Fcopy_sequence (h1
->hash
);
4100 h2
->next
= Fcopy_sequence (h1
->next
);
4101 h2
->index
= Fcopy_sequence (h1
->index
);
4102 XSET_HASH_TABLE (table
, h2
);
4104 /* Maybe add this hash table to the list of all weak hash tables. */
4105 if (!NILP (h2
->weak
))
4107 h2
->next_weak
= Vweak_hash_tables
;
4108 Vweak_hash_tables
= table
;
4115 /* Resize hash table H if it's too full. If H cannot be resized
4116 because it's already too large, throw an error. */
4119 maybe_resize_hash_table (h
)
4120 struct Lisp_Hash_Table
*h
;
4122 if (NILP (h
->next_free
))
4124 int old_size
= HASH_TABLE_SIZE (h
);
4125 int i
, new_size
, index_size
;
4127 if (INTEGERP (h
->rehash_size
))
4128 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4130 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4131 new_size
= max (old_size
+ 1, new_size
);
4132 index_size
= next_almost_prime ((int)
4134 / XFLOATINT (h
->rehash_threshold
)));
4135 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4136 error ("Hash table too large to resize");
4138 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4139 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4140 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4141 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4143 /* Update the free list. Do it so that new entries are added at
4144 the end of the free list. This makes some operations like
4146 for (i
= old_size
; i
< new_size
- 1; ++i
)
4147 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4149 if (!NILP (h
->next_free
))
4151 Lisp_Object last
, next
;
4153 last
= h
->next_free
;
4154 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4158 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4161 XSETFASTINT (h
->next_free
, old_size
);
4164 for (i
= 0; i
< old_size
; ++i
)
4165 if (!NILP (HASH_HASH (h
, i
)))
4167 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4168 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4169 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4170 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4176 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4177 the hash code of KEY. Value is the index of the entry in H
4178 matching KEY, or -1 if not found. */
4181 hash_lookup (h
, key
, hash
)
4182 struct Lisp_Hash_Table
*h
;
4187 int start_of_bucket
;
4190 hash_code
= h
->hashfn (h
, key
);
4194 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4195 idx
= HASH_INDEX (h
, start_of_bucket
);
4197 /* We need not gcpro idx since it's either an integer or nil. */
4200 int i
= XFASTINT (idx
);
4201 if (EQ (key
, HASH_KEY (h
, i
))
4203 && h
->cmpfn (h
, key
, hash_code
,
4204 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4206 idx
= HASH_NEXT (h
, i
);
4209 return NILP (idx
) ? -1 : XFASTINT (idx
);
4213 /* Put an entry into hash table H that associates KEY with VALUE.
4214 HASH is a previously computed hash code of KEY.
4215 Value is the index of the entry in H matching KEY. */
4218 hash_put (h
, key
, value
, hash
)
4219 struct Lisp_Hash_Table
*h
;
4220 Lisp_Object key
, value
;
4223 int start_of_bucket
, i
;
4225 xassert ((hash
& ~VALMASK
) == 0);
4227 /* Increment count after resizing because resizing may fail. */
4228 maybe_resize_hash_table (h
);
4229 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4231 /* Store key/value in the key_and_value vector. */
4232 i
= XFASTINT (h
->next_free
);
4233 h
->next_free
= HASH_NEXT (h
, i
);
4234 HASH_KEY (h
, i
) = key
;
4235 HASH_VALUE (h
, i
) = value
;
4237 /* Remember its hash code. */
4238 HASH_HASH (h
, i
) = make_number (hash
);
4240 /* Add new entry to its collision chain. */
4241 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4242 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4243 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4248 /* Remove the entry matching KEY from hash table H, if there is one. */
4251 hash_remove (h
, key
)
4252 struct Lisp_Hash_Table
*h
;
4256 int start_of_bucket
;
4257 Lisp_Object idx
, prev
;
4259 hash_code
= h
->hashfn (h
, key
);
4260 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4261 idx
= HASH_INDEX (h
, start_of_bucket
);
4264 /* We need not gcpro idx, prev since they're either integers or nil. */
4267 int i
= XFASTINT (idx
);
4269 if (EQ (key
, HASH_KEY (h
, i
))
4271 && h
->cmpfn (h
, key
, hash_code
,
4272 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4274 /* Take entry out of collision chain. */
4276 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4278 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4280 /* Clear slots in key_and_value and add the slots to
4282 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4283 HASH_NEXT (h
, i
) = h
->next_free
;
4284 h
->next_free
= make_number (i
);
4285 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4286 xassert (XINT (h
->count
) >= 0);
4292 idx
= HASH_NEXT (h
, i
);
4298 /* Clear hash table H. */
4302 struct Lisp_Hash_Table
*h
;
4304 if (XFASTINT (h
->count
) > 0)
4306 int i
, size
= HASH_TABLE_SIZE (h
);
4308 for (i
= 0; i
< size
; ++i
)
4310 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4311 HASH_KEY (h
, i
) = Qnil
;
4312 HASH_VALUE (h
, i
) = Qnil
;
4313 HASH_HASH (h
, i
) = Qnil
;
4316 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4317 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4319 h
->next_free
= make_number (0);
4320 h
->count
= make_number (0);
4326 /************************************************************************
4328 ************************************************************************/
4330 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4331 entries from the table that don't survive the current GC.
4332 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4333 non-zero if anything was marked. */
4336 sweep_weak_table (h
, remove_entries_p
)
4337 struct Lisp_Hash_Table
*h
;
4338 int remove_entries_p
;
4340 int bucket
, n
, marked
;
4342 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4345 for (bucket
= 0; bucket
< n
; ++bucket
)
4347 Lisp_Object idx
, prev
;
4349 /* Follow collision chain, removing entries that
4350 don't survive this garbage collection. */
4351 idx
= HASH_INDEX (h
, bucket
);
4353 while (!GC_NILP (idx
))
4356 int i
= XFASTINT (idx
);
4358 int key_known_to_survive_p
, value_known_to_survive_p
;
4360 key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4361 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
, i
) = 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
));
4423 /* Remove elements from weak hash tables that don't survive the
4424 current garbage collection. Remove weak tables that don't survive
4425 from Vweak_hash_tables. Called from gc_sweep. */
4428 sweep_weak_hash_tables ()
4430 Lisp_Object table
, used
, next
;
4431 struct Lisp_Hash_Table
*h
;
4434 /* Mark all keys and values that are in use. Keep on marking until
4435 there is no more change. This is necessary for cases like
4436 value-weak table A containing an entry X -> Y, where Y is used in a
4437 key-weak table B, Z -> Y. If B comes after A in the list of weak
4438 tables, X -> Y might be removed from A, although when looking at B
4439 one finds that it shouldn't. */
4443 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4445 h
= XHASH_TABLE (table
);
4446 if (h
->size
& ARRAY_MARK_FLAG
)
4447 marked
|= sweep_weak_table (h
, 0);
4452 /* Remove tables and entries that aren't used. */
4453 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4455 h
= XHASH_TABLE (table
);
4456 next
= h
->next_weak
;
4458 if (h
->size
& ARRAY_MARK_FLAG
)
4460 /* TABLE is marked as used. Sweep its contents. */
4461 if (XFASTINT (h
->count
) > 0)
4462 sweep_weak_table (h
, 1);
4464 /* Add table to the list of used weak hash tables. */
4465 h
->next_weak
= used
;
4470 Vweak_hash_tables
= used
;
4475 /***********************************************************************
4476 Hash Code Computation
4477 ***********************************************************************/
4479 /* Maximum depth up to which to dive into Lisp structures. */
4481 #define SXHASH_MAX_DEPTH 3
4483 /* Maximum length up to which to take list and vector elements into
4486 #define SXHASH_MAX_LEN 7
4488 /* Combine two integers X and Y for hashing. */
4490 #define SXHASH_COMBINE(X, Y) \
4491 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4495 /* Return a hash for string PTR which has length LEN. The hash
4496 code returned is guaranteed to fit in a Lisp integer. */
4499 sxhash_string (ptr
, len
)
4503 unsigned char *p
= ptr
;
4504 unsigned char *end
= p
+ len
;
4513 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4516 return hash
& VALMASK
;
4520 /* Return a hash for list LIST. DEPTH is the current depth in the
4521 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4524 sxhash_list (list
, depth
)
4531 if (depth
< SXHASH_MAX_DEPTH
)
4533 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4534 list
= XCDR (list
), ++i
)
4536 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4537 hash
= SXHASH_COMBINE (hash
, hash2
);
4544 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4545 the Lisp structure. */
4548 sxhash_vector (vec
, depth
)
4552 unsigned hash
= XVECTOR (vec
)->size
;
4555 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4556 for (i
= 0; i
< n
; ++i
)
4558 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4559 hash
= SXHASH_COMBINE (hash
, hash2
);
4566 /* Return a hash for bool-vector VECTOR. */
4569 sxhash_bool_vector (vec
)
4572 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4575 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4576 for (i
= 0; i
< n
; ++i
)
4577 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4583 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4584 structure. Value is an unsigned integer clipped to VALMASK. */
4593 if (depth
> SXHASH_MAX_DEPTH
)
4596 switch (XTYPE (obj
))
4603 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4604 XSYMBOL (obj
)->name
->size
);
4612 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4615 /* This can be everything from a vector to an overlay. */
4616 case Lisp_Vectorlike
:
4618 /* According to the CL HyperSpec, two arrays are equal only if
4619 they are `eq', except for strings and bit-vectors. In
4620 Emacs, this works differently. We have to compare element
4622 hash
= sxhash_vector (obj
, depth
);
4623 else if (BOOL_VECTOR_P (obj
))
4624 hash
= sxhash_bool_vector (obj
);
4626 /* Others are `equal' if they are `eq', so let's take their
4632 hash
= sxhash_list (obj
, depth
);
4637 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4638 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4639 for (hash
= 0; p
< e
; ++p
)
4640 hash
= SXHASH_COMBINE (hash
, *p
);
4648 return hash
& VALMASK
;
4653 /***********************************************************************
4655 ***********************************************************************/
4658 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4659 "Compute a hash code for OBJ and return it as integer.")
4663 unsigned hash
= sxhash (obj
, 0);;
4664 return make_number (hash
);
4668 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4669 "Create and return a new hash table.\n\
4670 Arguments are specified as keyword/argument pairs. The following\n\
4671 arguments are defined:\n\
4673 :test TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4674 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4675 User-supplied test and hash functions can be specified via\n\
4676 `define-hash-table-test'.\n\
4678 :size SIZE -- A hint as to how many elements will be put in the table.\n\
4681 :rehash-size REHASH-SIZE - Indicates how to expand the table when\n\
4682 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4683 If it is a float, it must be > 1.0, and the new size is computed by\n\
4684 multiplying the old size with that factor. Default is 1.5.\n\
4686 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4687 Resize the hash table when ratio of the number of entries in the table.\n\
4690 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',\n\
4691 `key-or-value', or `key-and-value'. If WEAK is not nil, the table returned\n\
4692 is a weak table. Key/value pairs are removed from a weak hash table when\n\
4693 there are no non-weak references pointing to their key, value, one of key\n\
4694 or value, or both key and value, depending on WEAK. WEAK t is equivalent\n\
4695 to `key-and-value'. Default value of WEAK is nil.")
4700 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4701 Lisp_Object user_test
, user_hash
;
4705 /* The vector `used' is used to keep track of arguments that
4706 have been consumed. */
4707 used
= (char *) alloca (nargs
* sizeof *used
);
4708 bzero (used
, nargs
* sizeof *used
);
4710 /* See if there's a `:test TEST' among the arguments. */
4711 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4712 test
= i
< 0 ? Qeql
: args
[i
];
4713 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4715 /* See if it is a user-defined test. */
4718 prop
= Fget (test
, Qhash_table_test
);
4719 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4720 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4722 user_test
= Fnth (make_number (0), prop
);
4723 user_hash
= Fnth (make_number (1), prop
);
4726 user_test
= user_hash
= Qnil
;
4728 /* See if there's a `:size SIZE' argument. */
4729 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4730 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4731 if (!INTEGERP (size
) || XINT (size
) < 0)
4733 list2 (build_string ("Invalid hash table size"),
4736 /* Look for `:rehash-size SIZE'. */
4737 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4738 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4739 if (!NUMBERP (rehash_size
)
4740 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4741 || XFLOATINT (rehash_size
) <= 1.0)
4743 list2 (build_string ("Invalid hash table rehash size"),
4746 /* Look for `:rehash-threshold THRESHOLD'. */
4747 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4748 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4749 if (!FLOATP (rehash_threshold
)
4750 || XFLOATINT (rehash_threshold
) <= 0.0
4751 || XFLOATINT (rehash_threshold
) > 1.0)
4753 list2 (build_string ("Invalid hash table rehash threshold"),
4756 /* Look for `:weakness WEAK'. */
4757 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4758 weak
= i
< 0 ? Qnil
: args
[i
];
4760 weak
= Qkey_and_value
;
4763 && !EQ (weak
, Qvalue
)
4764 && !EQ (weak
, Qkey_or_value
)
4765 && !EQ (weak
, Qkey_and_value
))
4766 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4769 /* Now, all args should have been used up, or there's a problem. */
4770 for (i
= 0; i
< nargs
; ++i
)
4773 list2 (build_string ("Invalid argument list"), args
[i
]));
4775 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4776 user_test
, user_hash
);
4780 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4781 "Return a copy of hash table TABLE.")
4785 return copy_hash_table (check_hash_table (table
));
4789 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4790 "Create a new hash table.\n\
4791 Optional first argument TEST specifies how to compare keys in\n\
4792 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4793 is `eql'. New tests can be defined with `define-hash-table-test'.")
4797 Lisp_Object args
[2];
4799 args
[1] = NILP (test
) ? Qeql
: test
;
4800 return Fmake_hash_table (2, args
);
4804 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4805 "Return the number of elements in TABLE.")
4809 return check_hash_table (table
)->count
;
4813 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4814 Shash_table_rehash_size
, 1, 1, 0,
4815 "Return the current rehash size of TABLE.")
4819 return check_hash_table (table
)->rehash_size
;
4823 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4824 Shash_table_rehash_threshold
, 1, 1, 0,
4825 "Return the current rehash threshold of TABLE.")
4829 return check_hash_table (table
)->rehash_threshold
;
4833 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4834 "Return the size of TABLE.\n\
4835 The size can be used as an argument to `make-hash-table' to create\n\
4836 a hash table than can hold as many elements of TABLE holds\n\
4837 without need for resizing.")
4841 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4842 return make_number (HASH_TABLE_SIZE (h
));
4846 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4847 "Return the test TABLE uses.")
4851 return check_hash_table (table
)->test
;
4855 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4857 "Return the weakness of TABLE.")
4861 return check_hash_table (table
)->weak
;
4865 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4866 "Return t if OBJ is a Lisp hash table object.")
4870 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4874 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4875 "Clear hash table TABLE.")
4879 hash_clear (check_hash_table (table
));
4884 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4885 "Look up KEY in TABLE and return its associated value.\n\
4886 If KEY is not found, return DFLT which defaults to nil.")
4888 Lisp_Object key
, table
, dflt
;
4890 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4891 int i
= hash_lookup (h
, key
, NULL
);
4892 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4896 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4897 "Associate KEY with VALUE in hash table TABLE.\n\
4898 If KEY is already present in table, replace its current value with\n\
4901 Lisp_Object key
, value
, table
;
4903 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4907 i
= hash_lookup (h
, key
, &hash
);
4909 HASH_VALUE (h
, i
) = value
;
4911 hash_put (h
, key
, value
, hash
);
4917 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4918 "Remove KEY from TABLE.")
4920 Lisp_Object key
, table
;
4922 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4923 hash_remove (h
, key
);
4928 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4929 "Call FUNCTION for all entries in hash table TABLE.\n\
4930 FUNCTION is called with 2 arguments KEY and VALUE.")
4932 Lisp_Object function
, table
;
4934 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4935 Lisp_Object args
[3];
4938 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4939 if (!NILP (HASH_HASH (h
, i
)))
4942 args
[1] = HASH_KEY (h
, i
);
4943 args
[2] = HASH_VALUE (h
, i
);
4951 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4952 Sdefine_hash_table_test
, 3, 3, 0,
4953 "Define a new hash table test with name NAME, a symbol.\n\
4954 In hash tables create with NAME specified as test, use TEST to compare\n\
4955 keys, and HASH for computing hash codes of keys.\n\
4957 TEST must be a function taking two arguments and returning non-nil\n\
4958 if both arguments are the same. HASH must be a function taking\n\
4959 one argument and return an integer that is the hash code of the\n\
4960 argument. Hash code computation should use the whole value range of\n\
4961 integers, including negative integers.")
4963 Lisp_Object name
, test
, hash
;
4965 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4970 /************************************************************************
4972 ************************************************************************/
4977 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4978 "Return MD5 message digest of OBJECT, a buffer or string.\n\
4979 A message digest is a cryptographic checksum of a document,\n\
4980 and the algorithm to calculate it is defined in RFC 1321.\n\
4982 The two optional arguments START and END are character positions\n\
4983 specifying for which part of OBJECT the message digest should be computed.\n\
4984 If nil or omitted, the digest is computed for the whole OBJECT.\n\
4986 The MD5 message digest is computed from the result of encoding the\n\
4987 text in a coding system, not directly from the internal Emacs form\n\
4988 of the text. The optional fourth argument CODING-SYSTEM specifies\n\
4989 which coding system to encode the text with. It should be the same\n\
4990 coding system that you used or will use when actually writing the text\n\
4993 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT.\n\
4994 If OBJECT is a buffer, the default for CODING-SYSTEM is whatever\n\
4995 coding system would be chosen by default for writing this text\n\
4998 If OBJECT is a string, the most preferred coding system (see the\n\
4999 command `prefer-coding-system') is used.\n\
5001 The optional fifth argument NOERROR exists for compatibility with\n\
5002 other Emacs versions, and is ignored.")
5003 (object
, start
, end
, coding_system
, noerror
)
5004 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5006 unsigned char digest
[16];
5007 unsigned char value
[33];
5011 int start_char
= 0, end_char
= 0;
5012 int start_byte
= 0, end_byte
= 0;
5014 register struct buffer
*bp
;
5017 if (STRINGP (object
))
5019 if (NILP (coding_system
))
5021 /* Decide the coding-system to encode the data with. */
5023 if (STRING_MULTIBYTE (object
))
5024 /* use default, we can't guess correct value */
5025 coding_system
= XSYMBOL (XCAR (Vcoding_category_list
))->value
;
5027 coding_system
= Qraw_text
;
5030 if (NILP (Fcoding_system_p (coding_system
)))
5032 /* Invalid coding system. */
5034 if (!NILP (noerror
))
5035 coding_system
= Qraw_text
;
5038 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5041 if (STRING_MULTIBYTE (object
))
5042 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5044 size
= XSTRING (object
)->size
;
5045 size_byte
= STRING_BYTES (XSTRING (object
));
5049 CHECK_NUMBER (start
, 1);
5051 start_char
= XINT (start
);
5056 start_byte
= string_char_to_byte (object
, start_char
);
5062 end_byte
= size_byte
;
5066 CHECK_NUMBER (end
, 2);
5068 end_char
= XINT (end
);
5073 end_byte
= string_char_to_byte (object
, end_char
);
5076 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5077 args_out_of_range_3 (object
, make_number (start_char
),
5078 make_number (end_char
));
5082 CHECK_BUFFER (object
, 0);
5084 bp
= XBUFFER (object
);
5090 CHECK_NUMBER_COERCE_MARKER (start
, 0);
5098 CHECK_NUMBER_COERCE_MARKER (end
, 1);
5103 temp
= b
, b
= e
, e
= temp
;
5105 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5106 args_out_of_range (start
, end
);
5108 if (NILP (coding_system
))
5110 /* Decide the coding-system to encode the data with.
5111 See fileio.c:Fwrite-region */
5113 if (!NILP (Vcoding_system_for_write
))
5114 coding_system
= Vcoding_system_for_write
;
5117 int force_raw_text
= 0;
5119 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5120 if (NILP (coding_system
)
5121 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5123 coding_system
= Qnil
;
5124 if (NILP (current_buffer
->enable_multibyte_characters
))
5128 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5130 /* Check file-coding-system-alist. */
5131 Lisp_Object args
[4], val
;
5133 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5134 args
[3] = Fbuffer_file_name(object
);
5135 val
= Ffind_operation_coding_system (4, args
);
5136 if (CONSP (val
) && !NILP (XCDR (val
)))
5137 coding_system
= XCDR (val
);
5140 if (NILP (coding_system
)
5141 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5143 /* If we still have not decided a coding system, use the
5144 default value of buffer-file-coding-system. */
5145 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5149 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5150 /* Confirm that VAL can surely encode the current region. */
5151 coding_system
= call3 (Vselect_safe_coding_system_function
,
5152 make_number (b
), make_number (e
),
5156 coding_system
= Qraw_text
;
5159 if (NILP (Fcoding_system_p (coding_system
)))
5161 /* Invalid coding system. */
5163 if (!NILP (noerror
))
5164 coding_system
= Qraw_text
;
5167 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5171 object
= make_buffer_string (b
, e
, 0);
5173 if (STRING_MULTIBYTE (object
))
5174 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5177 md5_buffer (XSTRING (object
)->data
+ start_byte
,
5178 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
5181 for (i
= 0; i
< 16; i
++)
5182 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5185 return make_string (value
, 32);
5192 /* Hash table stuff. */
5193 Qhash_table_p
= intern ("hash-table-p");
5194 staticpro (&Qhash_table_p
);
5195 Qeq
= intern ("eq");
5197 Qeql
= intern ("eql");
5199 Qequal
= intern ("equal");
5200 staticpro (&Qequal
);
5201 QCtest
= intern (":test");
5202 staticpro (&QCtest
);
5203 QCsize
= intern (":size");
5204 staticpro (&QCsize
);
5205 QCrehash_size
= intern (":rehash-size");
5206 staticpro (&QCrehash_size
);
5207 QCrehash_threshold
= intern (":rehash-threshold");
5208 staticpro (&QCrehash_threshold
);
5209 QCweakness
= intern (":weakness");
5210 staticpro (&QCweakness
);
5211 Qkey
= intern ("key");
5213 Qvalue
= intern ("value");
5214 staticpro (&Qvalue
);
5215 Qhash_table_test
= intern ("hash-table-test");
5216 staticpro (&Qhash_table_test
);
5217 Qkey_or_value
= intern ("key-or-value");
5218 staticpro (&Qkey_or_value
);
5219 Qkey_and_value
= intern ("key-and-value");
5220 staticpro (&Qkey_and_value
);
5223 defsubr (&Smake_hash_table
);
5224 defsubr (&Scopy_hash_table
);
5225 defsubr (&Smakehash
);
5226 defsubr (&Shash_table_count
);
5227 defsubr (&Shash_table_rehash_size
);
5228 defsubr (&Shash_table_rehash_threshold
);
5229 defsubr (&Shash_table_size
);
5230 defsubr (&Shash_table_test
);
5231 defsubr (&Shash_table_weakness
);
5232 defsubr (&Shash_table_p
);
5233 defsubr (&Sclrhash
);
5234 defsubr (&Sgethash
);
5235 defsubr (&Sputhash
);
5236 defsubr (&Sremhash
);
5237 defsubr (&Smaphash
);
5238 defsubr (&Sdefine_hash_table_test
);
5240 Qstring_lessp
= intern ("string-lessp");
5241 staticpro (&Qstring_lessp
);
5242 Qprovide
= intern ("provide");
5243 staticpro (&Qprovide
);
5244 Qrequire
= intern ("require");
5245 staticpro (&Qrequire
);
5246 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5247 staticpro (&Qyes_or_no_p_history
);
5248 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5249 staticpro (&Qcursor_in_echo_area
);
5250 Qwidget_type
= intern ("widget-type");
5251 staticpro (&Qwidget_type
);
5253 staticpro (&string_char_byte_cache_string
);
5254 string_char_byte_cache_string
= Qnil
;
5256 Fset (Qyes_or_no_p_history
, Qnil
);
5258 DEFVAR_LISP ("features", &Vfeatures
,
5259 "A list of symbols which are the features of the executing emacs.\n\
5260 Used by `featurep' and `require', and altered by `provide'.");
5263 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5264 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
5265 This applies to y-or-n and yes-or-no questions asked by commands\n\
5266 invoked by mouse clicks and mouse menu items.");
5269 defsubr (&Sidentity
);
5272 defsubr (&Ssafe_length
);
5273 defsubr (&Sstring_bytes
);
5274 defsubr (&Sstring_equal
);
5275 defsubr (&Scompare_strings
);
5276 defsubr (&Sstring_lessp
);
5279 defsubr (&Svconcat
);
5280 defsubr (&Scopy_sequence
);
5281 defsubr (&Sstring_make_multibyte
);
5282 defsubr (&Sstring_make_unibyte
);
5283 defsubr (&Sstring_as_multibyte
);
5284 defsubr (&Sstring_as_unibyte
);
5285 defsubr (&Scopy_alist
);
5286 defsubr (&Ssubstring
);
5298 defsubr (&Snreverse
);
5299 defsubr (&Sreverse
);
5301 defsubr (&Splist_get
);
5303 defsubr (&Splist_put
);
5306 defsubr (&Sfillarray
);
5307 defsubr (&Schar_table_subtype
);
5308 defsubr (&Schar_table_parent
);
5309 defsubr (&Sset_char_table_parent
);
5310 defsubr (&Schar_table_extra_slot
);
5311 defsubr (&Sset_char_table_extra_slot
);
5312 defsubr (&Schar_table_range
);
5313 defsubr (&Sset_char_table_range
);
5314 defsubr (&Sset_char_table_default
);
5315 defsubr (&Soptimize_char_table
);
5316 defsubr (&Smap_char_table
);
5320 defsubr (&Smapconcat
);
5321 defsubr (&Sy_or_n_p
);
5322 defsubr (&Syes_or_no_p
);
5323 defsubr (&Sload_average
);
5324 defsubr (&Sfeaturep
);
5325 defsubr (&Srequire
);
5326 defsubr (&Sprovide
);
5327 defsubr (&Splist_member
);
5328 defsubr (&Swidget_put
);
5329 defsubr (&Swidget_get
);
5330 defsubr (&Swidget_apply
);
5331 defsubr (&Sbase64_encode_region
);
5332 defsubr (&Sbase64_decode_region
);
5333 defsubr (&Sbase64_encode_string
);
5334 defsubr (&Sbase64_decode_string
);
5342 Vweak_hash_tables
= Qnil
;