1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* Note on some machines this defines `vector' as a typedef,
31 so make sure we don't use that name in this file. */
41 #include "intervals.h"
44 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
49 #define NULL (void *)0
53 #define min(a, b) ((a) < (b) ? (a) : (b))
54 #define max(a, b) ((a) > (b) ? (a) : (b))
57 /* Nonzero enables use of dialog boxes for questions
58 asked by mouse commands. */
61 extern int minibuffer_auto_raise
;
62 extern Lisp_Object minibuf_window
;
64 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
65 Lisp_Object Qyes_or_no_p_history
;
66 Lisp_Object Qcursor_in_echo_area
;
67 Lisp_Object Qwidget_type
;
69 extern Lisp_Object Qinput_method_function
;
71 static int internal_equal ();
73 extern long get_random ();
74 extern void seed_random ();
80 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
81 "Return the argument unchanged.")
88 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
89 "Return a pseudo-random number.\n\
90 All integers representable in Lisp are equally likely.\n\
91 On most systems, this is 28 bits' worth.\n\
92 With positive integer argument N, return random number in interval [0,N).\n\
93 With argument t, set the random number seed from the current time and pid.")
98 Lisp_Object lispy_val
;
99 unsigned long denominator
;
102 seed_random (getpid () + time (NULL
));
103 if (NATNUMP (n
) && XFASTINT (n
) != 0)
105 /* Try to take our random number from the higher bits of VAL,
106 not the lower, since (says Gentzel) the low bits of `random'
107 are less random than the higher ones. We do this by using the
108 quotient rather than the remainder. At the high end of the RNG
109 it's possible to get a quotient larger than n; discarding
110 these values eliminates the bias that would otherwise appear
111 when using a large n. */
112 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
114 val
= get_random () / denominator
;
115 while (val
>= XFASTINT (n
));
119 XSETINT (lispy_val
, val
);
123 /* Random data-structure functions */
125 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
126 "Return the length of vector, list or string SEQUENCE.\n\
127 A byte-code function object is also allowed.\n\
128 If the string contains multibyte characters, this is not the necessarily\n\
129 the number of bytes in the string; it is the number of characters.\n\
130 To get the number of bytes, use `string-bytes'")
132 register Lisp_Object sequence
;
134 register Lisp_Object tail
, 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)
834 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
836 this = args
[textprops
[argnum
].argnum
];
837 props
= text_property_list (this,
839 make_number (XSTRING (this)->size
),
841 /* If successive arguments have properites, be sure that the
842 value of `composition' property be the copy. */
844 && textprops
[argnum
- 1].argnum
+ 1 == textprops
[argnum
].argnum
)
845 make_composition_value_copy (props
);
846 add_text_properties_from_list (val
, props
,
847 make_number (textprops
[argnum
].to
));
853 static Lisp_Object string_char_byte_cache_string
;
854 static int string_char_byte_cache_charpos
;
855 static int string_char_byte_cache_bytepos
;
858 clear_string_char_byte_cache ()
860 string_char_byte_cache_string
= Qnil
;
863 /* Return the character index corresponding to CHAR_INDEX in STRING. */
866 string_char_to_byte (string
, char_index
)
871 int best_below
, best_below_byte
;
872 int best_above
, best_above_byte
;
874 if (! STRING_MULTIBYTE (string
))
877 best_below
= best_below_byte
= 0;
878 best_above
= XSTRING (string
)->size
;
879 best_above_byte
= STRING_BYTES (XSTRING (string
));
881 if (EQ (string
, string_char_byte_cache_string
))
883 if (string_char_byte_cache_charpos
< char_index
)
885 best_below
= string_char_byte_cache_charpos
;
886 best_below_byte
= string_char_byte_cache_bytepos
;
890 best_above
= string_char_byte_cache_charpos
;
891 best_above_byte
= string_char_byte_cache_bytepos
;
895 if (char_index
- best_below
< best_above
- char_index
)
897 while (best_below
< char_index
)
900 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
901 best_below
, best_below_byte
);
904 i_byte
= best_below_byte
;
908 while (best_above
> char_index
)
910 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
911 unsigned char *pbeg
= pend
- best_above_byte
;
912 unsigned char *p
= pend
- 1;
915 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
916 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
917 if (bytes
== pend
- p
)
918 best_above_byte
-= bytes
;
919 else if (bytes
> pend
- p
)
920 best_above_byte
-= (pend
- p
);
926 i_byte
= best_above_byte
;
929 string_char_byte_cache_bytepos
= i_byte
;
930 string_char_byte_cache_charpos
= i
;
931 string_char_byte_cache_string
= string
;
936 /* Return the character index corresponding to BYTE_INDEX in STRING. */
939 string_byte_to_char (string
, byte_index
)
944 int best_below
, best_below_byte
;
945 int best_above
, best_above_byte
;
947 if (! STRING_MULTIBYTE (string
))
950 best_below
= best_below_byte
= 0;
951 best_above
= XSTRING (string
)->size
;
952 best_above_byte
= STRING_BYTES (XSTRING (string
));
954 if (EQ (string
, string_char_byte_cache_string
))
956 if (string_char_byte_cache_bytepos
< byte_index
)
958 best_below
= string_char_byte_cache_charpos
;
959 best_below_byte
= string_char_byte_cache_bytepos
;
963 best_above
= string_char_byte_cache_charpos
;
964 best_above_byte
= string_char_byte_cache_bytepos
;
968 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
970 while (best_below_byte
< byte_index
)
973 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
974 best_below
, best_below_byte
);
977 i_byte
= best_below_byte
;
981 while (best_above_byte
> byte_index
)
983 unsigned char *pend
= XSTRING (string
)->data
+ best_above_byte
;
984 unsigned char *pbeg
= pend
- best_above_byte
;
985 unsigned char *p
= pend
- 1;
988 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
989 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
990 if (bytes
== pend
- p
)
991 best_above_byte
-= bytes
;
992 else if (bytes
> pend
- p
)
993 best_above_byte
-= (pend
- p
);
999 i_byte
= best_above_byte
;
1002 string_char_byte_cache_bytepos
= i_byte
;
1003 string_char_byte_cache_charpos
= i
;
1004 string_char_byte_cache_string
= string
;
1009 /* Convert STRING to a multibyte string.
1010 Single-byte characters 0240 through 0377 are converted
1011 by adding nonascii_insert_offset to each. */
1014 string_make_multibyte (string
)
1020 if (STRING_MULTIBYTE (string
))
1023 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
1024 XSTRING (string
)->size
);
1025 /* If all the chars are ASCII, they won't need any more bytes
1026 once converted. In that case, we can return STRING itself. */
1027 if (nbytes
== STRING_BYTES (XSTRING (string
)))
1030 buf
= (unsigned char *) alloca (nbytes
);
1031 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1034 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
1037 /* Convert STRING to a single-byte string. */
1040 string_make_unibyte (string
)
1045 if (! STRING_MULTIBYTE (string
))
1048 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
1050 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
1053 return make_unibyte_string (buf
, XSTRING (string
)->size
);
1056 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1058 "Return the multibyte equivalent of STRING.\n\
1059 The function `unibyte-char-to-multibyte' is used to convert\n\
1060 each unibyte character to a multibyte character.")
1064 CHECK_STRING (string
, 0);
1066 return string_make_multibyte (string
);
1069 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1071 "Return the unibyte equivalent of STRING.\n\
1072 Multibyte character codes are converted to unibyte\n\
1073 by using just the low 8 bits.")
1077 CHECK_STRING (string
, 0);
1079 return string_make_unibyte (string
);
1082 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1084 "Return a unibyte string with the same individual bytes as STRING.\n\
1085 If STRING is unibyte, the result is STRING itself.\n\
1086 Otherwise it is a newly created string, with no text properties.\n\
1087 If STRING is multibyte and contains a character of charset\n\
1088 `eight-bit-control' or `eight-bit-graphic', it is converted to the\n\
1089 corresponding single byte.")
1093 CHECK_STRING (string
, 0);
1095 if (STRING_MULTIBYTE (string
))
1097 int bytes
= STRING_BYTES (XSTRING (string
));
1098 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1100 bcopy (XSTRING (string
)->data
, str
, bytes
);
1101 bytes
= str_as_unibyte (str
, bytes
);
1102 string
= make_unibyte_string (str
, bytes
);
1108 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1110 "Return a multibyte string with the same individual bytes as STRING.\n\
1111 If STRING is multibyte, the result is STRING itself.\n\
1112 Otherwise it is a newly created string, with no text properties.\n\
1113 If STRING is unibyte and contains an individual 8-bit byte (i.e. not\n\
1114 part of a multibyte form), it is converted to the corresponding\n\
1115 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.")
1119 CHECK_STRING (string
, 0);
1121 if (! STRING_MULTIBYTE (string
))
1123 Lisp_Object new_string
;
1126 parse_str_as_multibyte (XSTRING (string
)->data
,
1127 STRING_BYTES (XSTRING (string
)),
1129 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1130 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1131 STRING_BYTES (XSTRING (string
)));
1132 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1133 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1134 STRING_BYTES (XSTRING (string
)), NULL
);
1135 string
= new_string
;
1136 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1141 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1142 "Return a copy of ALIST.\n\
1143 This is an alist which represents the same mapping from objects to objects,\n\
1144 but does not share the alist structure with ALIST.\n\
1145 The objects mapped (cars and cdrs of elements of the alist)\n\
1146 are shared, however.\n\
1147 Elements of ALIST that are not conses are also shared.")
1151 register Lisp_Object tem
;
1153 CHECK_LIST (alist
, 0);
1156 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1157 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1159 register Lisp_Object car
;
1163 XCAR (tem
) = Fcons (XCAR (car
), XCDR (car
));
1168 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1169 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1170 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1171 If FROM or TO is negative, it counts from the end.\n\
1173 This function allows vectors as well as strings.")
1176 register Lisp_Object from
, to
;
1181 int from_char
, to_char
;
1182 int from_byte
= 0, to_byte
= 0;
1184 if (! (STRINGP (string
) || VECTORP (string
)))
1185 wrong_type_argument (Qarrayp
, string
);
1187 CHECK_NUMBER (from
, 1);
1189 if (STRINGP (string
))
1191 size
= XSTRING (string
)->size
;
1192 size_byte
= STRING_BYTES (XSTRING (string
));
1195 size
= XVECTOR (string
)->size
;
1200 to_byte
= size_byte
;
1204 CHECK_NUMBER (to
, 2);
1206 to_char
= XINT (to
);
1210 if (STRINGP (string
))
1211 to_byte
= string_char_to_byte (string
, to_char
);
1214 from_char
= XINT (from
);
1217 if (STRINGP (string
))
1218 from_byte
= string_char_to_byte (string
, from_char
);
1220 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1221 args_out_of_range_3 (string
, make_number (from_char
),
1222 make_number (to_char
));
1224 if (STRINGP (string
))
1226 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1227 to_char
- from_char
, to_byte
- from_byte
,
1228 STRING_MULTIBYTE (string
));
1229 copy_text_properties (make_number (from_char
), make_number (to_char
),
1230 string
, make_number (0), res
, Qnil
);
1233 res
= Fvector (to_char
- from_char
,
1234 XVECTOR (string
)->contents
+ from_char
);
1239 /* Extract a substring of STRING, giving start and end positions
1240 both in characters and in bytes. */
1243 substring_both (string
, from
, from_byte
, to
, to_byte
)
1245 int from
, from_byte
, to
, to_byte
;
1251 if (! (STRINGP (string
) || VECTORP (string
)))
1252 wrong_type_argument (Qarrayp
, string
);
1254 if (STRINGP (string
))
1256 size
= XSTRING (string
)->size
;
1257 size_byte
= STRING_BYTES (XSTRING (string
));
1260 size
= XVECTOR (string
)->size
;
1262 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1263 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1265 if (STRINGP (string
))
1267 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1268 to
- from
, to_byte
- from_byte
,
1269 STRING_MULTIBYTE (string
));
1270 copy_text_properties (make_number (from
), make_number (to
),
1271 string
, make_number (0), res
, Qnil
);
1274 res
= Fvector (to
- from
,
1275 XVECTOR (string
)->contents
+ from
);
1280 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1281 "Take cdr N times on LIST, returns the result.")
1284 register Lisp_Object list
;
1286 register int i
, num
;
1287 CHECK_NUMBER (n
, 0);
1289 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1293 wrong_type_argument (Qlistp
, list
);
1299 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1300 "Return the Nth element of LIST.\n\
1301 N counts from zero. If LIST is not that long, nil is returned.")
1303 Lisp_Object n
, list
;
1305 return Fcar (Fnthcdr (n
, list
));
1308 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1309 "Return element of SEQUENCE at index N.")
1311 register Lisp_Object sequence
, n
;
1313 CHECK_NUMBER (n
, 0);
1316 if (CONSP (sequence
) || NILP (sequence
))
1317 return Fcar (Fnthcdr (n
, sequence
));
1318 else if (STRINGP (sequence
) || VECTORP (sequence
)
1319 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1320 return Faref (sequence
, n
);
1322 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1326 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1327 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1328 The value is actually the tail of LIST whose car is ELT.")
1330 register Lisp_Object elt
;
1333 register Lisp_Object tail
;
1334 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1336 register Lisp_Object tem
;
1338 wrong_type_argument (Qlistp
, list
);
1340 if (! NILP (Fequal (elt
, tem
)))
1347 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1348 "Return non-nil if ELT is an element of LIST.\n\
1349 Comparison done with EQ. The value is actually the tail of LIST\n\
1352 Lisp_Object elt
, list
;
1356 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1360 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1364 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1371 if (!CONSP (list
) && !NILP (list
))
1372 list
= wrong_type_argument (Qlistp
, list
);
1377 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1378 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1379 The value is actually the element of LIST whose car is KEY.\n\
1380 Elements of LIST that are not conses are ignored.")
1382 Lisp_Object key
, list
;
1389 || (CONSP (XCAR (list
))
1390 && EQ (XCAR (XCAR (list
)), key
)))
1395 || (CONSP (XCAR (list
))
1396 && EQ (XCAR (XCAR (list
)), key
)))
1401 || (CONSP (XCAR (list
))
1402 && EQ (XCAR (XCAR (list
)), key
)))
1410 result
= XCAR (list
);
1411 else if (NILP (list
))
1414 result
= wrong_type_argument (Qlistp
, list
);
1419 /* Like Fassq but never report an error and do not allow quits.
1420 Use only on lists known never to be circular. */
1423 assq_no_quit (key
, list
)
1424 Lisp_Object key
, list
;
1427 && (!CONSP (XCAR (list
))
1428 || !EQ (XCAR (XCAR (list
)), key
)))
1431 return CONSP (list
) ? XCAR (list
) : Qnil
;
1434 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1435 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1436 The value is actually the element of LIST whose car equals KEY.")
1438 Lisp_Object key
, list
;
1440 Lisp_Object result
, car
;
1445 || (CONSP (XCAR (list
))
1446 && (car
= XCAR (XCAR (list
)),
1447 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1452 || (CONSP (XCAR (list
))
1453 && (car
= XCAR (XCAR (list
)),
1454 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1459 || (CONSP (XCAR (list
))
1460 && (car
= XCAR (XCAR (list
)),
1461 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1469 result
= XCAR (list
);
1470 else if (NILP (list
))
1473 result
= wrong_type_argument (Qlistp
, list
);
1478 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1479 "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
1480 The value is actually the element of LIST whose cdr is KEY.")
1482 register Lisp_Object key
;
1490 || (CONSP (XCAR (list
))
1491 && EQ (XCDR (XCAR (list
)), key
)))
1496 || (CONSP (XCAR (list
))
1497 && EQ (XCDR (XCAR (list
)), key
)))
1502 || (CONSP (XCAR (list
))
1503 && EQ (XCDR (XCAR (list
)), key
)))
1512 else if (CONSP (list
))
1513 result
= XCAR (list
);
1515 result
= wrong_type_argument (Qlistp
, list
);
1520 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1521 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1522 The value is actually the element of LIST whose cdr equals KEY.")
1524 Lisp_Object key
, list
;
1526 Lisp_Object result
, cdr
;
1531 || (CONSP (XCAR (list
))
1532 && (cdr
= XCDR (XCAR (list
)),
1533 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1538 || (CONSP (XCAR (list
))
1539 && (cdr
= XCDR (XCAR (list
)),
1540 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1545 || (CONSP (XCAR (list
))
1546 && (cdr
= XCDR (XCAR (list
)),
1547 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1555 result
= XCAR (list
);
1556 else if (NILP (list
))
1559 result
= wrong_type_argument (Qlistp
, list
);
1564 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1565 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1566 The modified LIST is returned. Comparison is done with `eq'.\n\
1567 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1568 therefore, write `(setq foo (delq element foo))'\n\
1569 to be sure of changing the value of `foo'.")
1571 register Lisp_Object elt
;
1574 register Lisp_Object tail
, prev
;
1575 register Lisp_Object tem
;
1579 while (!NILP (tail
))
1582 wrong_type_argument (Qlistp
, list
);
1589 Fsetcdr (prev
, XCDR (tail
));
1599 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1600 "Delete by side effect any occurrences of ELT as a member of SEQ.\n\
1601 SEQ must be a list, a vector, or a string.\n\
1602 The modified SEQ is returned. Comparison is done with `equal'.\n\
1603 If SEQ is not a list, or the first member of SEQ is ELT, deleting it\n\
1604 is not a side effect; it is simply using a different sequence.\n\
1605 Therefore, write `(setq foo (delete element foo))'\n\
1606 to be sure of changing the value of `foo'.")
1608 Lisp_Object elt
, seq
;
1612 EMACS_INT i
, n
, size
;
1614 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1615 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1618 if (n
!= ASIZE (seq
))
1620 struct Lisp_Vector
*p
= allocate_vectorlike (n
);
1622 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1623 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1624 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
;
2355 if (! SUB_CHAR_TABLE_P (char_table
))
2356 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2357 = make_sub_char_table (temp
));
2358 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2359 if (SUB_CHAR_TABLE_P (temp
))
2360 XCHAR_TABLE (temp
)->defalt
= value
;
2362 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2366 /* Look up the element in TABLE at index CH,
2367 and return it as an integer.
2368 If the element is nil, return CH itself.
2369 (Actually we do that for any non-integer.) */
2372 char_table_translate (table
, ch
)
2377 value
= Faref (table
, make_number (ch
));
2378 if (! INTEGERP (value
))
2380 return XINT (value
);
2384 optimize_sub_char_table (table
, chars
)
2392 from
= 33, to
= 127;
2394 from
= 32, to
= 128;
2396 if (!SUB_CHAR_TABLE_P (*table
))
2398 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2399 for (; from
< to
; from
++)
2400 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2405 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2407 "Optimize char table TABLE.")
2415 CHECK_CHAR_TABLE (table
, 0);
2417 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2419 elt
= XCHAR_TABLE (table
)->contents
[i
];
2420 if (!SUB_CHAR_TABLE_P (elt
))
2422 dim
= CHARSET_DIMENSION (i
- 128);
2424 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2425 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2426 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2432 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2433 character or group of characters that share a value.
2434 DEPTH is the current depth in the originally specified
2435 chartable, and INDICES contains the vector indices
2436 for the levels our callers have descended.
2438 ARG is passed to C_FUNCTION when that is called. */
2441 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2442 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2443 Lisp_Object function
, subtable
, arg
, *indices
;
2450 /* At first, handle ASCII and 8-bit European characters. */
2451 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2453 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2455 (*c_function
) (arg
, make_number (i
), elt
);
2457 call2 (function
, make_number (i
), elt
);
2459 #if 0 /* If the char table has entries for higher characters,
2460 we should report them. */
2461 if (NILP (current_buffer
->enable_multibyte_characters
))
2464 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2468 int charset
= XFASTINT (indices
[0]) - 128;
2471 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2472 if (CHARSET_CHARS (charset
) == 94)
2481 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2482 XSETFASTINT (indices
[depth
], i
);
2483 charset
= XFASTINT (indices
[0]) - 128;
2485 && (!CHARSET_DEFINED_P (charset
)
2486 || charset
== CHARSET_8_BIT_CONTROL
2487 || charset
== CHARSET_8_BIT_GRAPHIC
))
2490 if (SUB_CHAR_TABLE_P (elt
))
2493 error ("Too deep char table");
2494 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2501 elt
= XCHAR_TABLE (subtable
)->defalt
;
2502 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2503 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2504 c
= MAKE_CHAR (charset
, c1
, c2
);
2506 (*c_function
) (arg
, make_number (c
), elt
);
2508 call2 (function
, make_number (c
), elt
);
2513 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2515 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2516 FUNCTION is called with two arguments--a key and a value.\n\
2517 The key is always a possible IDX argument to `aref'.")
2518 (function
, char_table
)
2519 Lisp_Object function
, char_table
;
2521 /* The depth of char table is at most 3. */
2522 Lisp_Object indices
[3];
2524 CHECK_CHAR_TABLE (char_table
, 1);
2526 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2530 /* Return a value for character C in char-table TABLE. Store the
2531 actual index for that value in *IDX. Ignore the default value of
2535 char_table_ref_and_index (table
, c
, idx
)
2539 int charset
, c1
, c2
;
2542 if (SINGLE_BYTE_CHAR_P (c
))
2545 return XCHAR_TABLE (table
)->contents
[c
];
2547 SPLIT_CHAR (c
, charset
, c1
, c2
);
2548 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2549 *idx
= MAKE_CHAR (charset
, 0, 0);
2550 if (!SUB_CHAR_TABLE_P (elt
))
2552 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2553 return XCHAR_TABLE (elt
)->defalt
;
2554 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2555 *idx
= MAKE_CHAR (charset
, c1
, 0);
2556 if (!SUB_CHAR_TABLE_P (elt
))
2558 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2559 return XCHAR_TABLE (elt
)->defalt
;
2561 return XCHAR_TABLE (elt
)->contents
[c2
];
2571 Lisp_Object args
[2];
2574 return Fnconc (2, args
);
2576 return Fnconc (2, &s1
);
2577 #endif /* NO_ARG_ARRAY */
2580 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2581 "Concatenate any number of lists by altering them.\n\
2582 Only the last argument is not altered, and need not be a list.")
2587 register int argnum
;
2588 register Lisp_Object tail
, tem
, val
;
2592 for (argnum
= 0; argnum
< nargs
; argnum
++)
2595 if (NILP (tem
)) continue;
2600 if (argnum
+ 1 == nargs
) break;
2603 tem
= wrong_type_argument (Qlistp
, tem
);
2612 tem
= args
[argnum
+ 1];
2613 Fsetcdr (tail
, tem
);
2615 args
[argnum
+ 1] = tail
;
2621 /* This is the guts of all mapping functions.
2622 Apply FN to each element of SEQ, one by one,
2623 storing the results into elements of VALS, a C vector of Lisp_Objects.
2624 LENI is the length of VALS, which should also be the length of SEQ. */
2627 mapcar1 (leni
, vals
, fn
, seq
)
2630 Lisp_Object fn
, seq
;
2632 register Lisp_Object tail
;
2635 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2639 /* Don't let vals contain any garbage when GC happens. */
2640 for (i
= 0; i
< leni
; i
++)
2643 GCPRO3 (dummy
, fn
, seq
);
2645 gcpro1
.nvars
= leni
;
2649 /* We need not explicitly protect `tail' because it is used only on lists, and
2650 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2654 for (i
= 0; i
< leni
; i
++)
2656 dummy
= XVECTOR (seq
)->contents
[i
];
2657 dummy
= call1 (fn
, dummy
);
2662 else if (BOOL_VECTOR_P (seq
))
2664 for (i
= 0; i
< leni
; i
++)
2667 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2668 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2673 dummy
= call1 (fn
, dummy
);
2678 else if (STRINGP (seq
))
2682 for (i
= 0, i_byte
= 0; i
< leni
;)
2687 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2688 XSETFASTINT (dummy
, c
);
2689 dummy
= call1 (fn
, dummy
);
2691 vals
[i_before
] = dummy
;
2694 else /* Must be a list, since Flength did not get an error */
2697 for (i
= 0; i
< leni
; i
++)
2699 dummy
= call1 (fn
, Fcar (tail
));
2709 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2710 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2711 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2712 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2713 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2714 (function
, sequence
, separator
)
2715 Lisp_Object function
, sequence
, separator
;
2720 register Lisp_Object
*args
;
2722 struct gcpro gcpro1
;
2724 len
= Flength (sequence
);
2726 nargs
= leni
+ leni
- 1;
2727 if (nargs
< 0) return build_string ("");
2729 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2732 mapcar1 (leni
, args
, function
, sequence
);
2735 for (i
= leni
- 1; i
>= 0; i
--)
2736 args
[i
+ i
] = args
[i
];
2738 for (i
= 1; i
< nargs
; i
+= 2)
2739 args
[i
] = separator
;
2741 return Fconcat (nargs
, args
);
2744 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2745 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2746 The result is a list just as long as SEQUENCE.\n\
2747 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2748 (function
, sequence
)
2749 Lisp_Object function
, sequence
;
2751 register Lisp_Object len
;
2753 register Lisp_Object
*args
;
2755 len
= Flength (sequence
);
2756 leni
= XFASTINT (len
);
2757 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2759 mapcar1 (leni
, args
, function
, sequence
);
2761 return Flist (leni
, args
);
2764 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2765 "Apply FUNCTION to each element of SEQUENCE for side effects only.\n\
2766 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.\n\
2767 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2768 (function
, sequence
)
2769 Lisp_Object function
, sequence
;
2773 leni
= XFASTINT (Flength (sequence
));
2774 mapcar1 (leni
, 0, function
, sequence
);
2779 /* Anything that calls this function must protect from GC! */
2781 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2782 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2783 Takes one argument, which is the string to display to ask the question.\n\
2784 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2785 No confirmation of the answer is requested; a single character is enough.\n\
2786 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
2787 the bindings in `query-replace-map'; see the documentation of that variable\n\
2788 for more information. In this case, the useful bindings are `act', `skip',\n\
2789 `recenter', and `quit'.\)\n\
2791 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2792 is nil and `use-dialog-box' is non-nil.")
2796 register Lisp_Object obj
, key
, def
, map
;
2797 register int answer
;
2798 Lisp_Object xprompt
;
2799 Lisp_Object args
[2];
2800 struct gcpro gcpro1
, gcpro2
;
2801 int count
= specpdl_ptr
- specpdl
;
2803 specbind (Qcursor_in_echo_area
, Qt
);
2805 map
= Fsymbol_value (intern ("query-replace-map"));
2807 CHECK_STRING (prompt
, 0);
2809 GCPRO2 (prompt
, xprompt
);
2811 #ifdef HAVE_X_WINDOWS
2812 if (display_busy_cursor_p
)
2813 cancel_busy_cursor ();
2820 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2824 Lisp_Object pane
, menu
;
2825 redisplay_preserve_echo_area ();
2826 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2827 Fcons (Fcons (build_string ("No"), Qnil
),
2829 menu
= Fcons (prompt
, pane
);
2830 obj
= Fx_popup_dialog (Qt
, menu
);
2831 answer
= !NILP (obj
);
2834 #endif /* HAVE_MENUS */
2835 cursor_in_echo_area
= 1;
2836 choose_minibuf_frame ();
2837 message_with_string ("%s(y or n) ", xprompt
, 0);
2839 if (minibuffer_auto_raise
)
2841 Lisp_Object mini_frame
;
2843 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2845 Fraise_frame (mini_frame
);
2848 obj
= read_filtered_event (1, 0, 0, 0);
2849 cursor_in_echo_area
= 0;
2850 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2853 key
= Fmake_vector (make_number (1), obj
);
2854 def
= Flookup_key (map
, key
, Qt
);
2856 if (EQ (def
, intern ("skip")))
2861 else if (EQ (def
, intern ("act")))
2866 else if (EQ (def
, intern ("recenter")))
2872 else if (EQ (def
, intern ("quit")))
2874 /* We want to exit this command for exit-prefix,
2875 and this is the only way to do it. */
2876 else if (EQ (def
, intern ("exit-prefix")))
2881 /* If we don't clear this, then the next call to read_char will
2882 return quit_char again, and we'll enter an infinite loop. */
2887 if (EQ (xprompt
, prompt
))
2889 args
[0] = build_string ("Please answer y or n. ");
2891 xprompt
= Fconcat (2, args
);
2896 if (! noninteractive
)
2898 cursor_in_echo_area
= -1;
2899 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2903 unbind_to (count
, Qnil
);
2904 return answer
? Qt
: Qnil
;
2907 /* This is how C code calls `yes-or-no-p' and allows the user
2910 Anything that calls this function must protect from GC! */
2913 do_yes_or_no_p (prompt
)
2916 return call1 (intern ("yes-or-no-p"), prompt
);
2919 /* Anything that calls this function must protect from GC! */
2921 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2922 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2923 Takes one argument, which is the string to display to ask the question.\n\
2924 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2925 The user must confirm the answer with RET,\n\
2926 and can edit it until it has been confirmed.\n\
2928 Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
2929 is nil, and `use-dialog-box' is non-nil.")
2933 register Lisp_Object ans
;
2934 Lisp_Object args
[2];
2935 struct gcpro gcpro1
;
2937 CHECK_STRING (prompt
, 0);
2940 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2944 Lisp_Object pane
, menu
, obj
;
2945 redisplay_preserve_echo_area ();
2946 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2947 Fcons (Fcons (build_string ("No"), Qnil
),
2950 menu
= Fcons (prompt
, pane
);
2951 obj
= Fx_popup_dialog (Qt
, menu
);
2955 #endif /* HAVE_MENUS */
2958 args
[1] = build_string ("(yes or no) ");
2959 prompt
= Fconcat (2, args
);
2965 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2966 Qyes_or_no_p_history
, Qnil
,
2968 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2973 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2981 message ("Please answer yes or no.");
2982 Fsleep_for (make_number (2), Qnil
);
2986 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2987 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2988 Each of the three load averages is multiplied by 100,\n\
2989 then converted to integer.\n\
2990 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2991 These floats are not multiplied by 100.\n\n\
2992 If the 5-minute or 15-minute load averages are not available, return a\n\
2993 shortened list, containing only those averages which are available.")
2995 Lisp_Object use_floats
;
2998 int loads
= getloadavg (load_ave
, 3);
2999 Lisp_Object ret
= Qnil
;
3002 error ("load-average not implemented for this operating system");
3006 Lisp_Object load
= (NILP (use_floats
) ?
3007 make_number ((int) (100.0 * load_ave
[loads
]))
3008 : make_float (load_ave
[loads
]));
3009 ret
= Fcons (load
, ret
);
3015 Lisp_Object Vfeatures
;
3017 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
3018 "Returns t if FEATURE is present in this Emacs.\n\
3019 Use this to conditionalize execution of lisp code based on the presence or\n\
3020 absence of emacs or environment extensions.\n\
3021 Use `provide' to declare that a feature is available.\n\
3022 This function looks at the value of the variable `features'.")
3024 Lisp_Object feature
;
3026 register Lisp_Object tem
;
3027 CHECK_SYMBOL (feature
, 0);
3028 tem
= Fmemq (feature
, Vfeatures
);
3029 return (NILP (tem
)) ? Qnil
: Qt
;
3032 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
3033 "Announce that FEATURE is a feature of the current Emacs.")
3035 Lisp_Object feature
;
3037 register Lisp_Object tem
;
3038 CHECK_SYMBOL (feature
, 0);
3039 if (!NILP (Vautoload_queue
))
3040 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3041 tem
= Fmemq (feature
, Vfeatures
);
3043 Vfeatures
= Fcons (feature
, Vfeatures
);
3044 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3048 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3049 "If feature FEATURE is not loaded, load it from FILENAME.\n\
3050 If FEATURE is not a member of the list `features', then the feature\n\
3051 is not loaded; so load the file FILENAME.\n\
3052 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
3053 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
3054 If the optional third argument NOERROR is non-nil,\n\
3055 then return nil if the file is not found.\n\
3056 Normally the return value is FEATURE.")
3057 (feature
, file_name
, noerror
)
3058 Lisp_Object feature
, file_name
, noerror
;
3060 register Lisp_Object tem
;
3061 CHECK_SYMBOL (feature
, 0);
3062 tem
= Fmemq (feature
, Vfeatures
);
3064 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3068 int count
= specpdl_ptr
- specpdl
;
3070 /* Value saved here is to be restored into Vautoload_queue */
3071 record_unwind_protect (un_autoload
, Vautoload_queue
);
3072 Vautoload_queue
= Qt
;
3074 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
3075 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
3076 /* If load failed entirely, return nil. */
3078 return unbind_to (count
, Qnil
);
3080 tem
= Fmemq (feature
, Vfeatures
);
3082 error ("Required feature %s was not provided",
3083 XSYMBOL (feature
)->name
->data
);
3085 /* Once loading finishes, don't undo it. */
3086 Vautoload_queue
= Qt
;
3087 feature
= unbind_to (count
, feature
);
3092 /* Primitives for work of the "widget" library.
3093 In an ideal world, this section would not have been necessary.
3094 However, lisp function calls being as slow as they are, it turns
3095 out that some functions in the widget library (wid-edit.el) are the
3096 bottleneck of Widget operation. Here is their translation to C,
3097 for the sole reason of efficiency. */
3099 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3100 "Return non-nil if PLIST has the property PROP.\n\
3101 PLIST is a property list, which is a list of the form\n\
3102 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
3103 Unlike `plist-get', this allows you to distinguish between a missing\n\
3104 property and a property with the value nil.\n\
3105 The value is actually the tail of PLIST whose car is PROP.")
3107 Lisp_Object plist
, prop
;
3109 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3112 plist
= XCDR (plist
);
3113 plist
= CDR (plist
);
3118 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3119 "In WIDGET, set PROPERTY to VALUE.\n\
3120 The value can later be retrieved with `widget-get'.")
3121 (widget
, property
, value
)
3122 Lisp_Object widget
, property
, value
;
3124 CHECK_CONS (widget
, 1);
3125 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
3129 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3130 "In WIDGET, get the value of PROPERTY.\n\
3131 The value could either be specified when the widget was created, or\n\
3132 later with `widget-put'.")
3134 Lisp_Object widget
, property
;
3142 CHECK_CONS (widget
, 1);
3143 tmp
= Fplist_member (XCDR (widget
), property
);
3149 tmp
= XCAR (widget
);
3152 widget
= Fget (tmp
, Qwidget_type
);
3156 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3157 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
3158 ARGS are passed as extra arguments to the function.")
3163 /* This function can GC. */
3164 Lisp_Object newargs
[3];
3165 struct gcpro gcpro1
, gcpro2
;
3168 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3169 newargs
[1] = args
[0];
3170 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3171 GCPRO2 (newargs
[0], newargs
[2]);
3172 result
= Fapply (3, newargs
);
3177 /* base64 encode/decode functions (RFC 2045).
3178 Based on code from GNU recode. */
3180 #define MIME_LINE_LENGTH 76
3182 #define IS_ASCII(Character) \
3184 #define IS_BASE64(Character) \
3185 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3186 #define IS_BASE64_IGNORABLE(Character) \
3187 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3188 || (Character) == '\f' || (Character) == '\r')
3190 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3191 character or return retval if there are no characters left to
3193 #define READ_QUADRUPLET_BYTE(retval) \
3198 if (nchars_return) \
3199 *nchars_return = nchars; \
3204 while (IS_BASE64_IGNORABLE (c))
3206 /* Don't use alloca for regions larger than this, lest we overflow
3208 #define MAX_ALLOCA 16*1024
3210 /* Table of characters coding the 64 values. */
3211 static char base64_value_to_char
[64] =
3213 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3214 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3215 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3216 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3217 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3218 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3219 '8', '9', '+', '/' /* 60-63 */
3222 /* Table of base64 values for first 128 characters. */
3223 static short base64_char_to_value
[128] =
3225 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3226 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3227 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3228 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3229 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3230 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3231 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3232 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3233 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3234 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3235 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3236 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3237 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3240 /* The following diagram shows the logical steps by which three octets
3241 get transformed into four base64 characters.
3243 .--------. .--------. .--------.
3244 |aaaaaabb| |bbbbcccc| |ccdddddd|
3245 `--------' `--------' `--------'
3247 .--------+--------+--------+--------.
3248 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3249 `--------+--------+--------+--------'
3251 .--------+--------+--------+--------.
3252 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3253 `--------+--------+--------+--------'
3255 The octets are divided into 6 bit chunks, which are then encoded into
3256 base64 characters. */
3259 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3260 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3262 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3264 "Base64-encode the region between BEG and END.\n\
3265 Return the length of the encoded text.\n\
3266 Optional third argument NO-LINE-BREAK means do not break long lines\n\
3267 into shorter lines.")
3268 (beg
, end
, no_line_break
)
3269 Lisp_Object beg
, end
, no_line_break
;
3272 int allength
, length
;
3273 int ibeg
, iend
, encoded_length
;
3276 validate_region (&beg
, &end
);
3278 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3279 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3280 move_gap_both (XFASTINT (beg
), ibeg
);
3282 /* We need to allocate enough room for encoding the text.
3283 We need 33 1/3% more space, plus a newline every 76
3284 characters, and then we round up. */
3285 length
= iend
- ibeg
;
3286 allength
= length
+ length
/3 + 1;
3287 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3289 if (allength
<= MAX_ALLOCA
)
3290 encoded
= (char *) alloca (allength
);
3292 encoded
= (char *) xmalloc (allength
);
3293 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3294 NILP (no_line_break
),
3295 !NILP (current_buffer
->enable_multibyte_characters
));
3296 if (encoded_length
> allength
)
3299 if (encoded_length
< 0)
3301 /* The encoding wasn't possible. */
3302 if (length
> MAX_ALLOCA
)
3304 error ("Multibyte character in data for base64 encoding");
3307 /* Now we have encoded the region, so we insert the new contents
3308 and delete the old. (Insert first in order to preserve markers.) */
3309 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3310 insert (encoded
, encoded_length
);
3311 if (allength
> MAX_ALLOCA
)
3313 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3315 /* If point was outside of the region, restore it exactly; else just
3316 move to the beginning of the region. */
3317 if (old_pos
>= XFASTINT (end
))
3318 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3319 else if (old_pos
> XFASTINT (beg
))
3320 old_pos
= XFASTINT (beg
);
3323 /* We return the length of the encoded text. */
3324 return make_number (encoded_length
);
3327 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3329 "Base64-encode STRING and return the result.\n\
3330 Optional second argument NO-LINE-BREAK means do not break long lines\n\
3331 into shorter lines.")
3332 (string
, no_line_break
)
3333 Lisp_Object string
, no_line_break
;
3335 int allength
, length
, encoded_length
;
3337 Lisp_Object encoded_string
;
3339 CHECK_STRING (string
, 1);
3341 /* We need to allocate enough room for encoding the text.
3342 We need 33 1/3% more space, plus a newline every 76
3343 characters, and then we round up. */
3344 length
= STRING_BYTES (XSTRING (string
));
3345 allength
= length
+ length
/3 + 1;
3346 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3348 /* We need to allocate enough room for decoding the text. */
3349 if (allength
<= MAX_ALLOCA
)
3350 encoded
= (char *) alloca (allength
);
3352 encoded
= (char *) xmalloc (allength
);
3354 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
3355 encoded
, length
, NILP (no_line_break
),
3356 STRING_MULTIBYTE (string
));
3357 if (encoded_length
> allength
)
3360 if (encoded_length
< 0)
3362 /* The encoding wasn't possible. */
3363 if (length
> MAX_ALLOCA
)
3365 error ("Multibyte character in data for base64 encoding");
3368 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3369 if (allength
> MAX_ALLOCA
)
3372 return encoded_string
;
3376 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3383 int counter
= 0, i
= 0;
3393 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3401 /* Wrap line every 76 characters. */
3405 if (counter
< MIME_LINE_LENGTH
/ 4)
3414 /* Process first byte of a triplet. */
3416 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3417 value
= (0x03 & c
) << 4;
3419 /* Process second byte of a triplet. */
3423 *e
++ = base64_value_to_char
[value
];
3431 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3439 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3440 value
= (0x0f & c
) << 2;
3442 /* Process third byte of a triplet. */
3446 *e
++ = base64_value_to_char
[value
];
3453 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3461 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3462 *e
++ = base64_value_to_char
[0x3f & c
];
3469 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3471 "Base64-decode the region between BEG and END.\n\
3472 Return the length of the decoded text.\n\
3473 If the region can't be decoded, signal an error and don't modify the buffer.")
3475 Lisp_Object beg
, end
;
3477 int ibeg
, iend
, length
, allength
;
3482 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3484 validate_region (&beg
, &end
);
3486 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3487 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3489 length
= iend
- ibeg
;
3491 /* We need to allocate enough room for decoding the text. If we are
3492 working on a multibyte buffer, each decoded code may occupy at
3494 allength
= multibyte
? length
* 2 : length
;
3495 if (allength
<= MAX_ALLOCA
)
3496 decoded
= (char *) alloca (allength
);
3498 decoded
= (char *) xmalloc (allength
);
3500 move_gap_both (XFASTINT (beg
), ibeg
);
3501 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3502 multibyte
, &inserted_chars
);
3503 if (decoded_length
> allength
)
3506 if (decoded_length
< 0)
3508 /* The decoding wasn't possible. */
3509 if (allength
> MAX_ALLOCA
)
3511 error ("Invalid base64 data");
3514 /* Now we have decoded the region, so we insert the new contents
3515 and delete the old. (Insert first in order to preserve markers.) */
3516 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3517 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3518 if (allength
> MAX_ALLOCA
)
3520 /* Delete the original text. */
3521 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3522 iend
+ decoded_length
, 1);
3524 /* If point was outside of the region, restore it exactly; else just
3525 move to the beginning of the region. */
3526 if (old_pos
>= XFASTINT (end
))
3527 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3528 else if (old_pos
> XFASTINT (beg
))
3529 old_pos
= XFASTINT (beg
);
3530 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3532 return make_number (inserted_chars
);
3535 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3537 "Base64-decode STRING and return the result.")
3542 int length
, decoded_length
;
3543 Lisp_Object decoded_string
;
3545 CHECK_STRING (string
, 1);
3547 length
= STRING_BYTES (XSTRING (string
));
3548 /* We need to allocate enough room for decoding the text. */
3549 if (length
<= MAX_ALLOCA
)
3550 decoded
= (char *) alloca (length
);
3552 decoded
= (char *) xmalloc (length
);
3554 /* The decoded result should be unibyte. */
3555 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3557 if (decoded_length
> length
)
3559 else if (decoded_length
>= 0)
3560 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3562 decoded_string
= Qnil
;
3564 if (length
> MAX_ALLOCA
)
3566 if (!STRINGP (decoded_string
))
3567 error ("Invalid base64 data");
3569 return decoded_string
;
3572 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3573 MULTIBYTE is nonzero, the decoded result should be in multibyte
3574 form. If NCHARS_RETRUN is not NULL, store the number of produced
3575 characters in *NCHARS_RETURN. */
3578 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3588 unsigned long value
;
3593 /* Process first byte of a quadruplet. */
3595 READ_QUADRUPLET_BYTE (e
-to
);
3599 value
= base64_char_to_value
[c
] << 18;
3601 /* Process second byte of a quadruplet. */
3603 READ_QUADRUPLET_BYTE (-1);
3607 value
|= base64_char_to_value
[c
] << 12;
3609 c
= (unsigned char) (value
>> 16);
3611 e
+= CHAR_STRING (c
, e
);
3616 /* Process third byte of a quadruplet. */
3618 READ_QUADRUPLET_BYTE (-1);
3622 READ_QUADRUPLET_BYTE (-1);
3631 value
|= base64_char_to_value
[c
] << 6;
3633 c
= (unsigned char) (0xff & value
>> 8);
3635 e
+= CHAR_STRING (c
, e
);
3640 /* Process fourth byte of a quadruplet. */
3642 READ_QUADRUPLET_BYTE (-1);
3649 value
|= base64_char_to_value
[c
];
3651 c
= (unsigned char) (0xff & value
);
3653 e
+= CHAR_STRING (c
, e
);
3662 /***********************************************************************
3664 ***** Hash Tables *****
3666 ***********************************************************************/
3668 /* Implemented by gerd@gnu.org. This hash table implementation was
3669 inspired by CMUCL hash tables. */
3673 1. For small tables, association lists are probably faster than
3674 hash tables because they have lower overhead.
3676 For uses of hash tables where the O(1) behavior of table
3677 operations is not a requirement, it might therefore be a good idea
3678 not to hash. Instead, we could just do a linear search in the
3679 key_and_value vector of the hash table. This could be done
3680 if a `:linear-search t' argument is given to make-hash-table. */
3683 /* Value is the key part of entry IDX in hash table H. */
3685 #define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
3687 /* Value is the value part of entry IDX in hash table H. */
3689 #define HASH_VALUE(H, IDX) AREF ((H)->key_and_value, 2 * (IDX) + 1)
3691 /* Value is the index of the next entry following the one at IDX
3694 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3696 /* Value is the hash code computed for entry IDX in hash table H. */
3698 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3700 /* Value is the index of the element in hash table H that is the
3701 start of the collision list at index IDX in the index vector of H. */
3703 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3705 /* Value is the size of hash table H. */
3707 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3709 /* The list of all weak hash tables. Don't staticpro this one. */
3711 Lisp_Object Vweak_hash_tables
;
3713 /* Various symbols. */
3715 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3716 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3717 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3719 /* Function prototypes. */
3721 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3722 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3723 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3724 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3725 Lisp_Object
, unsigned));
3726 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3727 Lisp_Object
, unsigned));
3728 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3729 unsigned, Lisp_Object
, unsigned));
3730 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3731 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3732 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3733 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3735 static unsigned sxhash_string
P_ ((unsigned char *, int));
3736 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3737 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3738 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3739 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3743 /***********************************************************************
3745 ***********************************************************************/
3747 /* If OBJ is a Lisp hash table, return a pointer to its struct
3748 Lisp_Hash_Table. Otherwise, signal an error. */
3750 static struct Lisp_Hash_Table
*
3751 check_hash_table (obj
)
3754 CHECK_HASH_TABLE (obj
, 0);
3755 return XHASH_TABLE (obj
);
3759 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3763 next_almost_prime (n
)
3776 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3777 which USED[I] is non-zero. If found at index I in ARGS, set
3778 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3779 -1. This function is used to extract a keyword/argument pair from
3780 a DEFUN parameter list. */
3783 get_key_arg (key
, nargs
, args
, used
)
3791 for (i
= 0; i
< nargs
- 1; ++i
)
3792 if (!used
[i
] && EQ (args
[i
], key
))
3807 /* Return a Lisp vector which has the same contents as VEC but has
3808 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3809 vector that are not copied from VEC are set to INIT. */
3812 larger_vector (vec
, new_size
, init
)
3817 struct Lisp_Vector
*v
;
3820 xassert (VECTORP (vec
));
3821 old_size
= XVECTOR (vec
)->size
;
3822 xassert (new_size
>= old_size
);
3824 v
= allocate_vectorlike (new_size
);
3826 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3827 old_size
* sizeof *v
->contents
);
3828 for (i
= old_size
; i
< new_size
; ++i
)
3829 v
->contents
[i
] = init
;
3830 XSETVECTOR (vec
, v
);
3835 /***********************************************************************
3837 ***********************************************************************/
3839 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3840 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3841 KEY2 are the same. */
3844 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3845 struct Lisp_Hash_Table
*h
;
3846 Lisp_Object key1
, key2
;
3847 unsigned hash1
, hash2
;
3849 return (FLOATP (key1
)
3851 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3855 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3856 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3857 KEY2 are the same. */
3860 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3861 struct Lisp_Hash_Table
*h
;
3862 Lisp_Object key1
, key2
;
3863 unsigned hash1
, hash2
;
3865 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3869 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3870 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3871 if KEY1 and KEY2 are the same. */
3874 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3875 struct Lisp_Hash_Table
*h
;
3876 Lisp_Object key1
, key2
;
3877 unsigned hash1
, hash2
;
3881 Lisp_Object args
[3];
3883 args
[0] = h
->user_cmp_function
;
3886 return !NILP (Ffuncall (3, args
));
3893 /* Value is a hash code for KEY for use in hash table H which uses
3894 `eq' to compare keys. The hash code returned is guaranteed to fit
3895 in a Lisp integer. */
3899 struct Lisp_Hash_Table
*h
;
3902 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3903 xassert ((hash
& ~VALMASK
) == 0);
3908 /* Value is a hash code for KEY for use in hash table H which uses
3909 `eql' to compare keys. The hash code returned is guaranteed to fit
3910 in a Lisp integer. */
3914 struct Lisp_Hash_Table
*h
;
3919 hash
= sxhash (key
, 0);
3921 hash
= XUINT (key
) ^ XGCTYPE (key
);
3922 xassert ((hash
& ~VALMASK
) == 0);
3927 /* Value is a hash code for KEY for use in hash table H which uses
3928 `equal' to compare keys. The hash code returned is guaranteed to fit
3929 in a Lisp integer. */
3932 hashfn_equal (h
, key
)
3933 struct Lisp_Hash_Table
*h
;
3936 unsigned hash
= sxhash (key
, 0);
3937 xassert ((hash
& ~VALMASK
) == 0);
3942 /* Value is a hash code for KEY for use in hash table H which uses as
3943 user-defined function to compare keys. The hash code returned is
3944 guaranteed to fit in a Lisp integer. */
3947 hashfn_user_defined (h
, key
)
3948 struct Lisp_Hash_Table
*h
;
3951 Lisp_Object args
[2], hash
;
3953 args
[0] = h
->user_hash_function
;
3955 hash
= Ffuncall (2, args
);
3956 if (!INTEGERP (hash
))
3958 list2 (build_string ("Invalid hash code returned from \
3959 user-supplied hash function"),
3961 return XUINT (hash
);
3965 /* Create and initialize a new hash table.
3967 TEST specifies the test the hash table will use to compare keys.
3968 It must be either one of the predefined tests `eq', `eql' or
3969 `equal' or a symbol denoting a user-defined test named TEST with
3970 test and hash functions USER_TEST and USER_HASH.
3972 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3974 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3975 new size when it becomes full is computed by adding REHASH_SIZE to
3976 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3977 table's new size is computed by multiplying its old size with
3980 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3981 be resized when the ratio of (number of entries in the table) /
3982 (table size) is >= REHASH_THRESHOLD.
3984 WEAK specifies the weakness of the table. If non-nil, it must be
3985 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3988 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3989 user_test
, user_hash
)
3990 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3991 Lisp_Object user_test
, user_hash
;
3993 struct Lisp_Hash_Table
*h
;
3994 struct Lisp_Vector
*v
;
3996 int index_size
, i
, len
, 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 vector, and initialize it. */
4011 len
= VECSIZE (struct Lisp_Hash_Table
);
4012 v
= allocate_vectorlike (len
);
4014 for (i
= 0; i
< len
; ++i
)
4015 v
->contents
[i
] = Qnil
;
4017 /* Initialize hash table slots. */
4018 sz
= XFASTINT (size
);
4019 h
= (struct Lisp_Hash_Table
*) v
;
4022 if (EQ (test
, Qeql
))
4024 h
->cmpfn
= cmpfn_eql
;
4025 h
->hashfn
= hashfn_eql
;
4027 else if (EQ (test
, Qeq
))
4030 h
->hashfn
= hashfn_eq
;
4032 else if (EQ (test
, Qequal
))
4034 h
->cmpfn
= cmpfn_equal
;
4035 h
->hashfn
= hashfn_equal
;
4039 h
->user_cmp_function
= user_test
;
4040 h
->user_hash_function
= user_hash
;
4041 h
->cmpfn
= cmpfn_user_defined
;
4042 h
->hashfn
= hashfn_user_defined
;
4046 h
->rehash_threshold
= rehash_threshold
;
4047 h
->rehash_size
= rehash_size
;
4048 h
->count
= make_number (0);
4049 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4050 h
->hash
= Fmake_vector (size
, Qnil
);
4051 h
->next
= Fmake_vector (size
, Qnil
);
4052 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4053 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4054 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4056 /* Set up the free list. */
4057 for (i
= 0; i
< sz
- 1; ++i
)
4058 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4059 h
->next_free
= make_number (0);
4061 XSET_HASH_TABLE (table
, h
);
4062 xassert (HASH_TABLE_P (table
));
4063 xassert (XHASH_TABLE (table
) == h
);
4065 /* Maybe add this hash table to the list of all weak hash tables. */
4067 h
->next_weak
= Qnil
;
4070 h
->next_weak
= Vweak_hash_tables
;
4071 Vweak_hash_tables
= table
;
4078 /* Return a copy of hash table H1. Keys and values are not copied,
4079 only the table itself is. */
4082 copy_hash_table (h1
)
4083 struct Lisp_Hash_Table
*h1
;
4086 struct Lisp_Hash_Table
*h2
;
4087 struct Lisp_Vector
*v
, *next
;
4090 len
= VECSIZE (struct Lisp_Hash_Table
);
4091 v
= allocate_vectorlike (len
);
4092 h2
= (struct Lisp_Hash_Table
*) v
;
4093 next
= h2
->vec_next
;
4094 bcopy (h1
, h2
, sizeof *h2
);
4095 h2
->vec_next
= next
;
4096 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4097 h2
->hash
= Fcopy_sequence (h1
->hash
);
4098 h2
->next
= Fcopy_sequence (h1
->next
);
4099 h2
->index
= Fcopy_sequence (h1
->index
);
4100 XSET_HASH_TABLE (table
, h2
);
4102 /* Maybe add this hash table to the list of all weak hash tables. */
4103 if (!NILP (h2
->weak
))
4105 h2
->next_weak
= Vweak_hash_tables
;
4106 Vweak_hash_tables
= table
;
4113 /* Resize hash table H if it's too full. If H cannot be resized
4114 because it's already too large, throw an error. */
4117 maybe_resize_hash_table (h
)
4118 struct Lisp_Hash_Table
*h
;
4120 if (NILP (h
->next_free
))
4122 int old_size
= HASH_TABLE_SIZE (h
);
4123 int i
, new_size
, index_size
;
4125 if (INTEGERP (h
->rehash_size
))
4126 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4128 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4129 new_size
= max (old_size
+ 1, new_size
);
4130 index_size
= next_almost_prime ((int)
4132 / XFLOATINT (h
->rehash_threshold
)));
4133 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4134 error ("Hash table too large to resize");
4136 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4137 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4138 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4139 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4141 /* Update the free list. Do it so that new entries are added at
4142 the end of the free list. This makes some operations like
4144 for (i
= old_size
; i
< new_size
- 1; ++i
)
4145 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4147 if (!NILP (h
->next_free
))
4149 Lisp_Object last
, next
;
4151 last
= h
->next_free
;
4152 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4156 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4159 XSETFASTINT (h
->next_free
, old_size
);
4162 for (i
= 0; i
< old_size
; ++i
)
4163 if (!NILP (HASH_HASH (h
, i
)))
4165 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4166 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4167 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4168 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4174 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4175 the hash code of KEY. Value is the index of the entry in H
4176 matching KEY, or -1 if not found. */
4179 hash_lookup (h
, key
, hash
)
4180 struct Lisp_Hash_Table
*h
;
4185 int start_of_bucket
;
4188 hash_code
= h
->hashfn (h
, key
);
4192 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4193 idx
= HASH_INDEX (h
, start_of_bucket
);
4195 /* We need not gcpro idx since it's either an integer or nil. */
4198 int i
= XFASTINT (idx
);
4199 if (EQ (key
, HASH_KEY (h
, i
))
4201 && h
->cmpfn (h
, key
, hash_code
,
4202 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4204 idx
= HASH_NEXT (h
, i
);
4207 return NILP (idx
) ? -1 : XFASTINT (idx
);
4211 /* Put an entry into hash table H that associates KEY with VALUE.
4212 HASH is a previously computed hash code of KEY.
4213 Value is the index of the entry in H matching KEY. */
4216 hash_put (h
, key
, value
, hash
)
4217 struct Lisp_Hash_Table
*h
;
4218 Lisp_Object key
, value
;
4221 int start_of_bucket
, i
;
4223 xassert ((hash
& ~VALMASK
) == 0);
4225 /* Increment count after resizing because resizing may fail. */
4226 maybe_resize_hash_table (h
);
4227 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4229 /* Store key/value in the key_and_value vector. */
4230 i
= XFASTINT (h
->next_free
);
4231 h
->next_free
= HASH_NEXT (h
, i
);
4232 HASH_KEY (h
, i
) = key
;
4233 HASH_VALUE (h
, i
) = value
;
4235 /* Remember its hash code. */
4236 HASH_HASH (h
, i
) = make_number (hash
);
4238 /* Add new entry to its collision chain. */
4239 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4240 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4241 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4246 /* Remove the entry matching KEY from hash table H, if there is one. */
4249 hash_remove (h
, key
)
4250 struct Lisp_Hash_Table
*h
;
4254 int start_of_bucket
;
4255 Lisp_Object idx
, prev
;
4257 hash_code
= h
->hashfn (h
, key
);
4258 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4259 idx
= HASH_INDEX (h
, start_of_bucket
);
4262 /* We need not gcpro idx, prev since they're either integers or nil. */
4265 int i
= XFASTINT (idx
);
4267 if (EQ (key
, HASH_KEY (h
, i
))
4269 && h
->cmpfn (h
, key
, hash_code
,
4270 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4272 /* Take entry out of collision chain. */
4274 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4276 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4278 /* Clear slots in key_and_value and add the slots to
4280 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4281 HASH_NEXT (h
, i
) = h
->next_free
;
4282 h
->next_free
= make_number (i
);
4283 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4284 xassert (XINT (h
->count
) >= 0);
4290 idx
= HASH_NEXT (h
, i
);
4296 /* Clear hash table H. */
4300 struct Lisp_Hash_Table
*h
;
4302 if (XFASTINT (h
->count
) > 0)
4304 int i
, size
= HASH_TABLE_SIZE (h
);
4306 for (i
= 0; i
< size
; ++i
)
4308 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4309 HASH_KEY (h
, i
) = Qnil
;
4310 HASH_VALUE (h
, i
) = Qnil
;
4311 HASH_HASH (h
, i
) = Qnil
;
4314 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4315 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4317 h
->next_free
= make_number (0);
4318 h
->count
= make_number (0);
4324 /************************************************************************
4326 ************************************************************************/
4328 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4329 entries from the table that don't survive the current GC.
4330 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4331 non-zero if anything was marked. */
4334 sweep_weak_table (h
, remove_entries_p
)
4335 struct Lisp_Hash_Table
*h
;
4336 int remove_entries_p
;
4338 int bucket
, n
, marked
;
4340 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4343 for (bucket
= 0; bucket
< n
; ++bucket
)
4345 Lisp_Object idx
, prev
;
4347 /* Follow collision chain, removing entries that
4348 don't survive this garbage collection. */
4349 idx
= HASH_INDEX (h
, bucket
);
4351 while (!GC_NILP (idx
))
4354 int i
= XFASTINT (idx
);
4356 int key_known_to_survive_p
, value_known_to_survive_p
;
4358 key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4359 value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4361 if (EQ (h
->weak
, Qkey
))
4362 remove_p
= !key_known_to_survive_p
;
4363 else if (EQ (h
->weak
, Qvalue
))
4364 remove_p
= !value_known_to_survive_p
;
4365 else if (EQ (h
->weak
, Qkey_or_value
))
4366 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4367 else if (EQ (h
->weak
, Qkey_and_value
))
4368 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4372 next
= HASH_NEXT (h
, i
);
4374 if (remove_entries_p
)
4378 /* Take out of collision chain. */
4380 HASH_INDEX (h
, i
) = next
;
4382 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4384 /* Add to free list. */
4385 HASH_NEXT (h
, i
) = h
->next_free
;
4388 /* Clear key, value, and hash. */
4389 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4390 HASH_HASH (h
, i
) = Qnil
;
4392 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4399 /* Make sure key and value survive. */
4400 if (!key_known_to_survive_p
)
4402 mark_object (&HASH_KEY (h
, i
));
4406 if (!value_known_to_survive_p
)
4408 mark_object (&HASH_VALUE (h
, i
));
4421 /* Remove elements from weak hash tables that don't survive the
4422 current garbage collection. Remove weak tables that don't survive
4423 from Vweak_hash_tables. Called from gc_sweep. */
4426 sweep_weak_hash_tables ()
4428 Lisp_Object table
, used
, next
;
4429 struct Lisp_Hash_Table
*h
;
4432 /* Mark all keys and values that are in use. Keep on marking until
4433 there is no more change. This is necessary for cases like
4434 value-weak table A containing an entry X -> Y, where Y is used in a
4435 key-weak table B, Z -> Y. If B comes after A in the list of weak
4436 tables, X -> Y might be removed from A, although when looking at B
4437 one finds that it shouldn't. */
4441 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4443 h
= XHASH_TABLE (table
);
4444 if (h
->size
& ARRAY_MARK_FLAG
)
4445 marked
|= sweep_weak_table (h
, 0);
4450 /* Remove tables and entries that aren't used. */
4451 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4453 h
= XHASH_TABLE (table
);
4454 next
= h
->next_weak
;
4456 if (h
->size
& ARRAY_MARK_FLAG
)
4458 /* TABLE is marked as used. Sweep its contents. */
4459 if (XFASTINT (h
->count
) > 0)
4460 sweep_weak_table (h
, 1);
4462 /* Add table to the list of used weak hash tables. */
4463 h
->next_weak
= used
;
4468 Vweak_hash_tables
= used
;
4473 /***********************************************************************
4474 Hash Code Computation
4475 ***********************************************************************/
4477 /* Maximum depth up to which to dive into Lisp structures. */
4479 #define SXHASH_MAX_DEPTH 3
4481 /* Maximum length up to which to take list and vector elements into
4484 #define SXHASH_MAX_LEN 7
4486 /* Combine two integers X and Y for hashing. */
4488 #define SXHASH_COMBINE(X, Y) \
4489 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4493 /* Return a hash for string PTR which has length LEN. The hash
4494 code returned is guaranteed to fit in a Lisp integer. */
4497 sxhash_string (ptr
, len
)
4501 unsigned char *p
= ptr
;
4502 unsigned char *end
= p
+ len
;
4511 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4514 return hash
& VALMASK
;
4518 /* Return a hash for list LIST. DEPTH is the current depth in the
4519 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4522 sxhash_list (list
, depth
)
4529 if (depth
< SXHASH_MAX_DEPTH
)
4531 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4532 list
= XCDR (list
), ++i
)
4534 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4535 hash
= SXHASH_COMBINE (hash
, hash2
);
4542 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4543 the Lisp structure. */
4546 sxhash_vector (vec
, depth
)
4550 unsigned hash
= XVECTOR (vec
)->size
;
4553 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4554 for (i
= 0; i
< n
; ++i
)
4556 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4557 hash
= SXHASH_COMBINE (hash
, hash2
);
4564 /* Return a hash for bool-vector VECTOR. */
4567 sxhash_bool_vector (vec
)
4570 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4573 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4574 for (i
= 0; i
< n
; ++i
)
4575 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4581 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4582 structure. Value is an unsigned integer clipped to VALMASK. */
4591 if (depth
> SXHASH_MAX_DEPTH
)
4594 switch (XTYPE (obj
))
4601 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4602 XSYMBOL (obj
)->name
->size
);
4610 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4613 /* This can be everything from a vector to an overlay. */
4614 case Lisp_Vectorlike
:
4616 /* According to the CL HyperSpec, two arrays are equal only if
4617 they are `eq', except for strings and bit-vectors. In
4618 Emacs, this works differently. We have to compare element
4620 hash
= sxhash_vector (obj
, depth
);
4621 else if (BOOL_VECTOR_P (obj
))
4622 hash
= sxhash_bool_vector (obj
);
4624 /* Others are `equal' if they are `eq', so let's take their
4630 hash
= sxhash_list (obj
, depth
);
4635 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4636 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4637 for (hash
= 0; p
< e
; ++p
)
4638 hash
= SXHASH_COMBINE (hash
, *p
);
4646 return hash
& VALMASK
;
4651 /***********************************************************************
4653 ***********************************************************************/
4656 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4657 "Compute a hash code for OBJ and return it as integer.")
4661 unsigned hash
= sxhash (obj
, 0);;
4662 return make_number (hash
);
4666 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4667 "Create and return a new hash table.\n\
4668 Arguments are specified as keyword/argument pairs. The following\n\
4669 arguments are defined:\n\
4671 :test TEST -- TEST must be a symbol that specifies how to compare keys.\n\
4672 Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
4673 User-supplied test and hash functions can be specified via\n\
4674 `define-hash-table-test'.\n\
4676 :size SIZE -- A hint as to how many elements will be put in the table.\n\
4679 :rehash-size REHASH-SIZE - Indicates how to expand the table when\n\
4680 it fills up. If REHASH-SIZE is an integer, add that many space.\n\
4681 If it is a float, it must be > 1.0, and the new size is computed by\n\
4682 multiplying the old size with that factor. Default is 1.5.\n\
4684 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
4685 Resize the hash table when ratio of the number of entries in the table.\n\
4688 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',\n\
4689 `key-or-value', or `key-and-value'. If WEAK is not nil, the table returned\n\
4690 is a weak table. Key/value pairs are removed from a weak hash table when\n\
4691 there are no non-weak references pointing to their key, value, one of key\n\
4692 or value, or both key and value, depending on WEAK. WEAK t is equivalent\n\
4693 to `key-and-value'. Default value of WEAK is nil.")
4698 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4699 Lisp_Object user_test
, user_hash
;
4703 /* The vector `used' is used to keep track of arguments that
4704 have been consumed. */
4705 used
= (char *) alloca (nargs
* sizeof *used
);
4706 bzero (used
, nargs
* sizeof *used
);
4708 /* See if there's a `:test TEST' among the arguments. */
4709 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4710 test
= i
< 0 ? Qeql
: args
[i
];
4711 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4713 /* See if it is a user-defined test. */
4716 prop
= Fget (test
, Qhash_table_test
);
4717 if (!CONSP (prop
) || XFASTINT (Flength (prop
)) < 2)
4718 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4720 user_test
= Fnth (make_number (0), prop
);
4721 user_hash
= Fnth (make_number (1), prop
);
4724 user_test
= user_hash
= Qnil
;
4726 /* See if there's a `:size SIZE' argument. */
4727 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4728 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4729 if (!INTEGERP (size
) || XINT (size
) < 0)
4731 list2 (build_string ("Invalid hash table size"),
4734 /* Look for `:rehash-size SIZE'. */
4735 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4736 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4737 if (!NUMBERP (rehash_size
)
4738 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4739 || XFLOATINT (rehash_size
) <= 1.0)
4741 list2 (build_string ("Invalid hash table rehash size"),
4744 /* Look for `:rehash-threshold THRESHOLD'. */
4745 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4746 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4747 if (!FLOATP (rehash_threshold
)
4748 || XFLOATINT (rehash_threshold
) <= 0.0
4749 || XFLOATINT (rehash_threshold
) > 1.0)
4751 list2 (build_string ("Invalid hash table rehash threshold"),
4754 /* Look for `:weakness WEAK'. */
4755 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4756 weak
= i
< 0 ? Qnil
: args
[i
];
4758 weak
= Qkey_and_value
;
4761 && !EQ (weak
, Qvalue
)
4762 && !EQ (weak
, Qkey_or_value
)
4763 && !EQ (weak
, Qkey_and_value
))
4764 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4767 /* Now, all args should have been used up, or there's a problem. */
4768 for (i
= 0; i
< nargs
; ++i
)
4771 list2 (build_string ("Invalid argument list"), args
[i
]));
4773 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4774 user_test
, user_hash
);
4778 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4779 "Return a copy of hash table TABLE.")
4783 return copy_hash_table (check_hash_table (table
));
4787 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4788 "Create a new hash table.\n\
4789 Optional first argument TEST specifies how to compare keys in\n\
4790 the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
4791 is `eql'. New tests can be defined with `define-hash-table-test'.")
4795 Lisp_Object args
[2];
4797 args
[1] = NILP (test
) ? Qeql
: test
;
4798 return Fmake_hash_table (2, args
);
4802 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4803 "Return the number of elements in TABLE.")
4807 return check_hash_table (table
)->count
;
4811 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4812 Shash_table_rehash_size
, 1, 1, 0,
4813 "Return the current rehash size of TABLE.")
4817 return check_hash_table (table
)->rehash_size
;
4821 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4822 Shash_table_rehash_threshold
, 1, 1, 0,
4823 "Return the current rehash threshold of TABLE.")
4827 return check_hash_table (table
)->rehash_threshold
;
4831 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4832 "Return the size of TABLE.\n\
4833 The size can be used as an argument to `make-hash-table' to create\n\
4834 a hash table than can hold as many elements of TABLE holds\n\
4835 without need for resizing.")
4839 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4840 return make_number (HASH_TABLE_SIZE (h
));
4844 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4845 "Return the test TABLE uses.")
4849 return check_hash_table (table
)->test
;
4853 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4855 "Return the weakness of TABLE.")
4859 return check_hash_table (table
)->weak
;
4863 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4864 "Return t if OBJ is a Lisp hash table object.")
4868 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4872 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4873 "Clear hash table TABLE.")
4877 hash_clear (check_hash_table (table
));
4882 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4883 "Look up KEY in TABLE and return its associated value.\n\
4884 If KEY is not found, return DFLT which defaults to nil.")
4886 Lisp_Object key
, table
, dflt
;
4888 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4889 int i
= hash_lookup (h
, key
, NULL
);
4890 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4894 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4895 "Associate KEY with VALUE in hash table TABLE.\n\
4896 If KEY is already present in table, replace its current value with\n\
4899 Lisp_Object key
, value
, table
;
4901 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4905 i
= hash_lookup (h
, key
, &hash
);
4907 HASH_VALUE (h
, i
) = value
;
4909 hash_put (h
, key
, value
, hash
);
4915 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4916 "Remove KEY from TABLE.")
4918 Lisp_Object key
, table
;
4920 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4921 hash_remove (h
, key
);
4926 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4927 "Call FUNCTION for all entries in hash table TABLE.\n\
4928 FUNCTION is called with 2 arguments KEY and VALUE.")
4930 Lisp_Object function
, table
;
4932 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4933 Lisp_Object args
[3];
4936 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4937 if (!NILP (HASH_HASH (h
, i
)))
4940 args
[1] = HASH_KEY (h
, i
);
4941 args
[2] = HASH_VALUE (h
, i
);
4949 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4950 Sdefine_hash_table_test
, 3, 3, 0,
4951 "Define a new hash table test with name NAME, a symbol.\n\
4952 In hash tables create with NAME specified as test, use TEST to compare\n\
4953 keys, and HASH for computing hash codes of keys.\n\
4955 TEST must be a function taking two arguments and returning non-nil\n\
4956 if both arguments are the same. HASH must be a function taking\n\
4957 one argument and return an integer that is the hash code of the\n\
4958 argument. Hash code computation should use the whole value range of\n\
4959 integers, including negative integers.")
4961 Lisp_Object name
, test
, hash
;
4963 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4973 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4974 "Return MD5 message digest of OBJECT, a buffer or string.\n\
4976 The two optional arguments START and END are character positions\n\
4977 specifying for which part of OBJECT the message digest should be computed.\n\
4978 If nil or omitted, the digest is computed for the whole OBJECT.\n\
4980 Third optional argument CODING-SYSTEM specifies the coding system text\n\
4981 should be converted to before computing the digest. If nil or omitted,\n\
4982 the current format is used or a format is guessed.\n\
4984 Fourth optional argument NOERROR is there for compatability with other\n\
4985 Emacsen and is ignored.")
4986 (object
, start
, end
, coding_system
, noerror
)
4987 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4989 unsigned char digest
[16];
4990 unsigned char value
[33];
4994 int start_char
= 0, end_char
= 0;
4995 int start_byte
= 0, end_byte
= 0;
4997 register struct buffer
*bp
;
5000 if (STRINGP(object
))
5002 if (NILP (coding_system
))
5004 /* we should guess coding system */
5005 if (STRING_MULTIBYTE (object
))
5007 /* we make a unibyte string and guess it's coding system
5008 (is this correct?) */
5009 object
= string_make_unibyte (object
);
5010 coding_system
= detect_coding_system
5011 (XSTRING(object
)->data
, STRING_BYTES(XSTRING (object
)), 1);
5015 /* guess coding system */
5016 coding_system
= detect_coding_system
5017 (XSTRING(object
)->data
, STRING_BYTES(XSTRING (object
)), 1);
5020 /* encode unibyte string into desired coding system
5021 (yes encoding functions handle unibyte source) */
5022 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5026 /* convert string into given coding system */
5027 if (STRING_MULTIBYTE (object
))
5029 /* just encode it */
5030 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5032 /* assume string is encoded */
5036 size
= XSTRING (object
)->size
;
5037 size_byte
= STRING_BYTES (XSTRING (object
));
5041 CHECK_NUMBER (start
, 1);
5043 start_char
= XINT (start
);
5048 start_byte
= string_char_to_byte (object
, start_char
);
5054 end_byte
= size_byte
;
5058 CHECK_NUMBER (end
, 2);
5060 end_char
= XINT (end
);
5065 end_byte
= string_char_to_byte (object
, end_char
);
5068 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5069 args_out_of_range_3 (object
, make_number (start_char
),
5070 make_number (end_char
));
5074 CHECK_BUFFER(object
, 0);
5076 bp
= XBUFFER (object
);
5082 CHECK_NUMBER_COERCE_MARKER (start
, 0);
5090 CHECK_NUMBER_COERCE_MARKER (end
, 1);
5095 temp
= b
, b
= e
, e
= temp
;
5097 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5098 args_out_of_range (start
, end
);
5100 if (NILP (coding_system
))
5102 /* we should guess coding system of buffer */
5103 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5104 if (NILP (coding_system
))
5106 /* xxx this can (and should) be handled. I do not know how. */
5108 Fcons (build_string ("No coding system found"), Qnil
));
5112 object
= make_buffer_string (b
, e
, 0);
5114 if (STRING_MULTIBYTE (object
))
5115 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5118 md5_buffer (XSTRING(object
)->data
+ start_byte
,
5119 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
5122 for (i
= 0; i
< 16; i
++)
5123 sprintf (&value
[2*i
], "%02x", digest
[i
]);
5126 return make_string (value
, 32);
5133 /* Hash table stuff. */
5134 Qhash_table_p
= intern ("hash-table-p");
5135 staticpro (&Qhash_table_p
);
5136 Qeq
= intern ("eq");
5138 Qeql
= intern ("eql");
5140 Qequal
= intern ("equal");
5141 staticpro (&Qequal
);
5142 QCtest
= intern (":test");
5143 staticpro (&QCtest
);
5144 QCsize
= intern (":size");
5145 staticpro (&QCsize
);
5146 QCrehash_size
= intern (":rehash-size");
5147 staticpro (&QCrehash_size
);
5148 QCrehash_threshold
= intern (":rehash-threshold");
5149 staticpro (&QCrehash_threshold
);
5150 QCweakness
= intern (":weakness");
5151 staticpro (&QCweakness
);
5152 Qkey
= intern ("key");
5154 Qvalue
= intern ("value");
5155 staticpro (&Qvalue
);
5156 Qhash_table_test
= intern ("hash-table-test");
5157 staticpro (&Qhash_table_test
);
5158 Qkey_or_value
= intern ("key-or-value");
5159 staticpro (&Qkey_or_value
);
5160 Qkey_and_value
= intern ("key-and-value");
5161 staticpro (&Qkey_and_value
);
5164 defsubr (&Smake_hash_table
);
5165 defsubr (&Scopy_hash_table
);
5166 defsubr (&Smakehash
);
5167 defsubr (&Shash_table_count
);
5168 defsubr (&Shash_table_rehash_size
);
5169 defsubr (&Shash_table_rehash_threshold
);
5170 defsubr (&Shash_table_size
);
5171 defsubr (&Shash_table_test
);
5172 defsubr (&Shash_table_weakness
);
5173 defsubr (&Shash_table_p
);
5174 defsubr (&Sclrhash
);
5175 defsubr (&Sgethash
);
5176 defsubr (&Sputhash
);
5177 defsubr (&Sremhash
);
5178 defsubr (&Smaphash
);
5179 defsubr (&Sdefine_hash_table_test
);
5181 Qstring_lessp
= intern ("string-lessp");
5182 staticpro (&Qstring_lessp
);
5183 Qprovide
= intern ("provide");
5184 staticpro (&Qprovide
);
5185 Qrequire
= intern ("require");
5186 staticpro (&Qrequire
);
5187 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5188 staticpro (&Qyes_or_no_p_history
);
5189 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5190 staticpro (&Qcursor_in_echo_area
);
5191 Qwidget_type
= intern ("widget-type");
5192 staticpro (&Qwidget_type
);
5194 staticpro (&string_char_byte_cache_string
);
5195 string_char_byte_cache_string
= Qnil
;
5197 Fset (Qyes_or_no_p_history
, Qnil
);
5199 DEFVAR_LISP ("features", &Vfeatures
,
5200 "A list of symbols which are the features of the executing emacs.\n\
5201 Used by `featurep' and `require', and altered by `provide'.");
5204 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5205 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
5206 This applies to y-or-n and yes-or-no questions asked by commands\n\
5207 invoked by mouse clicks and mouse menu items.");
5210 defsubr (&Sidentity
);
5213 defsubr (&Ssafe_length
);
5214 defsubr (&Sstring_bytes
);
5215 defsubr (&Sstring_equal
);
5216 defsubr (&Scompare_strings
);
5217 defsubr (&Sstring_lessp
);
5220 defsubr (&Svconcat
);
5221 defsubr (&Scopy_sequence
);
5222 defsubr (&Sstring_make_multibyte
);
5223 defsubr (&Sstring_make_unibyte
);
5224 defsubr (&Sstring_as_multibyte
);
5225 defsubr (&Sstring_as_unibyte
);
5226 defsubr (&Scopy_alist
);
5227 defsubr (&Ssubstring
);
5239 defsubr (&Snreverse
);
5240 defsubr (&Sreverse
);
5242 defsubr (&Splist_get
);
5244 defsubr (&Splist_put
);
5247 defsubr (&Sfillarray
);
5248 defsubr (&Schar_table_subtype
);
5249 defsubr (&Schar_table_parent
);
5250 defsubr (&Sset_char_table_parent
);
5251 defsubr (&Schar_table_extra_slot
);
5252 defsubr (&Sset_char_table_extra_slot
);
5253 defsubr (&Schar_table_range
);
5254 defsubr (&Sset_char_table_range
);
5255 defsubr (&Sset_char_table_default
);
5256 defsubr (&Soptimize_char_table
);
5257 defsubr (&Smap_char_table
);
5261 defsubr (&Smapconcat
);
5262 defsubr (&Sy_or_n_p
);
5263 defsubr (&Syes_or_no_p
);
5264 defsubr (&Sload_average
);
5265 defsubr (&Sfeaturep
);
5266 defsubr (&Srequire
);
5267 defsubr (&Sprovide
);
5268 defsubr (&Splist_member
);
5269 defsubr (&Swidget_put
);
5270 defsubr (&Swidget_get
);
5271 defsubr (&Swidget_apply
);
5272 defsubr (&Sbase64_encode_region
);
5273 defsubr (&Sbase64_decode_region
);
5274 defsubr (&Sbase64_encode_string
);
5275 defsubr (&Sbase64_decode_string
);
5283 Vweak_hash_tables
= Qnil
;