1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
41 #include "intervals.h"
44 #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_vector (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
);
1627 XSETVECTOR (seq
, p
);
1630 else if (STRINGP (seq
))
1632 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1635 for (i
= nchars
= nbytes
= ibyte
= 0;
1636 i
< XSTRING (seq
)->size
;
1637 ++i
, ibyte
+= cbytes
)
1639 if (STRING_MULTIBYTE (seq
))
1641 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1642 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1643 cbytes
= CHAR_BYTES (c
);
1647 c
= XSTRING (seq
)->data
[i
];
1651 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1658 if (nchars
!= XSTRING (seq
)->size
)
1662 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1663 if (!STRING_MULTIBYTE (seq
))
1664 SET_STRING_BYTES (XSTRING (tem
), -1);
1666 for (i
= nchars
= nbytes
= ibyte
= 0;
1667 i
< XSTRING (seq
)->size
;
1668 ++i
, ibyte
+= cbytes
)
1670 if (STRING_MULTIBYTE (seq
))
1672 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1673 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1674 cbytes
= CHAR_BYTES (c
);
1678 c
= XSTRING (seq
)->data
[i
];
1682 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1684 unsigned char *from
= &XSTRING (seq
)->data
[ibyte
];
1685 unsigned char *to
= &XSTRING (tem
)->data
[nbytes
];
1691 for (n
= cbytes
; n
--; )
1701 Lisp_Object tail
, prev
;
1703 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1706 wrong_type_argument (Qlistp
, seq
);
1708 if (!NILP (Fequal (elt
, XCAR (tail
))))
1713 Fsetcdr (prev
, XCDR (tail
));
1724 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1725 "Reverse LIST by modifying cdr pointers.\n\
1726 Returns the beginning of the reversed list.")
1730 register Lisp_Object prev
, tail
, next
;
1732 if (NILP (list
)) return list
;
1735 while (!NILP (tail
))
1739 wrong_type_argument (Qlistp
, list
);
1741 Fsetcdr (tail
, prev
);
1748 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1749 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1750 See also the function `nreverse', which is used more often.")
1756 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1757 new = Fcons (XCAR (list
), new);
1759 wrong_type_argument (Qconsp
, list
);
1763 Lisp_Object
merge ();
1765 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1766 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1767 Returns the sorted list. LIST is modified by side effects.\n\
1768 PREDICATE is called with two elements of LIST, and should return T\n\
1769 if the first element is \"less\" than the second.")
1771 Lisp_Object list
, predicate
;
1773 Lisp_Object front
, back
;
1774 register Lisp_Object len
, tem
;
1775 struct gcpro gcpro1
, gcpro2
;
1776 register int length
;
1779 len
= Flength (list
);
1780 length
= XINT (len
);
1784 XSETINT (len
, (length
/ 2) - 1);
1785 tem
= Fnthcdr (len
, list
);
1787 Fsetcdr (tem
, Qnil
);
1789 GCPRO2 (front
, back
);
1790 front
= Fsort (front
, predicate
);
1791 back
= Fsort (back
, predicate
);
1793 return merge (front
, back
, predicate
);
1797 merge (org_l1
, org_l2
, pred
)
1798 Lisp_Object org_l1
, org_l2
;
1802 register Lisp_Object tail
;
1804 register Lisp_Object l1
, l2
;
1805 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1812 /* It is sufficient to protect org_l1 and org_l2.
1813 When l1 and l2 are updated, we copy the new values
1814 back into the org_ vars. */
1815 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1835 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1851 Fsetcdr (tail
, tem
);
1857 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1858 "Extract a value from a property list.\n\
1859 PLIST is a property list, which is a list of the form\n\
1860 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1861 corresponding to the given PROP, or nil if PROP is not\n\
1862 one of the properties on the list.")
1865 register Lisp_Object prop
;
1867 register Lisp_Object tail
;
1868 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCDR (tail
)))
1870 register Lisp_Object tem
;
1873 return Fcar (XCDR (tail
));
1878 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1879 "Return the value of SYMBOL's PROPNAME property.\n\
1880 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1882 Lisp_Object symbol
, propname
;
1884 CHECK_SYMBOL (symbol
, 0);
1885 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1888 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1889 "Change value in PLIST of PROP to VAL.\n\
1890 PLIST is a property list, which is a list of the form\n\
1891 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1892 If PROP is already a property on the list, its value is set to VAL,\n\
1893 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1894 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1895 The PLIST is modified by side effects.")
1898 register Lisp_Object prop
;
1901 register Lisp_Object tail
, prev
;
1902 Lisp_Object newcell
;
1904 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1905 tail
= XCDR (XCDR (tail
)))
1907 if (EQ (prop
, XCAR (tail
)))
1909 Fsetcar (XCDR (tail
), val
);
1914 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1918 Fsetcdr (XCDR (prev
), newcell
);
1922 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1923 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1924 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1925 (symbol
, propname
, value
)
1926 Lisp_Object symbol
, propname
, value
;
1928 CHECK_SYMBOL (symbol
, 0);
1929 XSYMBOL (symbol
)->plist
1930 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1934 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1935 "Return t if two Lisp objects have similar structure and contents.\n\
1936 They must have the same data type.\n\
1937 Conses are compared by comparing the cars and the cdrs.\n\
1938 Vectors and strings are compared element by element.\n\
1939 Numbers are compared by value, but integers cannot equal floats.\n\
1940 (Use `=' if you want integers and floats to be able to be equal.)\n\
1941 Symbols must match exactly.")
1943 register Lisp_Object o1
, o2
;
1945 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1949 internal_equal (o1
, o2
, depth
)
1950 register Lisp_Object o1
, o2
;
1954 error ("Stack overflow in equal");
1960 if (XTYPE (o1
) != XTYPE (o2
))
1966 return (extract_float (o1
) == extract_float (o2
));
1969 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1976 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1980 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1982 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1985 o1
= XOVERLAY (o1
)->plist
;
1986 o2
= XOVERLAY (o2
)->plist
;
1991 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1992 && (XMARKER (o1
)->buffer
== 0
1993 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1997 case Lisp_Vectorlike
:
1999 register int i
, size
;
2000 size
= XVECTOR (o1
)->size
;
2001 /* Pseudovectors have the type encoded in the size field, so this test
2002 actually checks that the objects have the same type as well as the
2004 if (XVECTOR (o2
)->size
!= size
)
2006 /* Boolvectors are compared much like strings. */
2007 if (BOOL_VECTOR_P (o1
))
2010 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2012 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2014 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2019 if (WINDOW_CONFIGURATIONP (o1
))
2020 return compare_window_configurations (o1
, o2
, 0);
2022 /* Aside from them, only true vectors, char-tables, and compiled
2023 functions are sensible to compare, so eliminate the others now. */
2024 if (size
& PSEUDOVECTOR_FLAG
)
2026 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2028 size
&= PSEUDOVECTOR_SIZE_MASK
;
2030 for (i
= 0; i
< size
; i
++)
2033 v1
= XVECTOR (o1
)->contents
[i
];
2034 v2
= XVECTOR (o2
)->contents
[i
];
2035 if (!internal_equal (v1
, v2
, depth
+ 1))
2043 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
2045 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
2047 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
2048 STRING_BYTES (XSTRING (o1
))))
2054 case Lisp_Type_Limit
:
2061 extern Lisp_Object
Fmake_char_internal ();
2063 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2064 "Store each element of ARRAY with ITEM.\n\
2065 ARRAY is a vector, string, char-table, or bool-vector.")
2067 Lisp_Object array
, item
;
2069 register int size
, index
, charval
;
2071 if (VECTORP (array
))
2073 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2074 size
= XVECTOR (array
)->size
;
2075 for (index
= 0; index
< size
; index
++)
2078 else if (CHAR_TABLE_P (array
))
2080 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2081 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2082 for (index
= 0; index
< size
; index
++)
2084 XCHAR_TABLE (array
)->defalt
= Qnil
;
2086 else if (STRINGP (array
))
2088 register unsigned char *p
= XSTRING (array
)->data
;
2089 CHECK_NUMBER (item
, 1);
2090 charval
= XINT (item
);
2091 size
= XSTRING (array
)->size
;
2092 if (STRING_MULTIBYTE (array
))
2094 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2095 int len
= CHAR_STRING (charval
, str
);
2096 int size_byte
= STRING_BYTES (XSTRING (array
));
2097 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2100 if (size
!= size_byte
)
2103 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2104 if (len
!= this_len
)
2105 error ("Attempt to change byte length of a string");
2108 for (i
= 0; i
< size_byte
; i
++)
2109 *p
++ = str
[i
% len
];
2112 for (index
= 0; index
< size
; index
++)
2115 else if (BOOL_VECTOR_P (array
))
2117 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2119 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2121 charval
= (! NILP (item
) ? -1 : 0);
2122 for (index
= 0; index
< size_in_chars
; index
++)
2127 array
= wrong_type_argument (Qarrayp
, array
);
2133 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2135 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
2137 Lisp_Object char_table
;
2139 CHECK_CHAR_TABLE (char_table
, 0);
2141 return XCHAR_TABLE (char_table
)->purpose
;
2144 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2146 "Return the parent char-table of CHAR-TABLE.\n\
2147 The value is either nil or another char-table.\n\
2148 If CHAR-TABLE holds nil for a given character,\n\
2149 then the actual applicable value is inherited from the parent char-table\n\
2150 \(or from its parents, if necessary).")
2152 Lisp_Object char_table
;
2154 CHECK_CHAR_TABLE (char_table
, 0);
2156 return XCHAR_TABLE (char_table
)->parent
;
2159 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2161 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
2162 PARENT must be either nil or another char-table.")
2163 (char_table
, parent
)
2164 Lisp_Object char_table
, parent
;
2168 CHECK_CHAR_TABLE (char_table
, 0);
2172 CHECK_CHAR_TABLE (parent
, 0);
2174 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2175 if (EQ (temp
, char_table
))
2176 error ("Attempt to make a chartable be its own parent");
2179 XCHAR_TABLE (char_table
)->parent
= parent
;
2184 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2186 "Return the value of CHAR-TABLE's extra-slot number N.")
2188 Lisp_Object char_table
, n
;
2190 CHECK_CHAR_TABLE (char_table
, 1);
2191 CHECK_NUMBER (n
, 2);
2193 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2194 args_out_of_range (char_table
, n
);
2196 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2199 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2200 Sset_char_table_extra_slot
,
2202 "Set CHAR-TABLE's extra-slot number N to VALUE.")
2203 (char_table
, n
, value
)
2204 Lisp_Object char_table
, n
, value
;
2206 CHECK_CHAR_TABLE (char_table
, 1);
2207 CHECK_NUMBER (n
, 2);
2209 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2210 args_out_of_range (char_table
, n
);
2212 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2215 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2217 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
2218 RANGE should be nil (for the default value)\n\
2219 a vector which identifies a character set or a row of a character set,\n\
2220 a character set name, or a character code.")
2222 Lisp_Object char_table
, range
;
2224 CHECK_CHAR_TABLE (char_table
, 0);
2226 if (EQ (range
, Qnil
))
2227 return XCHAR_TABLE (char_table
)->defalt
;
2228 else if (INTEGERP (range
))
2229 return Faref (char_table
, range
);
2230 else if (SYMBOLP (range
))
2232 Lisp_Object charset_info
;
2234 charset_info
= Fget (range
, Qcharset
);
2235 CHECK_VECTOR (charset_info
, 0);
2237 return Faref (char_table
,
2238 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2241 else if (VECTORP (range
))
2243 if (XVECTOR (range
)->size
== 1)
2244 return Faref (char_table
,
2245 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2248 int size
= XVECTOR (range
)->size
;
2249 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2250 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2251 size
<= 1 ? Qnil
: val
[1],
2252 size
<= 2 ? Qnil
: val
[2]);
2253 return Faref (char_table
, ch
);
2257 error ("Invalid RANGE argument to `char-table-range'");
2261 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2263 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
2264 RANGE should be t (for all characters), nil (for the default value)\n\
2265 a vector which identifies a character set or a row of a character set,\n\
2266 a coding system, or a character code.")
2267 (char_table
, range
, value
)
2268 Lisp_Object char_table
, range
, value
;
2272 CHECK_CHAR_TABLE (char_table
, 0);
2275 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2276 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2277 else if (EQ (range
, Qnil
))
2278 XCHAR_TABLE (char_table
)->defalt
= value
;
2279 else if (SYMBOLP (range
))
2281 Lisp_Object charset_info
;
2283 charset_info
= Fget (range
, Qcharset
);
2284 CHECK_VECTOR (charset_info
, 0);
2286 return Faset (char_table
,
2287 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2291 else if (INTEGERP (range
))
2292 Faset (char_table
, range
, value
);
2293 else if (VECTORP (range
))
2295 if (XVECTOR (range
)->size
== 1)
2296 return Faset (char_table
,
2297 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2301 int size
= XVECTOR (range
)->size
;
2302 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2303 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2304 size
<= 1 ? Qnil
: val
[1],
2305 size
<= 2 ? Qnil
: val
[2]);
2306 return Faset (char_table
, ch
, value
);
2310 error ("Invalid RANGE argument to `set-char-table-range'");
2315 DEFUN ("set-char-table-default", Fset_char_table_default
,
2316 Sset_char_table_default
, 3, 3, 0,
2317 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2318 The generic character specifies the group of characters.\n\
2319 See also the documentation of make-char.")
2320 (char_table
, ch
, value
)
2321 Lisp_Object char_table
, ch
, value
;
2323 int c
, charset
, code1
, code2
;
2326 CHECK_CHAR_TABLE (char_table
, 0);
2327 CHECK_NUMBER (ch
, 1);
2330 SPLIT_CHAR (c
, charset
, code1
, code2
);
2332 /* Since we may want to set the default value for a character set
2333 not yet defined, we check only if the character set is in the
2334 valid range or not, instead of it is already defined or not. */
2335 if (! CHARSET_VALID_P (charset
))
2336 invalid_character (c
);
2338 if (charset
== CHARSET_ASCII
)
2339 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2341 /* Even if C is not a generic char, we had better behave as if a
2342 generic char is specified. */
2343 if (CHARSET_DIMENSION (charset
) == 1)
2345 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2348 if (SUB_CHAR_TABLE_P (temp
))
2349 XCHAR_TABLE (temp
)->defalt
= value
;
2351 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2354 if (SUB_CHAR_TABLE_P (temp
))
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_hourglass_p
)
2814 cancel_hourglass ();
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_vector (new_size
);
3827 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3828 old_size
* sizeof *v
->contents
);
3829 for (i
= old_size
; i
< new_size
; ++i
)
3830 v
->contents
[i
] = init
;
3831 XSETVECTOR (vec
, v
);
3836 /***********************************************************************
3838 ***********************************************************************/
3840 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3841 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3842 KEY2 are the same. */
3845 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3846 struct Lisp_Hash_Table
*h
;
3847 Lisp_Object key1
, key2
;
3848 unsigned hash1
, hash2
;
3850 return (FLOATP (key1
)
3852 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3856 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3857 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3858 KEY2 are the same. */
3861 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3862 struct Lisp_Hash_Table
*h
;
3863 Lisp_Object key1
, key2
;
3864 unsigned hash1
, hash2
;
3866 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3870 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3871 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3872 if KEY1 and KEY2 are the same. */
3875 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3876 struct Lisp_Hash_Table
*h
;
3877 Lisp_Object key1
, key2
;
3878 unsigned hash1
, hash2
;
3882 Lisp_Object args
[3];
3884 args
[0] = h
->user_cmp_function
;
3887 return !NILP (Ffuncall (3, args
));
3894 /* Value is a hash code for KEY for use in hash table H which uses
3895 `eq' to compare keys. The hash code returned is guaranteed to fit
3896 in a Lisp integer. */
3900 struct Lisp_Hash_Table
*h
;
3903 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3904 xassert ((hash
& ~VALMASK
) == 0);
3909 /* Value is a hash code for KEY for use in hash table H which uses
3910 `eql' to compare keys. The hash code returned is guaranteed to fit
3911 in a Lisp integer. */
3915 struct Lisp_Hash_Table
*h
;
3920 hash
= sxhash (key
, 0);
3922 hash
= XUINT (key
) ^ XGCTYPE (key
);
3923 xassert ((hash
& ~VALMASK
) == 0);
3928 /* Value is a hash code for KEY for use in hash table H which uses
3929 `equal' to compare keys. The hash code returned is guaranteed to fit
3930 in a Lisp integer. */
3933 hashfn_equal (h
, key
)
3934 struct Lisp_Hash_Table
*h
;
3937 unsigned hash
= sxhash (key
, 0);
3938 xassert ((hash
& ~VALMASK
) == 0);
3943 /* Value is a hash code for KEY for use in hash table H which uses as
3944 user-defined function to compare keys. The hash code returned is
3945 guaranteed to fit in a Lisp integer. */
3948 hashfn_user_defined (h
, key
)
3949 struct Lisp_Hash_Table
*h
;
3952 Lisp_Object args
[2], hash
;
3954 args
[0] = h
->user_hash_function
;
3956 hash
= Ffuncall (2, args
);
3957 if (!INTEGERP (hash
))
3959 list2 (build_string ("Invalid hash code returned from \
3960 user-supplied hash function"),
3962 return XUINT (hash
);
3966 /* Create and initialize a new hash table.
3968 TEST specifies the test the hash table will use to compare keys.
3969 It must be either one of the predefined tests `eq', `eql' or
3970 `equal' or a symbol denoting a user-defined test named TEST with
3971 test and hash functions USER_TEST and USER_HASH.
3973 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3975 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3976 new size when it becomes full is computed by adding REHASH_SIZE to
3977 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3978 table's new size is computed by multiplying its old size with
3981 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3982 be resized when the ratio of (number of entries in the table) /
3983 (table size) is >= REHASH_THRESHOLD.
3985 WEAK specifies the weakness of the table. If non-nil, it must be
3986 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3989 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3990 user_test
, user_hash
)
3991 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3992 Lisp_Object user_test
, user_hash
;
3994 struct Lisp_Hash_Table
*h
;
3996 int index_size
, i
, sz
;
3998 /* Preconditions. */
3999 xassert (SYMBOLP (test
));
4000 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4001 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4002 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4003 xassert (FLOATP (rehash_threshold
)
4004 && XFLOATINT (rehash_threshold
) > 0
4005 && XFLOATINT (rehash_threshold
) <= 1.0);
4007 if (XFASTINT (size
) == 0)
4008 size
= make_number (1);
4010 /* Allocate a table and initialize it. */
4011 h
= allocate_hash_table ();
4013 /* Initialize hash table slots. */
4014 sz
= XFASTINT (size
);
4017 if (EQ (test
, Qeql
))
4019 h
->cmpfn
= cmpfn_eql
;
4020 h
->hashfn
= hashfn_eql
;
4022 else if (EQ (test
, Qeq
))
4025 h
->hashfn
= hashfn_eq
;
4027 else if (EQ (test
, Qequal
))
4029 h
->cmpfn
= cmpfn_equal
;
4030 h
->hashfn
= hashfn_equal
;
4034 h
->user_cmp_function
= user_test
;
4035 h
->user_hash_function
= user_hash
;
4036 h
->cmpfn
= cmpfn_user_defined
;
4037 h
->hashfn
= hashfn_user_defined
;
4041 h
->rehash_threshold
= rehash_threshold
;
4042 h
->rehash_size
= rehash_size
;
4043 h
->count
= make_number (0);
4044 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4045 h
->hash
= Fmake_vector (size
, Qnil
);
4046 h
->next
= Fmake_vector (size
, Qnil
);
4047 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4048 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4049 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4051 /* Set up the free list. */
4052 for (i
= 0; i
< sz
- 1; ++i
)
4053 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4054 h
->next_free
= make_number (0);
4056 XSET_HASH_TABLE (table
, h
);
4057 xassert (HASH_TABLE_P (table
));
4058 xassert (XHASH_TABLE (table
) == h
);
4060 /* Maybe add this hash table to the list of all weak hash tables. */
4062 h
->next_weak
= Qnil
;
4065 h
->next_weak
= Vweak_hash_tables
;
4066 Vweak_hash_tables
= table
;
4073 /* Return a copy of hash table H1. Keys and values are not copied,
4074 only the table itself is. */
4077 copy_hash_table (h1
)
4078 struct Lisp_Hash_Table
*h1
;
4081 struct Lisp_Hash_Table
*h2
;
4082 struct Lisp_Vector
*v
, *next
;
4084 h2
= allocate_hash_table ();
4085 next
= h2
->vec_next
;
4086 bcopy (h1
, h2
, sizeof *h2
);
4087 h2
->vec_next
= next
;
4088 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4089 h2
->hash
= Fcopy_sequence (h1
->hash
);
4090 h2
->next
= Fcopy_sequence (h1
->next
);
4091 h2
->index
= Fcopy_sequence (h1
->index
);
4092 XSET_HASH_TABLE (table
, h2
);
4094 /* Maybe add this hash table to the list of all weak hash tables. */
4095 if (!NILP (h2
->weak
))
4097 h2
->next_weak
= Vweak_hash_tables
;
4098 Vweak_hash_tables
= table
;
4105 /* Resize hash table H if it's too full. If H cannot be resized
4106 because it's already too large, throw an error. */
4109 maybe_resize_hash_table (h
)
4110 struct Lisp_Hash_Table
*h
;
4112 if (NILP (h
->next_free
))
4114 int old_size
= HASH_TABLE_SIZE (h
);
4115 int i
, new_size
, index_size
;
4117 if (INTEGERP (h
->rehash_size
))
4118 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4120 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4121 new_size
= max (old_size
+ 1, new_size
);
4122 index_size
= next_almost_prime ((int)
4124 / XFLOATINT (h
->rehash_threshold
)));
4125 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4126 error ("Hash table too large to resize");
4128 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4129 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4130 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4131 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4133 /* Update the free list. Do it so that new entries are added at
4134 the end of the free list. This makes some operations like
4136 for (i
= old_size
; i
< new_size
- 1; ++i
)
4137 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4139 if (!NILP (h
->next_free
))
4141 Lisp_Object last
, next
;
4143 last
= h
->next_free
;
4144 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4148 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4151 XSETFASTINT (h
->next_free
, old_size
);
4154 for (i
= 0; i
< old_size
; ++i
)
4155 if (!NILP (HASH_HASH (h
, i
)))
4157 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4158 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4159 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4160 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4166 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4167 the hash code of KEY. Value is the index of the entry in H
4168 matching KEY, or -1 if not found. */
4171 hash_lookup (h
, key
, hash
)
4172 struct Lisp_Hash_Table
*h
;
4177 int start_of_bucket
;
4180 hash_code
= h
->hashfn (h
, key
);
4184 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4185 idx
= HASH_INDEX (h
, start_of_bucket
);
4187 /* We need not gcpro idx since it's either an integer or nil. */
4190 int i
= XFASTINT (idx
);
4191 if (EQ (key
, HASH_KEY (h
, i
))
4193 && h
->cmpfn (h
, key
, hash_code
,
4194 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4196 idx
= HASH_NEXT (h
, i
);
4199 return NILP (idx
) ? -1 : XFASTINT (idx
);
4203 /* Put an entry into hash table H that associates KEY with VALUE.
4204 HASH is a previously computed hash code of KEY.
4205 Value is the index of the entry in H matching KEY. */
4208 hash_put (h
, key
, value
, hash
)
4209 struct Lisp_Hash_Table
*h
;
4210 Lisp_Object key
, value
;
4213 int start_of_bucket
, i
;
4215 xassert ((hash
& ~VALMASK
) == 0);
4217 /* Increment count after resizing because resizing may fail. */
4218 maybe_resize_hash_table (h
);
4219 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4221 /* Store key/value in the key_and_value vector. */
4222 i
= XFASTINT (h
->next_free
);
4223 h
->next_free
= HASH_NEXT (h
, i
);
4224 HASH_KEY (h
, i
) = key
;
4225 HASH_VALUE (h
, i
) = value
;
4227 /* Remember its hash code. */
4228 HASH_HASH (h
, i
) = make_number (hash
);
4230 /* Add new entry to its collision chain. */
4231 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4232 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4233 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4238 /* Remove the entry matching KEY from hash table H, if there is one. */
4241 hash_remove (h
, key
)
4242 struct Lisp_Hash_Table
*h
;
4246 int start_of_bucket
;
4247 Lisp_Object idx
, prev
;
4249 hash_code
= h
->hashfn (h
, key
);
4250 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4251 idx
= HASH_INDEX (h
, start_of_bucket
);
4254 /* We need not gcpro idx, prev since they're either integers or nil. */
4257 int i
= XFASTINT (idx
);
4259 if (EQ (key
, HASH_KEY (h
, i
))
4261 && h
->cmpfn (h
, key
, hash_code
,
4262 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4264 /* Take entry out of collision chain. */
4266 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4268 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4270 /* Clear slots in key_and_value and add the slots to
4272 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4273 HASH_NEXT (h
, i
) = h
->next_free
;
4274 h
->next_free
= make_number (i
);
4275 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4276 xassert (XINT (h
->count
) >= 0);
4282 idx
= HASH_NEXT (h
, i
);
4288 /* Clear hash table H. */
4292 struct Lisp_Hash_Table
*h
;
4294 if (XFASTINT (h
->count
) > 0)
4296 int i
, size
= HASH_TABLE_SIZE (h
);
4298 for (i
= 0; i
< size
; ++i
)
4300 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4301 HASH_KEY (h
, i
) = Qnil
;
4302 HASH_VALUE (h
, i
) = Qnil
;
4303 HASH_HASH (h
, i
) = Qnil
;
4306 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4307 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4309 h
->next_free
= make_number (0);
4310 h
->count
= make_number (0);
4316 /************************************************************************
4318 ************************************************************************/
4320 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4321 entries from the table that don't survive the current GC.
4322 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4323 non-zero if anything was marked. */
4326 sweep_weak_table (h
, remove_entries_p
)
4327 struct Lisp_Hash_Table
*h
;
4328 int remove_entries_p
;
4330 int bucket
, n
, marked
;
4332 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4335 for (bucket
= 0; bucket
< n
; ++bucket
)
4337 Lisp_Object idx
, next
, prev
;
4339 /* Follow collision chain, removing entries that
4340 don't survive this garbage collection. */
4342 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4344 int i
= XFASTINT (idx
);
4345 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4346 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4349 if (EQ (h
->weak
, Qkey
))
4350 remove_p
= !key_known_to_survive_p
;
4351 else if (EQ (h
->weak
, Qvalue
))
4352 remove_p
= !value_known_to_survive_p
;
4353 else if (EQ (h
->weak
, Qkey_or_value
))
4354 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4355 else if (EQ (h
->weak
, Qkey_and_value
))
4356 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4360 next
= HASH_NEXT (h
, i
);
4362 if (remove_entries_p
)
4366 /* Take out of collision chain. */
4368 HASH_INDEX (h
, bucket
) = next
;
4370 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4372 /* Add to free list. */
4373 HASH_NEXT (h
, i
) = h
->next_free
;
4376 /* Clear key, value, and hash. */
4377 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4378 HASH_HASH (h
, i
) = Qnil
;
4380 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4387 /* Make sure key and value survive. */
4388 if (!key_known_to_survive_p
)
4390 mark_object (&HASH_KEY (h
, i
));
4394 if (!value_known_to_survive_p
)
4396 mark_object (&HASH_VALUE (h
, i
));
4407 /* Remove elements from weak hash tables that don't survive the
4408 current garbage collection. Remove weak tables that don't survive
4409 from Vweak_hash_tables. Called from gc_sweep. */
4412 sweep_weak_hash_tables ()
4414 Lisp_Object table
, used
, next
;
4415 struct Lisp_Hash_Table
*h
;
4418 /* Mark all keys and values that are in use. Keep on marking until
4419 there is no more change. This is necessary for cases like
4420 value-weak table A containing an entry X -> Y, where Y is used in a
4421 key-weak table B, Z -> Y. If B comes after A in the list of weak
4422 tables, X -> Y might be removed from A, although when looking at B
4423 one finds that it shouldn't. */
4427 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4429 h
= XHASH_TABLE (table
);
4430 if (h
->size
& ARRAY_MARK_FLAG
)
4431 marked
|= sweep_weak_table (h
, 0);
4436 /* Remove tables and entries that aren't used. */
4437 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4439 h
= XHASH_TABLE (table
);
4440 next
= h
->next_weak
;
4442 if (h
->size
& ARRAY_MARK_FLAG
)
4444 /* TABLE is marked as used. Sweep its contents. */
4445 if (XFASTINT (h
->count
) > 0)
4446 sweep_weak_table (h
, 1);
4448 /* Add table to the list of used weak hash tables. */
4449 h
->next_weak
= used
;
4454 Vweak_hash_tables
= used
;
4459 /***********************************************************************
4460 Hash Code Computation
4461 ***********************************************************************/
4463 /* Maximum depth up to which to dive into Lisp structures. */
4465 #define SXHASH_MAX_DEPTH 3
4467 /* Maximum length up to which to take list and vector elements into
4470 #define SXHASH_MAX_LEN 7
4472 /* Combine two integers X and Y for hashing. */
4474 #define SXHASH_COMBINE(X, Y) \
4475 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4479 /* Return a hash for string PTR which has length LEN. The hash
4480 code returned is guaranteed to fit in a Lisp integer. */
4483 sxhash_string (ptr
, len
)
4487 unsigned char *p
= ptr
;
4488 unsigned char *end
= p
+ len
;
4497 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4500 return hash
& VALMASK
;
4504 /* Return a hash for list LIST. DEPTH is the current depth in the
4505 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4508 sxhash_list (list
, depth
)
4515 if (depth
< SXHASH_MAX_DEPTH
)
4517 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4518 list
= XCDR (list
), ++i
)
4520 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4521 hash
= SXHASH_COMBINE (hash
, hash2
);
4528 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4529 the Lisp structure. */
4532 sxhash_vector (vec
, depth
)
4536 unsigned hash
= XVECTOR (vec
)->size
;
4539 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4540 for (i
= 0; i
< n
; ++i
)
4542 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4543 hash
= SXHASH_COMBINE (hash
, hash2
);
4550 /* Return a hash for bool-vector VECTOR. */
4553 sxhash_bool_vector (vec
)
4556 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4559 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4560 for (i
= 0; i
< n
; ++i
)
4561 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4567 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4568 structure. Value is an unsigned integer clipped to VALMASK. */
4577 if (depth
> SXHASH_MAX_DEPTH
)
4580 switch (XTYPE (obj
))
4587 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4588 XSYMBOL (obj
)->name
->size
);
4596 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4599 /* This can be everything from a vector to an overlay. */
4600 case Lisp_Vectorlike
:
4602 /* According to the CL HyperSpec, two arrays are equal only if
4603 they are `eq', except for strings and bit-vectors. In
4604 Emacs, this works differently. We have to compare element
4606 hash
= sxhash_vector (obj
, depth
);
4607 else if (BOOL_VECTOR_P (obj
))
4608 hash
= sxhash_bool_vector (obj
);
4610 /* Others are `equal' if they are `eq', so let's take their
4616 hash
= sxhash_list (obj
, depth
);
4621 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4622 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4623 for (hash
= 0; p
< e
; ++p
)
4624 hash
= SXHASH_COMBINE (hash
, *p
);
4632 return hash
& VALMASK
;
4637 /***********************************************************************
4639 ***********************************************************************/
4642 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4643 "Compute a hash code for OBJ and return it as integer.")
4647 unsigned hash
= sxhash (obj
, 0);;
4648 return make_number (hash
);
4652 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4653 "Create and return a new hash table.\n\
4654 Arguments are specified as keyword/argument pairs. The following\n\
4655 arguments are defined:\n\
4657 :test TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4658 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4659 User-supplied test and hash functions can be specified via\n\
4660 `define-hash-table-test'.\n\
4662 :size SIZE -- A hint as to how many elements will be put in the table.\n\
4665 :rehash-size REHASH-SIZE - Indicates how to expand the table when\n\
4666 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4667 If it is a float, it must be > 1.0, and the new size is computed by\n\
4668 multiplying the old size with that factor. Default is 1.5.\n\
4670 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4671 Resize the hash table when ratio of the number of entries in the table.\n\
4674 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',\n\
4675 `key-or-value', or `key-and-value'. If WEAK is not nil, the table returned\n\
4676 is a weak table. Key/value pairs are removed from a weak hash table when\n\
4677 there are no non-weak references pointing to their key, value, one of key\n\
4678 or value, or both key and value, depending on WEAK. WEAK t is equivalent\n\
4679 to `key-and-value'. Default value of WEAK is nil.")
4684 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4685 Lisp_Object user_test
, user_hash
;
4689 /* The vector `used' is used to keep track of arguments that
4690 have been consumed. */
4691 used
= (char *) alloca (nargs
* sizeof *used
);
4692 bzero (used
, nargs
* sizeof *used
);
4694 /* See if there's a `:test TEST' among the arguments. */
4695 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4696 test
= i
< 0 ? Qeql
: args
[i
];
4697 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4699 /* See if it is a user-defined test. */
4702 prop
= Fget (test
, Qhash_table_test
);
4703 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4704 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4706 user_test
= Fnth (make_number (0), prop
);
4707 user_hash
= Fnth (make_number (1), prop
);
4710 user_test
= user_hash
= Qnil
;
4712 /* See if there's a `:size SIZE' argument. */
4713 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4714 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4715 if (!INTEGERP (size
) || XINT (size
) < 0)
4717 list2 (build_string ("Invalid hash table size"),
4720 /* Look for `:rehash-size SIZE'. */
4721 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4722 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4723 if (!NUMBERP (rehash_size
)
4724 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4725 || XFLOATINT (rehash_size
) <= 1.0)
4727 list2 (build_string ("Invalid hash table rehash size"),
4730 /* Look for `:rehash-threshold THRESHOLD'. */
4731 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4732 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4733 if (!FLOATP (rehash_threshold
)
4734 || XFLOATINT (rehash_threshold
) <= 0.0
4735 || XFLOATINT (rehash_threshold
) > 1.0)
4737 list2 (build_string ("Invalid hash table rehash threshold"),
4740 /* Look for `:weakness WEAK'. */
4741 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4742 weak
= i
< 0 ? Qnil
: args
[i
];
4744 weak
= Qkey_and_value
;
4747 && !EQ (weak
, Qvalue
)
4748 && !EQ (weak
, Qkey_or_value
)
4749 && !EQ (weak
, Qkey_and_value
))
4750 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4753 /* Now, all args should have been used up, or there's a problem. */
4754 for (i
= 0; i
< nargs
; ++i
)
4757 list2 (build_string ("Invalid argument list"), args
[i
]));
4759 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4760 user_test
, user_hash
);
4764 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4765 "Return a copy of hash table TABLE.")
4769 return copy_hash_table (check_hash_table (table
));
4773 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4774 "Create a new hash table.\n\
4775 Optional first argument TEST specifies how to compare keys in\n\
4776 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4777 is `eql'. New tests can be defined with `define-hash-table-test'.")
4781 Lisp_Object args
[2];
4783 args
[1] = NILP (test
) ? Qeql
: test
;
4784 return Fmake_hash_table (2, args
);
4788 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4789 "Return the number of elements in TABLE.")
4793 return check_hash_table (table
)->count
;
4797 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4798 Shash_table_rehash_size
, 1, 1, 0,
4799 "Return the current rehash size of TABLE.")
4803 return check_hash_table (table
)->rehash_size
;
4807 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4808 Shash_table_rehash_threshold
, 1, 1, 0,
4809 "Return the current rehash threshold of TABLE.")
4813 return check_hash_table (table
)->rehash_threshold
;
4817 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4818 "Return the size of TABLE.\n\
4819 The size can be used as an argument to `make-hash-table' to create\n\
4820 a hash table than can hold as many elements of TABLE holds\n\
4821 without need for resizing.")
4825 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4826 return make_number (HASH_TABLE_SIZE (h
));
4830 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4831 "Return the test TABLE uses.")
4835 return check_hash_table (table
)->test
;
4839 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4841 "Return the weakness of TABLE.")
4845 return check_hash_table (table
)->weak
;
4849 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4850 "Return t if OBJ is a Lisp hash table object.")
4854 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4858 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4859 "Clear hash table TABLE.")
4863 hash_clear (check_hash_table (table
));
4868 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4869 "Look up KEY in TABLE and return its associated value.\n\
4870 If KEY is not found, return DFLT which defaults to nil.")
4872 Lisp_Object key
, table
, dflt
;
4874 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4875 int i
= hash_lookup (h
, key
, NULL
);
4876 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4880 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4881 "Associate KEY with VALUE in hash table TABLE.\n\
4882 If KEY is already present in table, replace its current value with\n\
4885 Lisp_Object key
, value
, table
;
4887 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4891 i
= hash_lookup (h
, key
, &hash
);
4893 HASH_VALUE (h
, i
) = value
;
4895 hash_put (h
, key
, value
, hash
);
4901 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4902 "Remove KEY from TABLE.")
4904 Lisp_Object key
, table
;
4906 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4907 hash_remove (h
, key
);
4912 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4913 "Call FUNCTION for all entries in hash table TABLE.\n\
4914 FUNCTION is called with 2 arguments KEY and VALUE.")
4916 Lisp_Object function
, table
;
4918 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4919 Lisp_Object args
[3];
4922 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4923 if (!NILP (HASH_HASH (h
, i
)))
4926 args
[1] = HASH_KEY (h
, i
);
4927 args
[2] = HASH_VALUE (h
, i
);
4935 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4936 Sdefine_hash_table_test
, 3, 3, 0,
4937 "Define a new hash table test with name NAME, a symbol.\n\
4938 In hash tables create with NAME specified as test, use TEST to compare\n\
4939 keys, and HASH for computing hash codes of keys.\n\
4941 TEST must be a function taking two arguments and returning non-nil\n\
4942 if both arguments are the same. HASH must be a function taking\n\
4943 one argument and return an integer that is the hash code of the\n\
4944 argument. Hash code computation should use the whole value range of\n\
4945 integers, including negative integers.")
4947 Lisp_Object name
, test
, hash
;
4949 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4954 /************************************************************************
4956 ************************************************************************/
4961 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4962 "Return MD5 message digest of OBJECT, a buffer or string.\n\
4963 A message digest is a cryptographic checksum of a document,\n\
4964 and the algorithm to calculate it is defined in RFC 1321.\n\
4966 The two optional arguments START and END are character positions\n\
4967 specifying for which part of OBJECT the message digest should be computed.\n\
4968 If nil or omitted, the digest is computed for the whole OBJECT.\n\
4970 The MD5 message digest is computed from the result of encoding the\n\
4971 text in a coding system, not directly from the internal Emacs form\n\
4972 of the text. The optional fourth argument CODING-SYSTEM specifies\n\
4973 which coding system to encode the text with. It should be the same\n\
4974 coding system that you used or will use when actually writing the text\n\
4977 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT.\n\
4978 If OBJECT is a buffer, the default for CODING-SYSTEM is whatever\n\
4979 coding system would be chosen by default for writing this text\n\
4982 If OBJECT is a string, the most preferred coding system (see the\n\
4983 command `prefer-coding-system') is used.\n\
4985 If NOERROR is non-nil, silently assume the `raw_text' coding if the\n\
4986 guesswork fails. Normally, an error is signaled in such case.")
4987 (object
, start
, end
, coding_system
, noerror
)
4988 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4990 unsigned char digest
[16];
4991 unsigned char value
[33];
4995 int start_char
= 0, end_char
= 0;
4996 int start_byte
= 0, end_byte
= 0;
4998 register struct buffer
*bp
;
5001 if (STRINGP (object
))
5003 if (NILP (coding_system
))
5005 /* Decide the coding-system to encode the data with. */
5007 if (STRING_MULTIBYTE (object
))
5008 /* use default, we can't guess correct value */
5009 coding_system
= XSYMBOL (XCAR (Vcoding_category_list
))->value
;
5011 coding_system
= Qraw_text
;
5014 if (NILP (Fcoding_system_p (coding_system
)))
5016 /* Invalid coding system. */
5018 if (!NILP (noerror
))
5019 coding_system
= Qraw_text
;
5022 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5025 if (STRING_MULTIBYTE (object
))
5026 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5028 size
= XSTRING (object
)->size
;
5029 size_byte
= STRING_BYTES (XSTRING (object
));
5033 CHECK_NUMBER (start
, 1);
5035 start_char
= XINT (start
);
5040 start_byte
= string_char_to_byte (object
, start_char
);
5046 end_byte
= size_byte
;
5050 CHECK_NUMBER (end
, 2);
5052 end_char
= XINT (end
);
5057 end_byte
= string_char_to_byte (object
, end_char
);
5060 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5061 args_out_of_range_3 (object
, make_number (start_char
),
5062 make_number (end_char
));
5066 CHECK_BUFFER (object
, 0);
5068 bp
= XBUFFER (object
);
5074 CHECK_NUMBER_COERCE_MARKER (start
, 0);
5082 CHECK_NUMBER_COERCE_MARKER (end
, 1);
5087 temp
= b
, b
= e
, e
= temp
;
5089 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5090 args_out_of_range (start
, end
);
5092 if (NILP (coding_system
))
5094 /* Decide the coding-system to encode the data with.
5095 See fileio.c:Fwrite-region */
5097 if (!NILP (Vcoding_system_for_write
))
5098 coding_system
= Vcoding_system_for_write
;
5101 int force_raw_text
= 0;
5103 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5104 if (NILP (coding_system
)
5105 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5107 coding_system
= Qnil
;
5108 if (NILP (current_buffer
->enable_multibyte_characters
))
5112 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5114 /* Check file-coding-system-alist. */
5115 Lisp_Object args
[4], val
;
5117 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5118 args
[3] = Fbuffer_file_name(object
);
5119 val
= Ffind_operation_coding_system (4, args
);
5120 if (CONSP (val
) && !NILP (XCDR (val
)))
5121 coding_system
= XCDR (val
);
5124 if (NILP (coding_system
)
5125 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5127 /* If we still have not decided a coding system, use the
5128 default value of buffer-file-coding-system. */
5129 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5133 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5134 /* Confirm that VAL can surely encode the current region. */
5135 coding_system
= call3 (Vselect_safe_coding_system_function
,
5136 make_number (b
), make_number (e
),
5140 coding_system
= Qraw_text
;
5143 if (NILP (Fcoding_system_p (coding_system
)))
5145 /* Invalid coding system. */
5147 if (!NILP (noerror
))
5148 coding_system
= Qraw_text
;
5151 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5155 object
= make_buffer_string (b
, e
, 0);
5157 if (STRING_MULTIBYTE (object
))
5158 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5161 md5_buffer (XSTRING (object
)->data
+ start_byte
,
5162 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
5165 for (i
= 0; i
< 16; i
++)
5166 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5169 return make_string (value
, 32);
5176 /* Hash table stuff. */
5177 Qhash_table_p
= intern ("hash-table-p");
5178 staticpro (&Qhash_table_p
);
5179 Qeq
= intern ("eq");
5181 Qeql
= intern ("eql");
5183 Qequal
= intern ("equal");
5184 staticpro (&Qequal
);
5185 QCtest
= intern (":test");
5186 staticpro (&QCtest
);
5187 QCsize
= intern (":size");
5188 staticpro (&QCsize
);
5189 QCrehash_size
= intern (":rehash-size");
5190 staticpro (&QCrehash_size
);
5191 QCrehash_threshold
= intern (":rehash-threshold");
5192 staticpro (&QCrehash_threshold
);
5193 QCweakness
= intern (":weakness");
5194 staticpro (&QCweakness
);
5195 Qkey
= intern ("key");
5197 Qvalue
= intern ("value");
5198 staticpro (&Qvalue
);
5199 Qhash_table_test
= intern ("hash-table-test");
5200 staticpro (&Qhash_table_test
);
5201 Qkey_or_value
= intern ("key-or-value");
5202 staticpro (&Qkey_or_value
);
5203 Qkey_and_value
= intern ("key-and-value");
5204 staticpro (&Qkey_and_value
);
5207 defsubr (&Smake_hash_table
);
5208 defsubr (&Scopy_hash_table
);
5209 defsubr (&Smakehash
);
5210 defsubr (&Shash_table_count
);
5211 defsubr (&Shash_table_rehash_size
);
5212 defsubr (&Shash_table_rehash_threshold
);
5213 defsubr (&Shash_table_size
);
5214 defsubr (&Shash_table_test
);
5215 defsubr (&Shash_table_weakness
);
5216 defsubr (&Shash_table_p
);
5217 defsubr (&Sclrhash
);
5218 defsubr (&Sgethash
);
5219 defsubr (&Sputhash
);
5220 defsubr (&Sremhash
);
5221 defsubr (&Smaphash
);
5222 defsubr (&Sdefine_hash_table_test
);
5224 Qstring_lessp
= intern ("string-lessp");
5225 staticpro (&Qstring_lessp
);
5226 Qprovide
= intern ("provide");
5227 staticpro (&Qprovide
);
5228 Qrequire
= intern ("require");
5229 staticpro (&Qrequire
);
5230 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5231 staticpro (&Qyes_or_no_p_history
);
5232 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5233 staticpro (&Qcursor_in_echo_area
);
5234 Qwidget_type
= intern ("widget-type");
5235 staticpro (&Qwidget_type
);
5237 staticpro (&string_char_byte_cache_string
);
5238 string_char_byte_cache_string
= Qnil
;
5240 Fset (Qyes_or_no_p_history
, Qnil
);
5242 DEFVAR_LISP ("features", &Vfeatures
,
5243 "A list of symbols which are the features of the executing emacs.\n\
5244 Used by `featurep' and `require', and altered by `provide'.");
5247 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5248 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
5249 This applies to y-or-n and yes-or-no questions asked by commands\n\
5250 invoked by mouse clicks and mouse menu items.");
5253 defsubr (&Sidentity
);
5256 defsubr (&Ssafe_length
);
5257 defsubr (&Sstring_bytes
);
5258 defsubr (&Sstring_equal
);
5259 defsubr (&Scompare_strings
);
5260 defsubr (&Sstring_lessp
);
5263 defsubr (&Svconcat
);
5264 defsubr (&Scopy_sequence
);
5265 defsubr (&Sstring_make_multibyte
);
5266 defsubr (&Sstring_make_unibyte
);
5267 defsubr (&Sstring_as_multibyte
);
5268 defsubr (&Sstring_as_unibyte
);
5269 defsubr (&Scopy_alist
);
5270 defsubr (&Ssubstring
);
5282 defsubr (&Snreverse
);
5283 defsubr (&Sreverse
);
5285 defsubr (&Splist_get
);
5287 defsubr (&Splist_put
);
5290 defsubr (&Sfillarray
);
5291 defsubr (&Schar_table_subtype
);
5292 defsubr (&Schar_table_parent
);
5293 defsubr (&Sset_char_table_parent
);
5294 defsubr (&Schar_table_extra_slot
);
5295 defsubr (&Sset_char_table_extra_slot
);
5296 defsubr (&Schar_table_range
);
5297 defsubr (&Sset_char_table_range
);
5298 defsubr (&Sset_char_table_default
);
5299 defsubr (&Soptimize_char_table
);
5300 defsubr (&Smap_char_table
);
5304 defsubr (&Smapconcat
);
5305 defsubr (&Sy_or_n_p
);
5306 defsubr (&Syes_or_no_p
);
5307 defsubr (&Sload_average
);
5308 defsubr (&Sfeaturep
);
5309 defsubr (&Srequire
);
5310 defsubr (&Sprovide
);
5311 defsubr (&Splist_member
);
5312 defsubr (&Swidget_put
);
5313 defsubr (&Swidget_get
);
5314 defsubr (&Swidget_apply
);
5315 defsubr (&Sbase64_encode_region
);
5316 defsubr (&Sbase64_decode_region
);
5317 defsubr (&Sbase64_encode_string
);
5318 defsubr (&Sbase64_decode_string
);
5326 Vweak_hash_tables
= Qnil
;