1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
36 #include "character.h"
41 #include "intervals.h"
44 #include "blockinput.h"
45 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
50 #define NULL (void *)0
53 /* Nonzero enables use of dialog boxes for questions
54 asked by mouse commands. */
57 extern int minibuffer_auto_raise
;
58 extern Lisp_Object minibuf_window
;
60 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
61 Lisp_Object Qyes_or_no_p_history
;
62 Lisp_Object Qcursor_in_echo_area
;
63 Lisp_Object Qwidget_type
;
65 extern Lisp_Object Qinput_method_function
;
67 static int internal_equal ();
69 extern long get_random ();
70 extern void seed_random ();
76 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
77 doc
: /* Return the argument unchanged. */)
84 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
85 doc
: /* Return a pseudo-random number.
86 All integers representable in Lisp are equally likely.
87 On most systems, this is 28 bits' worth.
88 With positive integer argument N, return random number in interval [0,N).
89 With argument t, set the random number seed from the current time and pid. */)
94 Lisp_Object lispy_val
;
95 unsigned long denominator
;
98 seed_random (getpid () + time (NULL
));
99 if (NATNUMP (n
) && XFASTINT (n
) != 0)
101 /* Try to take our random number from the higher bits of VAL,
102 not the lower, since (says Gentzel) the low bits of `random'
103 are less random than the higher ones. We do this by using the
104 quotient rather than the remainder. At the high end of the RNG
105 it's possible to get a quotient larger than n; discarding
106 these values eliminates the bias that would otherwise appear
107 when using a large n. */
108 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
110 val
= get_random () / denominator
;
111 while (val
>= XFASTINT (n
));
115 XSETINT (lispy_val
, val
);
119 /* Random data-structure functions */
121 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
122 doc
: /* Return the length of vector, list or string SEQUENCE.
123 A byte-code function object is also allowed.
124 If the string contains multibyte characters, this is not the necessarily
125 the number of bytes in the string; it is the number of characters.
126 To get the number of bytes, use `string-bytes'. */)
128 register Lisp_Object sequence
;
130 register Lisp_Object val
;
134 if (STRINGP (sequence
))
135 XSETFASTINT (val
, XSTRING (sequence
)->size
);
136 else if (VECTORP (sequence
))
137 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
138 else if (CHAR_TABLE_P (sequence
))
139 XSETFASTINT (val
, MAX_CHAR
);
140 else if (BOOL_VECTOR_P (sequence
))
141 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
142 else if (COMPILEDP (sequence
))
143 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
144 else if (CONSP (sequence
))
147 while (CONSP (sequence
))
149 sequence
= XCDR (sequence
);
152 if (!CONSP (sequence
))
155 sequence
= XCDR (sequence
);
160 if (!NILP (sequence
))
161 wrong_type_argument (Qlistp
, sequence
);
163 val
= make_number (i
);
165 else if (NILP (sequence
))
166 XSETFASTINT (val
, 0);
169 sequence
= wrong_type_argument (Qsequencep
, sequence
);
175 /* This does not check for quits. That is safe
176 since it must terminate. */
178 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
179 doc
: /* Return the length of a list, but avoid error or infinite loop.
180 This function never gets an error. If LIST is not really a list,
181 it returns 0. If LIST is circular, it returns a finite value
182 which is at least the number of distinct elements. */)
186 Lisp_Object tail
, halftail
, length
;
189 /* halftail is used to detect circular lists. */
191 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
193 if (EQ (tail
, halftail
) && len
!= 0)
197 halftail
= XCDR (halftail
);
200 XSETINT (length
, len
);
204 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
205 doc
: /* Return the number of bytes in STRING.
206 If STRING is a multibyte string, this is greater than the length of STRING. */)
210 CHECK_STRING (string
);
211 return make_number (STRING_BYTES (XSTRING (string
)));
214 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
215 doc
: /* Return t if two strings have identical contents.
216 Case is significant, but text properties are ignored.
217 Symbols are also allowed; their print names are used instead. */)
219 register Lisp_Object s1
, s2
;
222 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
224 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
228 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
229 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
230 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
235 DEFUN ("compare-strings", Fcompare_strings
,
236 Scompare_strings
, 6, 7, 0,
237 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
238 In string STR1, skip the first START1 characters and stop at END1.
239 In string STR2, skip the first START2 characters and stop at END2.
240 END1 and END2 default to the full lengths of the respective strings.
242 Case is significant in this comparison if IGNORE-CASE is nil.
243 Unibyte strings are converted to multibyte for comparison.
245 The value is t if the strings (or specified portions) match.
246 If string STR1 is less, the value is a negative number N;
247 - 1 - N is the number of characters that match at the beginning.
248 If string STR1 is greater, the value is a positive number N;
249 N - 1 is the number of characters that match at the beginning. */)
250 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
251 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
253 register int end1_char
, end2_char
;
254 register int i1
, i1_byte
, i2
, i2_byte
;
259 start1
= make_number (0);
261 start2
= make_number (0);
262 CHECK_NATNUM (start1
);
263 CHECK_NATNUM (start2
);
272 i1_byte
= string_char_to_byte (str1
, i1
);
273 i2_byte
= string_char_to_byte (str2
, i2
);
275 end1_char
= XSTRING (str1
)->size
;
276 if (! NILP (end1
) && end1_char
> XINT (end1
))
277 end1_char
= XINT (end1
);
279 end2_char
= XSTRING (str2
)->size
;
280 if (! NILP (end2
) && end2_char
> XINT (end2
))
281 end2_char
= XINT (end2
);
283 while (i1
< end1_char
&& i2
< end2_char
)
285 /* When we find a mismatch, we must compare the
286 characters, not just the bytes. */
289 if (STRING_MULTIBYTE (str1
))
290 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
293 c1
= XSTRING (str1
)->data
[i1
++];
294 c1
= unibyte_char_to_multibyte (c1
);
297 if (STRING_MULTIBYTE (str2
))
298 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
301 c2
= XSTRING (str2
)->data
[i2
++];
302 c2
= unibyte_char_to_multibyte (c2
);
308 if (! NILP (ignore_case
))
312 tem
= Fupcase (make_number (c1
));
314 tem
= Fupcase (make_number (c2
));
321 /* Note that I1 has already been incremented
322 past the character that we are comparing;
323 hence we don't add or subtract 1 here. */
325 return make_number (- i1
+ XINT (start1
));
327 return make_number (i1
- XINT (start1
));
331 return make_number (i1
- XINT (start1
) + 1);
333 return make_number (- i1
+ XINT (start1
) - 1);
338 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
339 doc
: /* Return t if first arg string is less than second in lexicographic order.
341 Symbols are also allowed; their print names are used instead. */)
343 register Lisp_Object s1
, s2
;
346 register int i1
, i1_byte
, i2
, i2_byte
;
349 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
351 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
355 i1
= i1_byte
= i2
= i2_byte
= 0;
357 end
= XSTRING (s1
)->size
;
358 if (end
> XSTRING (s2
)->size
)
359 end
= XSTRING (s2
)->size
;
363 /* When we find a mismatch, we must compare the
364 characters, not just the bytes. */
367 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
368 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
371 return c1
< c2
? Qt
: Qnil
;
373 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
376 static Lisp_Object
concat ();
387 return concat (2, args
, Lisp_String
, 0);
389 return concat (2, &s1
, Lisp_String
, 0);
390 #endif /* NO_ARG_ARRAY */
396 Lisp_Object s1
, s2
, s3
;
403 return concat (3, args
, Lisp_String
, 0);
405 return concat (3, &s1
, Lisp_String
, 0);
406 #endif /* NO_ARG_ARRAY */
409 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
410 doc
: /* Concatenate all the arguments and make the result a list.
411 The result is a list whose elements are the elements of all the arguments.
412 Each argument may be a list, vector or string.
413 The last argument is not copied, just used as the tail of the new list.
414 usage: (append &rest SEQUENCES) */)
419 return concat (nargs
, args
, Lisp_Cons
, 1);
422 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
423 doc
: /* Concatenate all the arguments and make the result a string.
424 The result is a string whose elements are the elements of all the arguments.
425 Each argument may be a string or a list or vector of characters (integers).
426 usage: (concat &rest SEQUENCES) */)
431 return concat (nargs
, args
, Lisp_String
, 0);
434 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
435 doc
: /* Concatenate all the arguments and make the result a vector.
436 The result is a vector whose elements are the elements of all the arguments.
437 Each argument may be a list, vector or string.
438 usage: (vconcat &rest SEQUENCES) */)
443 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
447 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
448 doc
: /* Return a copy of a list, vector or string.
449 The elements of a list or vector are not copied; they are shared
450 with the original. */)
454 if (NILP (arg
)) return arg
;
456 if (CHAR_TABLE_P (arg
))
458 return copy_char_table (arg
);
460 if (BOOL_VECTOR_P (arg
))
464 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
466 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
467 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
472 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
473 arg
= wrong_type_argument (Qsequencep
, arg
);
474 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
477 /* In string STR of length LEN, see if bytes before STR[I] combine
478 with bytes after STR[I] to form a single character. If so, return
479 the number of bytes after STR[I] which combine in this way.
480 Otherwize, return 0. */
483 count_combining (str
, len
, i
)
487 int j
= i
- 1, bytes
;
489 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
491 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
492 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
494 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
495 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
498 /* This structure holds information of an argument of `concat' that is
499 a string and has text properties to be copied. */
502 int argnum
; /* refer to ARGS (arguments of `concat') */
503 int from
; /* refer to ARGS[argnum] (argument string) */
504 int to
; /* refer to VAL (the target string) */
508 concat (nargs
, args
, target_type
, last_special
)
511 enum Lisp_Type target_type
;
515 register Lisp_Object tail
;
516 register Lisp_Object
this;
518 int toindex_byte
= 0;
519 register int result_len
;
520 register int result_len_byte
;
522 Lisp_Object last_tail
;
525 /* When we make a multibyte string, we can't copy text properties
526 while concatinating each string because the length of resulting
527 string can't be decided until we finish the whole concatination.
528 So, we record strings that have text properties to be copied
529 here, and copy the text properties after the concatination. */
530 struct textprop_rec
*textprops
= NULL
;
531 /* Number of elments in textprops. */
532 int num_textprops
= 0;
536 /* In append, the last arg isn't treated like the others */
537 if (last_special
&& nargs
> 0)
540 last_tail
= args
[nargs
];
545 /* Canonicalize each argument. */
546 for (argnum
= 0; argnum
< nargs
; argnum
++)
549 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
550 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
552 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
556 /* Compute total length in chars of arguments in RESULT_LEN.
557 If desired output is a string, also compute length in bytes
558 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
559 whether the result should be a multibyte string. */
563 for (argnum
= 0; argnum
< nargs
; argnum
++)
567 len
= XFASTINT (Flength (this));
568 if (target_type
== Lisp_String
)
570 /* We must count the number of bytes needed in the string
571 as well as the number of characters. */
577 for (i
= 0; i
< len
; i
++)
579 ch
= XVECTOR (this)->contents
[i
];
581 wrong_type_argument (Qintegerp
, ch
);
582 this_len_byte
= CHAR_BYTES (XINT (ch
));
583 result_len_byte
+= this_len_byte
;
584 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
587 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
588 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
589 else if (CONSP (this))
590 for (; CONSP (this); this = XCDR (this))
594 wrong_type_argument (Qintegerp
, ch
);
595 this_len_byte
= CHAR_BYTES (XINT (ch
));
596 result_len_byte
+= this_len_byte
;
597 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
600 else if (STRINGP (this))
602 if (STRING_MULTIBYTE (this))
605 result_len_byte
+= STRING_BYTES (XSTRING (this));
608 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
609 XSTRING (this)->size
);
616 if (! some_multibyte
)
617 result_len_byte
= result_len
;
619 /* Create the output object. */
620 if (target_type
== Lisp_Cons
)
621 val
= Fmake_list (make_number (result_len
), Qnil
);
622 else if (target_type
== Lisp_Vectorlike
)
623 val
= Fmake_vector (make_number (result_len
), Qnil
);
624 else if (some_multibyte
)
625 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
627 val
= make_uninit_string (result_len
);
629 /* In `append', if all but last arg are nil, return last arg. */
630 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
633 /* Copy the contents of the args into the result. */
635 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
637 toindex
= 0, toindex_byte
= 0;
642 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
644 for (argnum
= 0; argnum
< nargs
; argnum
++)
648 register unsigned int thisindex
= 0;
649 register unsigned int thisindex_byte
= 0;
653 thislen
= Flength (this), thisleni
= XINT (thislen
);
655 /* Between strings of the same kind, copy fast. */
656 if (STRINGP (this) && STRINGP (val
)
657 && STRING_MULTIBYTE (this) == some_multibyte
)
659 int thislen_byte
= STRING_BYTES (XSTRING (this));
661 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
662 STRING_BYTES (XSTRING (this)));
663 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
665 textprops
[num_textprops
].argnum
= argnum
;
666 textprops
[num_textprops
].from
= 0;
667 textprops
[num_textprops
++].to
= toindex
;
669 toindex_byte
+= thislen_byte
;
672 /* Copy a single-byte string to a multibyte string. */
673 else if (STRINGP (this) && STRINGP (val
))
675 if (! NULL_INTERVAL_P (XSTRING (this)->intervals
))
677 textprops
[num_textprops
].argnum
= argnum
;
678 textprops
[num_textprops
].from
= 0;
679 textprops
[num_textprops
++].to
= toindex
;
681 toindex_byte
+= copy_text (XSTRING (this)->data
,
682 XSTRING (val
)->data
+ toindex_byte
,
683 XSTRING (this)->size
, 0, 1);
687 /* Copy element by element. */
690 register Lisp_Object elt
;
692 /* Fetch next element of `this' arg into `elt', or break if
693 `this' is exhausted. */
694 if (NILP (this)) break;
696 elt
= XCAR (this), this = XCDR (this);
697 else if (thisindex
>= thisleni
)
699 else if (STRINGP (this))
702 if (STRING_MULTIBYTE (this))
704 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
707 XSETFASTINT (elt
, c
);
711 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
713 && XINT (elt
) >= 0200
714 && XINT (elt
) < 0400)
716 c
= unibyte_char_to_multibyte (XINT (elt
));
721 else if (BOOL_VECTOR_P (this))
724 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
725 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
732 elt
= XVECTOR (this)->contents
[thisindex
++];
734 /* Store this element into the result. */
741 else if (VECTORP (val
))
742 XVECTOR (val
)->contents
[toindex
++] = elt
;
748 += CHAR_STRING (XINT (elt
),
749 XSTRING (val
)->data
+ toindex_byte
);
751 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
757 XSETCDR (prev
, last_tail
);
759 if (num_textprops
> 0)
762 int last_to_end
= -1;
764 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
766 this = args
[textprops
[argnum
].argnum
];
767 props
= text_property_list (this,
769 make_number (XSTRING (this)->size
),
771 /* If successive arguments have properites, be sure that the
772 value of `composition' property be the copy. */
773 if (last_to_end
== textprops
[argnum
].to
)
774 make_composition_value_copy (props
);
775 add_text_properties_from_list (val
, props
,
776 make_number (textprops
[argnum
].to
));
777 last_to_end
= textprops
[argnum
].to
+ XSTRING (this)->size
;
783 static Lisp_Object string_char_byte_cache_string
;
784 static int string_char_byte_cache_charpos
;
785 static int string_char_byte_cache_bytepos
;
788 clear_string_char_byte_cache ()
790 string_char_byte_cache_string
= Qnil
;
793 /* Return the character index corresponding to CHAR_INDEX in STRING. */
796 string_char_to_byte (string
, char_index
)
801 int best_below
, best_below_byte
;
802 int best_above
, best_above_byte
;
804 if (! STRING_MULTIBYTE (string
))
807 best_below
= best_below_byte
= 0;
808 best_above
= XSTRING (string
)->size
;
809 best_above_byte
= STRING_BYTES (XSTRING (string
));
811 if (EQ (string
, string_char_byte_cache_string
))
813 if (string_char_byte_cache_charpos
< char_index
)
815 best_below
= string_char_byte_cache_charpos
;
816 best_below_byte
= string_char_byte_cache_bytepos
;
820 best_above
= string_char_byte_cache_charpos
;
821 best_above_byte
= string_char_byte_cache_bytepos
;
825 if (char_index
- best_below
< best_above
- char_index
)
827 unsigned char *p
= XSTRING (string
)->data
+ best_below_byte
;
829 while (best_below
< char_index
)
831 p
+= BYTES_BY_CHAR_HEAD (*p
);
834 i_byte
= p
- XSTRING (string
)->data
;
838 unsigned char *p
= XSTRING (string
)->data
+ best_above_byte
;
840 while (best_above
> char_index
)
843 while (!CHAR_HEAD_P (*p
)) p
--;
846 i_byte
= p
- XSTRING (string
)->data
;
849 string_char_byte_cache_bytepos
= i_byte
;
850 string_char_byte_cache_charpos
= char_index
;
851 string_char_byte_cache_string
= string
;
856 /* Return the character index corresponding to BYTE_INDEX in STRING. */
859 string_byte_to_char (string
, byte_index
)
864 int best_below
, best_below_byte
;
865 int best_above
, best_above_byte
;
867 if (! STRING_MULTIBYTE (string
))
870 best_below
= best_below_byte
= 0;
871 best_above
= XSTRING (string
)->size
;
872 best_above_byte
= STRING_BYTES (XSTRING (string
));
874 if (EQ (string
, string_char_byte_cache_string
))
876 if (string_char_byte_cache_bytepos
< byte_index
)
878 best_below
= string_char_byte_cache_charpos
;
879 best_below_byte
= string_char_byte_cache_bytepos
;
883 best_above
= string_char_byte_cache_charpos
;
884 best_above_byte
= string_char_byte_cache_bytepos
;
888 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
890 unsigned char *p
= XSTRING (string
)->data
+ best_below_byte
;
891 unsigned char *pend
= XSTRING (string
)->data
+ byte_index
;
895 p
+= BYTES_BY_CHAR_HEAD (*p
);
899 i_byte
= p
- XSTRING (string
)->data
;
903 unsigned char *p
= XSTRING (string
)->data
+ best_above_byte
;
904 unsigned char *pbeg
= XSTRING (string
)->data
+ byte_index
;
909 while (!CHAR_HEAD_P (*p
)) p
--;
913 i_byte
= p
- XSTRING (string
)->data
;
916 string_char_byte_cache_bytepos
= i_byte
;
917 string_char_byte_cache_charpos
= i
;
918 string_char_byte_cache_string
= string
;
923 /* Convert STRING to a multibyte string.
924 Single-byte characters 0240 through 0377 are converted
925 by adding nonascii_insert_offset to each. */
928 string_make_multibyte (string
)
934 if (STRING_MULTIBYTE (string
))
937 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
938 XSTRING (string
)->size
);
939 /* If all the chars are ASCII, they won't need any more bytes
940 once converted. In that case, we can return STRING itself. */
941 if (nbytes
== STRING_BYTES (XSTRING (string
)))
944 buf
= (unsigned char *) alloca (nbytes
);
945 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
948 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
951 /* Convert STRING to a single-byte string. */
954 string_make_unibyte (string
)
959 if (! STRING_MULTIBYTE (string
))
962 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
964 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
967 return make_unibyte_string (buf
, XSTRING (string
)->size
);
970 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
972 doc
: /* Return the multibyte equivalent of STRING.
973 The function `unibyte-char-to-multibyte' is used to convert
974 each unibyte character to a multibyte character. */)
978 CHECK_STRING (string
);
980 return string_make_multibyte (string
);
983 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
985 doc
: /* Return the unibyte equivalent of STRING.
986 Multibyte character codes are converted to unibyte
987 by using just the low 8 bits. */)
991 CHECK_STRING (string
);
993 return string_make_unibyte (string
);
996 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
998 doc
: /* Return a unibyte string with the same individual bytes as STRING.
999 If STRING is unibyte, the result is STRING itself.
1000 Otherwise it is a newly created string, with no text properties.
1001 If STRING is multibyte and contains a character of charset
1002 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1003 corresponding single byte. */)
1007 CHECK_STRING (string
);
1009 if (STRING_MULTIBYTE (string
))
1011 int bytes
= STRING_BYTES (XSTRING (string
));
1012 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1014 bcopy (XSTRING (string
)->data
, str
, bytes
);
1015 bytes
= str_as_unibyte (str
, bytes
);
1016 string
= make_unibyte_string (str
, bytes
);
1022 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1024 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1025 If STRING is multibyte, the result is STRING itself.
1026 Otherwise it is a newly created string, with no text properties.
1027 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1028 part of a multibyte form), it is converted to the corresponding
1029 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1033 CHECK_STRING (string
);
1035 if (! STRING_MULTIBYTE (string
))
1037 Lisp_Object new_string
;
1040 parse_str_as_multibyte (XSTRING (string
)->data
,
1041 STRING_BYTES (XSTRING (string
)),
1043 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1044 bcopy (XSTRING (string
)->data
, XSTRING (new_string
)->data
,
1045 STRING_BYTES (XSTRING (string
)));
1046 if (nbytes
!= STRING_BYTES (XSTRING (string
)))
1047 str_as_multibyte (XSTRING (new_string
)->data
, nbytes
,
1048 STRING_BYTES (XSTRING (string
)), NULL
);
1049 string
= new_string
;
1050 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1055 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1056 doc
: /* Return a copy of ALIST.
1057 This is an alist which represents the same mapping from objects to objects,
1058 but does not share the alist structure with ALIST.
1059 The objects mapped (cars and cdrs of elements of the alist)
1060 are shared, however.
1061 Elements of ALIST that are not conses are also shared. */)
1065 register Lisp_Object tem
;
1070 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1071 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1073 register Lisp_Object car
;
1077 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1082 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1083 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1084 TO may be nil or omitted; then the substring runs to the end of STRING.
1085 If FROM or TO is negative, it counts from the end.
1087 This function allows vectors as well as strings. */)
1090 register Lisp_Object from
, to
;
1095 int from_char
, to_char
;
1096 int from_byte
= 0, to_byte
= 0;
1098 if (! (STRINGP (string
) || VECTORP (string
)))
1099 wrong_type_argument (Qarrayp
, string
);
1101 CHECK_NUMBER (from
);
1103 if (STRINGP (string
))
1105 size
= XSTRING (string
)->size
;
1106 size_byte
= STRING_BYTES (XSTRING (string
));
1109 size
= XVECTOR (string
)->size
;
1114 to_byte
= size_byte
;
1120 to_char
= XINT (to
);
1124 if (STRINGP (string
))
1125 to_byte
= string_char_to_byte (string
, to_char
);
1128 from_char
= XINT (from
);
1131 if (STRINGP (string
))
1132 from_byte
= string_char_to_byte (string
, from_char
);
1134 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1135 args_out_of_range_3 (string
, make_number (from_char
),
1136 make_number (to_char
));
1138 if (STRINGP (string
))
1140 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1141 to_char
- from_char
, to_byte
- from_byte
,
1142 STRING_MULTIBYTE (string
));
1143 copy_text_properties (make_number (from_char
), make_number (to_char
),
1144 string
, make_number (0), res
, Qnil
);
1147 res
= Fvector (to_char
- from_char
,
1148 XVECTOR (string
)->contents
+ from_char
);
1153 /* Extract a substring of STRING, giving start and end positions
1154 both in characters and in bytes. */
1157 substring_both (string
, from
, from_byte
, to
, to_byte
)
1159 int from
, from_byte
, to
, to_byte
;
1165 if (! (STRINGP (string
) || VECTORP (string
)))
1166 wrong_type_argument (Qarrayp
, string
);
1168 if (STRINGP (string
))
1170 size
= XSTRING (string
)->size
;
1171 size_byte
= STRING_BYTES (XSTRING (string
));
1174 size
= XVECTOR (string
)->size
;
1176 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1177 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1179 if (STRINGP (string
))
1181 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1182 to
- from
, to_byte
- from_byte
,
1183 STRING_MULTIBYTE (string
));
1184 copy_text_properties (make_number (from
), make_number (to
),
1185 string
, make_number (0), res
, Qnil
);
1188 res
= Fvector (to
- from
,
1189 XVECTOR (string
)->contents
+ from
);
1194 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1195 doc
: /* Take cdr N times on LIST, returns the result. */)
1198 register Lisp_Object list
;
1200 register int i
, num
;
1203 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1207 wrong_type_argument (Qlistp
, list
);
1213 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1214 doc
: /* Return the Nth element of LIST.
1215 N counts from zero. If LIST is not that long, nil is returned. */)
1217 Lisp_Object n
, list
;
1219 return Fcar (Fnthcdr (n
, list
));
1222 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1223 doc
: /* Return element of SEQUENCE at index N. */)
1225 register Lisp_Object sequence
, n
;
1230 if (CONSP (sequence
) || NILP (sequence
))
1231 return Fcar (Fnthcdr (n
, sequence
));
1232 else if (STRINGP (sequence
) || VECTORP (sequence
)
1233 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1234 return Faref (sequence
, n
);
1236 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1240 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1241 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1242 The value is actually the tail of LIST whose car is ELT. */)
1244 register Lisp_Object elt
;
1247 register Lisp_Object tail
;
1248 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1250 register Lisp_Object tem
;
1252 wrong_type_argument (Qlistp
, list
);
1254 if (! NILP (Fequal (elt
, tem
)))
1261 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1262 doc
: /* Return non-nil if ELT is an element of LIST.
1263 Comparison done with EQ. The value is actually the tail of LIST
1264 whose car is ELT. */)
1266 Lisp_Object elt
, list
;
1270 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1274 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1278 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1285 if (!CONSP (list
) && !NILP (list
))
1286 list
= wrong_type_argument (Qlistp
, list
);
1291 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1292 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1293 The value is actually the element of LIST whose car is KEY.
1294 Elements of LIST that are not conses are ignored. */)
1296 Lisp_Object key
, list
;
1303 || (CONSP (XCAR (list
))
1304 && EQ (XCAR (XCAR (list
)), key
)))
1309 || (CONSP (XCAR (list
))
1310 && EQ (XCAR (XCAR (list
)), key
)))
1315 || (CONSP (XCAR (list
))
1316 && EQ (XCAR (XCAR (list
)), key
)))
1324 result
= XCAR (list
);
1325 else if (NILP (list
))
1328 result
= wrong_type_argument (Qlistp
, list
);
1333 /* Like Fassq but never report an error and do not allow quits.
1334 Use only on lists known never to be circular. */
1337 assq_no_quit (key
, list
)
1338 Lisp_Object key
, list
;
1341 && (!CONSP (XCAR (list
))
1342 || !EQ (XCAR (XCAR (list
)), key
)))
1345 return CONSP (list
) ? XCAR (list
) : Qnil
;
1348 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1349 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1350 The value is actually the element of LIST whose car equals KEY. */)
1352 Lisp_Object key
, list
;
1354 Lisp_Object result
, car
;
1359 || (CONSP (XCAR (list
))
1360 && (car
= XCAR (XCAR (list
)),
1361 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1366 || (CONSP (XCAR (list
))
1367 && (car
= XCAR (XCAR (list
)),
1368 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1373 || (CONSP (XCAR (list
))
1374 && (car
= XCAR (XCAR (list
)),
1375 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1383 result
= XCAR (list
);
1384 else if (NILP (list
))
1387 result
= wrong_type_argument (Qlistp
, list
);
1392 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1393 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1394 The value is actually the element of LIST whose cdr is KEY. */)
1396 register Lisp_Object key
;
1404 || (CONSP (XCAR (list
))
1405 && EQ (XCDR (XCAR (list
)), key
)))
1410 || (CONSP (XCAR (list
))
1411 && EQ (XCDR (XCAR (list
)), key
)))
1416 || (CONSP (XCAR (list
))
1417 && EQ (XCDR (XCAR (list
)), key
)))
1426 else if (CONSP (list
))
1427 result
= XCAR (list
);
1429 result
= wrong_type_argument (Qlistp
, list
);
1434 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1435 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1436 The value is actually the element of LIST whose cdr equals KEY. */)
1438 Lisp_Object key
, list
;
1440 Lisp_Object result
, cdr
;
1445 || (CONSP (XCAR (list
))
1446 && (cdr
= XCDR (XCAR (list
)),
1447 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1452 || (CONSP (XCAR (list
))
1453 && (cdr
= XCDR (XCAR (list
)),
1454 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1459 || (CONSP (XCAR (list
))
1460 && (cdr
= XCDR (XCAR (list
)),
1461 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1469 result
= XCAR (list
);
1470 else if (NILP (list
))
1473 result
= wrong_type_argument (Qlistp
, list
);
1478 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1479 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1480 The modified LIST is returned. Comparison is done with `eq'.
1481 If the first member of LIST is ELT, there is no way to remove it by side effect;
1482 therefore, write `(setq foo (delq element foo))'
1483 to be sure of changing the value of `foo'. */)
1485 register Lisp_Object elt
;
1488 register Lisp_Object tail
, prev
;
1489 register Lisp_Object tem
;
1493 while (!NILP (tail
))
1496 wrong_type_argument (Qlistp
, list
);
1503 Fsetcdr (prev
, XCDR (tail
));
1513 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1514 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1515 SEQ must be a list, a vector, or a string.
1516 The modified SEQ is returned. Comparison is done with `equal'.
1517 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1518 is not a side effect; it is simply using a different sequence.
1519 Therefore, write `(setq foo (delete element foo))'
1520 to be sure of changing the value of `foo'. */)
1522 Lisp_Object elt
, seq
;
1528 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1529 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1532 if (n
!= ASIZE (seq
))
1534 struct Lisp_Vector
*p
= allocate_vector (n
);
1536 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1537 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1538 p
->contents
[n
++] = AREF (seq
, i
);
1540 XSETVECTOR (seq
, p
);
1543 else if (STRINGP (seq
))
1545 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1548 for (i
= nchars
= nbytes
= ibyte
= 0;
1549 i
< XSTRING (seq
)->size
;
1550 ++i
, ibyte
+= cbytes
)
1552 if (STRING_MULTIBYTE (seq
))
1554 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1555 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1556 cbytes
= CHAR_BYTES (c
);
1560 c
= XSTRING (seq
)->data
[i
];
1564 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1571 if (nchars
!= XSTRING (seq
)->size
)
1575 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1576 if (!STRING_MULTIBYTE (seq
))
1577 SET_STRING_BYTES (XSTRING (tem
), -1);
1579 for (i
= nchars
= nbytes
= ibyte
= 0;
1580 i
< XSTRING (seq
)->size
;
1581 ++i
, ibyte
+= cbytes
)
1583 if (STRING_MULTIBYTE (seq
))
1585 c
= STRING_CHAR (&XSTRING (seq
)->data
[ibyte
],
1586 STRING_BYTES (XSTRING (seq
)) - ibyte
);
1587 cbytes
= CHAR_BYTES (c
);
1591 c
= XSTRING (seq
)->data
[i
];
1595 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1597 unsigned char *from
= &XSTRING (seq
)->data
[ibyte
];
1598 unsigned char *to
= &XSTRING (tem
)->data
[nbytes
];
1604 for (n
= cbytes
; n
--; )
1614 Lisp_Object tail
, prev
;
1616 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1619 wrong_type_argument (Qlistp
, seq
);
1621 if (!NILP (Fequal (elt
, XCAR (tail
))))
1626 Fsetcdr (prev
, XCDR (tail
));
1637 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1638 doc
: /* Reverse LIST by modifying cdr pointers.
1639 Returns the beginning of the reversed list. */)
1643 register Lisp_Object prev
, tail
, next
;
1645 if (NILP (list
)) return list
;
1648 while (!NILP (tail
))
1652 wrong_type_argument (Qlistp
, list
);
1654 Fsetcdr (tail
, prev
);
1661 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1662 doc
: /* Reverse LIST, copying. Returns the beginning of the reversed list.
1663 See also the function `nreverse', which is used more often. */)
1669 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1670 new = Fcons (XCAR (list
), new);
1672 wrong_type_argument (Qconsp
, list
);
1676 Lisp_Object
merge ();
1678 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1679 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1680 Returns the sorted list. LIST is modified by side effects.
1681 PREDICATE is called with two elements of LIST, and should return t
1682 if the first element is "less" than the second. */)
1684 Lisp_Object list
, predicate
;
1686 Lisp_Object front
, back
;
1687 register Lisp_Object len
, tem
;
1688 struct gcpro gcpro1
, gcpro2
;
1689 register int length
;
1692 len
= Flength (list
);
1693 length
= XINT (len
);
1697 XSETINT (len
, (length
/ 2) - 1);
1698 tem
= Fnthcdr (len
, list
);
1700 Fsetcdr (tem
, Qnil
);
1702 GCPRO2 (front
, back
);
1703 front
= Fsort (front
, predicate
);
1704 back
= Fsort (back
, predicate
);
1706 return merge (front
, back
, predicate
);
1710 merge (org_l1
, org_l2
, pred
)
1711 Lisp_Object org_l1
, org_l2
;
1715 register Lisp_Object tail
;
1717 register Lisp_Object l1
, l2
;
1718 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1725 /* It is sufficient to protect org_l1 and org_l2.
1726 When l1 and l2 are updated, we copy the new values
1727 back into the org_ vars. */
1728 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1748 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1764 Fsetcdr (tail
, tem
);
1770 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1771 doc
: /* Extract a value from a property list.
1772 PLIST is a property list, which is a list of the form
1773 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1774 corresponding to the given PROP, or nil if PROP is not
1775 one of the properties on the list. */)
1783 CONSP (tail
) && CONSP (XCDR (tail
));
1784 tail
= XCDR (XCDR (tail
)))
1786 if (EQ (prop
, XCAR (tail
)))
1787 return XCAR (XCDR (tail
));
1789 /* This function can be called asynchronously
1790 (setup_coding_system). Don't QUIT in that case. */
1791 if (!interrupt_input_blocked
)
1796 wrong_type_argument (Qlistp
, prop
);
1801 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1802 doc
: /* Return the value of SYMBOL's PROPNAME property.
1803 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1805 Lisp_Object symbol
, propname
;
1807 CHECK_SYMBOL (symbol
);
1808 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1811 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1812 doc
: /* Change value in PLIST of PROP to VAL.
1813 PLIST is a property list, which is a list of the form
1814 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1815 If PROP is already a property on the list, its value is set to VAL,
1816 otherwise the new PROP VAL pair is added. The new plist is returned;
1817 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1818 The PLIST is modified by side effects. */)
1821 register Lisp_Object prop
;
1824 register Lisp_Object tail
, prev
;
1825 Lisp_Object newcell
;
1827 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1828 tail
= XCDR (XCDR (tail
)))
1830 if (EQ (prop
, XCAR (tail
)))
1832 Fsetcar (XCDR (tail
), val
);
1839 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1843 Fsetcdr (XCDR (prev
), newcell
);
1847 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1848 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1849 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1850 (symbol
, propname
, value
)
1851 Lisp_Object symbol
, propname
, value
;
1853 CHECK_SYMBOL (symbol
);
1854 XSYMBOL (symbol
)->plist
1855 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1859 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1860 doc
: /* Return t if two Lisp objects have similar structure and contents.
1861 They must have the same data type.
1862 Conses are compared by comparing the cars and the cdrs.
1863 Vectors and strings are compared element by element.
1864 Numbers are compared by value, but integers cannot equal floats.
1865 (Use `=' if you want integers and floats to be able to be equal.)
1866 Symbols must match exactly. */)
1868 register Lisp_Object o1
, o2
;
1870 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1874 internal_equal (o1
, o2
, depth
)
1875 register Lisp_Object o1
, o2
;
1879 error ("Stack overflow in equal");
1885 if (XTYPE (o1
) != XTYPE (o2
))
1891 return (extract_float (o1
) == extract_float (o2
));
1894 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
1901 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1905 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
1907 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
1910 o1
= XOVERLAY (o1
)->plist
;
1911 o2
= XOVERLAY (o2
)->plist
;
1916 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1917 && (XMARKER (o1
)->buffer
== 0
1918 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1922 case Lisp_Vectorlike
:
1924 register int i
, size
;
1925 size
= XVECTOR (o1
)->size
;
1926 /* Pseudovectors have the type encoded in the size field, so this test
1927 actually checks that the objects have the same type as well as the
1929 if (XVECTOR (o2
)->size
!= size
)
1931 /* Boolvectors are compared much like strings. */
1932 if (BOOL_VECTOR_P (o1
))
1935 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1937 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1939 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1944 if (WINDOW_CONFIGURATIONP (o1
))
1945 return compare_window_configurations (o1
, o2
, 0);
1947 /* Aside from them, only true vectors, char-tables, and compiled
1948 functions are sensible to compare, so eliminate the others now. */
1949 if (size
& PSEUDOVECTOR_FLAG
)
1951 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
1952 | PVEC_SUB_CHAR_TABLE
)))
1954 size
&= PSEUDOVECTOR_SIZE_MASK
;
1956 for (i
= 0; i
< size
; i
++)
1959 v1
= XVECTOR (o1
)->contents
[i
];
1960 v2
= XVECTOR (o2
)->contents
[i
];
1961 if (!internal_equal (v1
, v2
, depth
+ 1))
1969 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1971 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1973 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1974 STRING_BYTES (XSTRING (o1
))))
1980 case Lisp_Type_Limit
:
1987 extern Lisp_Object
Fmake_char_internal ();
1989 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1990 doc
: /* Store each element of ARRAY with ITEM.
1991 ARRAY is a vector, string, char-table, or bool-vector. */)
1993 Lisp_Object array
, item
;
1995 register int size
, index
, charval
;
1997 if (VECTORP (array
))
1999 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2000 size
= XVECTOR (array
)->size
;
2001 for (index
= 0; index
< size
; index
++)
2004 else if (CHAR_TABLE_P (array
))
2008 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2009 XCHAR_TABLE (array
)->contents
[i
] = item
;
2010 XCHAR_TABLE (array
)->defalt
= item
;
2012 else if (STRINGP (array
))
2014 register unsigned char *p
= XSTRING (array
)->data
;
2015 CHECK_NUMBER (item
);
2016 charval
= XINT (item
);
2017 size
= XSTRING (array
)->size
;
2018 if (STRING_MULTIBYTE (array
))
2020 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2021 int len
= CHAR_STRING (charval
, str
);
2022 int size_byte
= STRING_BYTES (XSTRING (array
));
2023 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2026 if (size
!= size_byte
)
2029 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2030 if (len
!= this_len
)
2031 error ("Attempt to change byte length of a string");
2034 for (i
= 0; i
< size_byte
; i
++)
2035 *p
++ = str
[i
% len
];
2038 for (index
= 0; index
< size
; index
++)
2041 else if (BOOL_VECTOR_P (array
))
2043 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2045 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2047 charval
= (! NILP (item
) ? -1 : 0);
2048 for (index
= 0; index
< size_in_chars
; index
++)
2053 array
= wrong_type_argument (Qarrayp
, array
);
2066 Lisp_Object args
[2];
2069 return Fnconc (2, args
);
2071 return Fnconc (2, &s1
);
2072 #endif /* NO_ARG_ARRAY */
2075 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2076 doc
: /* Concatenate any number of lists by altering them.
2077 Only the last argument is not altered, and need not be a list.
2078 usage: (nconc &rest LISTS) */)
2083 register int argnum
;
2084 register Lisp_Object tail
, tem
, val
;
2088 for (argnum
= 0; argnum
< nargs
; argnum
++)
2091 if (NILP (tem
)) continue;
2096 if (argnum
+ 1 == nargs
) break;
2099 tem
= wrong_type_argument (Qlistp
, tem
);
2108 tem
= args
[argnum
+ 1];
2109 Fsetcdr (tail
, tem
);
2111 args
[argnum
+ 1] = tail
;
2117 /* This is the guts of all mapping functions.
2118 Apply FN to each element of SEQ, one by one,
2119 storing the results into elements of VALS, a C vector of Lisp_Objects.
2120 LENI is the length of VALS, which should also be the length of SEQ. */
2123 mapcar1 (leni
, vals
, fn
, seq
)
2126 Lisp_Object fn
, seq
;
2128 register Lisp_Object tail
;
2131 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2135 /* Don't let vals contain any garbage when GC happens. */
2136 for (i
= 0; i
< leni
; i
++)
2139 GCPRO3 (dummy
, fn
, seq
);
2141 gcpro1
.nvars
= leni
;
2145 /* We need not explicitly protect `tail' because it is used only on lists, and
2146 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2150 for (i
= 0; i
< leni
; i
++)
2152 dummy
= XVECTOR (seq
)->contents
[i
];
2153 dummy
= call1 (fn
, dummy
);
2158 else if (BOOL_VECTOR_P (seq
))
2160 for (i
= 0; i
< leni
; i
++)
2163 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2164 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2169 dummy
= call1 (fn
, dummy
);
2174 else if (STRINGP (seq
))
2178 for (i
= 0, i_byte
= 0; i
< leni
;)
2183 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2184 XSETFASTINT (dummy
, c
);
2185 dummy
= call1 (fn
, dummy
);
2187 vals
[i_before
] = dummy
;
2190 else /* Must be a list, since Flength did not get an error */
2193 for (i
= 0; i
< leni
; i
++)
2195 dummy
= call1 (fn
, Fcar (tail
));
2205 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2206 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2207 In between each pair of results, stick in SEPARATOR. Thus, " " as
2208 SEPARATOR results in spaces between the values returned by FUNCTION.
2209 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2210 (function
, sequence
, separator
)
2211 Lisp_Object function
, sequence
, separator
;
2216 register Lisp_Object
*args
;
2218 struct gcpro gcpro1
;
2220 len
= Flength (sequence
);
2222 nargs
= leni
+ leni
- 1;
2223 if (nargs
< 0) return build_string ("");
2225 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2228 mapcar1 (leni
, args
, function
, sequence
);
2231 for (i
= leni
- 1; i
>= 0; i
--)
2232 args
[i
+ i
] = args
[i
];
2234 for (i
= 1; i
< nargs
; i
+= 2)
2235 args
[i
] = separator
;
2237 return Fconcat (nargs
, args
);
2240 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2241 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2242 The result is a list just as long as SEQUENCE.
2243 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2244 (function
, sequence
)
2245 Lisp_Object function
, sequence
;
2247 register Lisp_Object len
;
2249 register Lisp_Object
*args
;
2251 len
= Flength (sequence
);
2252 leni
= XFASTINT (len
);
2253 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2255 mapcar1 (leni
, args
, function
, sequence
);
2257 return Flist (leni
, args
);
2260 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2261 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2262 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2263 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2264 (function
, sequence
)
2265 Lisp_Object function
, sequence
;
2269 leni
= XFASTINT (Flength (sequence
));
2270 mapcar1 (leni
, 0, function
, sequence
);
2275 /* Anything that calls this function must protect from GC! */
2277 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2278 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2279 Takes one argument, which is the string to display to ask the question.
2280 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2281 No confirmation of the answer is requested; a single character is enough.
2282 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2283 the bindings in `query-replace-map'; see the documentation of that variable
2284 for more information. In this case, the useful bindings are `act', `skip',
2285 `recenter', and `quit'.\)
2287 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2288 is nil and `use-dialog-box' is non-nil. */)
2292 register Lisp_Object obj
, key
, def
, map
;
2293 register int answer
;
2294 Lisp_Object xprompt
;
2295 Lisp_Object args
[2];
2296 struct gcpro gcpro1
, gcpro2
;
2297 int count
= specpdl_ptr
- specpdl
;
2299 specbind (Qcursor_in_echo_area
, Qt
);
2301 map
= Fsymbol_value (intern ("query-replace-map"));
2303 CHECK_STRING (prompt
);
2305 GCPRO2 (prompt
, xprompt
);
2307 #ifdef HAVE_X_WINDOWS
2308 if (display_hourglass_p
)
2309 cancel_hourglass ();
2316 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2320 Lisp_Object pane
, menu
;
2321 redisplay_preserve_echo_area (3);
2322 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2323 Fcons (Fcons (build_string ("No"), Qnil
),
2325 menu
= Fcons (prompt
, pane
);
2326 obj
= Fx_popup_dialog (Qt
, menu
);
2327 answer
= !NILP (obj
);
2330 #endif /* HAVE_MENUS */
2331 cursor_in_echo_area
= 1;
2332 choose_minibuf_frame ();
2333 message_with_string ("%s(y or n) ", xprompt
, 0);
2335 if (minibuffer_auto_raise
)
2337 Lisp_Object mini_frame
;
2339 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2341 Fraise_frame (mini_frame
);
2344 obj
= read_filtered_event (1, 0, 0, 0);
2345 cursor_in_echo_area
= 0;
2346 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2349 key
= Fmake_vector (make_number (1), obj
);
2350 def
= Flookup_key (map
, key
, Qt
);
2352 if (EQ (def
, intern ("skip")))
2357 else if (EQ (def
, intern ("act")))
2362 else if (EQ (def
, intern ("recenter")))
2368 else if (EQ (def
, intern ("quit")))
2370 /* We want to exit this command for exit-prefix,
2371 and this is the only way to do it. */
2372 else if (EQ (def
, intern ("exit-prefix")))
2377 /* If we don't clear this, then the next call to read_char will
2378 return quit_char again, and we'll enter an infinite loop. */
2383 if (EQ (xprompt
, prompt
))
2385 args
[0] = build_string ("Please answer y or n. ");
2387 xprompt
= Fconcat (2, args
);
2392 if (! noninteractive
)
2394 cursor_in_echo_area
= -1;
2395 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2399 unbind_to (count
, Qnil
);
2400 return answer
? Qt
: Qnil
;
2403 /* This is how C code calls `yes-or-no-p' and allows the user
2406 Anything that calls this function must protect from GC! */
2409 do_yes_or_no_p (prompt
)
2412 return call1 (intern ("yes-or-no-p"), prompt
);
2415 /* Anything that calls this function must protect from GC! */
2417 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2418 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2419 Takes one argument, which is the string to display to ask the question.
2420 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2421 The user must confirm the answer with RET,
2422 and can edit it until it has been confirmed.
2424 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2425 is nil, and `use-dialog-box' is non-nil. */)
2429 register Lisp_Object ans
;
2430 Lisp_Object args
[2];
2431 struct gcpro gcpro1
;
2433 CHECK_STRING (prompt
);
2436 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2440 Lisp_Object pane
, menu
, obj
;
2441 redisplay_preserve_echo_area (4);
2442 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2443 Fcons (Fcons (build_string ("No"), Qnil
),
2446 menu
= Fcons (prompt
, pane
);
2447 obj
= Fx_popup_dialog (Qt
, menu
);
2451 #endif /* HAVE_MENUS */
2454 args
[1] = build_string ("(yes or no) ");
2455 prompt
= Fconcat (2, args
);
2461 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2462 Qyes_or_no_p_history
, Qnil
,
2464 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2469 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2477 message ("Please answer yes or no.");
2478 Fsleep_for (make_number (2), Qnil
);
2482 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2483 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2485 Each of the three load averages is multiplied by 100, then converted
2488 When USE-FLOATS is non-nil, floats will be used instead of integers.
2489 These floats are not multiplied by 100.
2491 If the 5-minute or 15-minute load averages are not available, return a
2492 shortened list, containing only those averages which are available. */)
2494 Lisp_Object use_floats
;
2497 int loads
= getloadavg (load_ave
, 3);
2498 Lisp_Object ret
= Qnil
;
2501 error ("load-average not implemented for this operating system");
2505 Lisp_Object load
= (NILP (use_floats
) ?
2506 make_number ((int) (100.0 * load_ave
[loads
]))
2507 : make_float (load_ave
[loads
]));
2508 ret
= Fcons (load
, ret
);
2514 Lisp_Object Vfeatures
, Qsubfeatures
;
2515 extern Lisp_Object Vafter_load_alist
;
2517 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2518 doc
: /* Returns t if FEATURE is present in this Emacs.
2520 Use this to conditionalize execution of lisp code based on the
2521 presence or absence of emacs or environment extensions.
2522 Use `provide' to declare that a feature is available. This function
2523 looks at the value of the variable `features'. The optional argument
2524 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2525 (feature
, subfeature
)
2526 Lisp_Object feature
, subfeature
;
2528 register Lisp_Object tem
;
2529 CHECK_SYMBOL (feature
);
2530 tem
= Fmemq (feature
, Vfeatures
);
2531 if (!NILP (tem
) && !NILP (subfeature
))
2532 tem
= Fmemq (subfeature
, Fget (feature
, Qsubfeatures
));
2533 return (NILP (tem
)) ? Qnil
: Qt
;
2536 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2537 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2538 The optional argument SUBFEATURES should be a list of symbols listing
2539 particular subfeatures supported in this version of FEATURE. */)
2540 (feature
, subfeatures
)
2541 Lisp_Object feature
, subfeatures
;
2543 register Lisp_Object tem
;
2544 CHECK_SYMBOL (feature
);
2545 if (!NILP (Vautoload_queue
))
2546 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2547 tem
= Fmemq (feature
, Vfeatures
);
2549 Vfeatures
= Fcons (feature
, Vfeatures
);
2550 if (!NILP (subfeatures
))
2551 Fput (feature
, Qsubfeatures
, subfeatures
);
2552 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2554 /* Run any load-hooks for this file. */
2555 tem
= Fassq (feature
, Vafter_load_alist
);
2557 Fprogn (Fcdr (tem
));
2562 /* `require' and its subroutines. */
2564 /* List of features currently being require'd, innermost first. */
2566 Lisp_Object require_nesting_list
;
2569 require_unwind (old_value
)
2570 Lisp_Object old_value
;
2572 return require_nesting_list
= old_value
;
2575 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2576 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2577 If FEATURE is not a member of the list `features', then the feature
2578 is not loaded; so load the file FILENAME.
2579 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2580 and `load' will try to load this name appended with the suffix `.elc',
2581 `.el' or the unmodified name, in that order.
2582 If the optional third argument NOERROR is non-nil,
2583 then return nil if the file is not found instead of signaling an error.
2584 Normally the return value is FEATURE.
2585 The normal messages at start and end of loading FILENAME are suppressed. */)
2586 (feature
, filename
, noerror
)
2587 Lisp_Object feature
, filename
, noerror
;
2589 register Lisp_Object tem
;
2590 struct gcpro gcpro1
, gcpro2
;
2592 CHECK_SYMBOL (feature
);
2594 tem
= Fmemq (feature
, Vfeatures
);
2596 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2600 int count
= specpdl_ptr
- specpdl
;
2603 /* A certain amount of recursive `require' is legitimate,
2604 but if we require the same feature recursively 3 times,
2606 tem
= require_nesting_list
;
2607 while (! NILP (tem
))
2609 if (! NILP (Fequal (feature
, XCAR (tem
))))
2614 error ("Recursive `require' for feature `%s'",
2615 XSYMBOL (feature
)->name
->data
);
2617 /* Update the list for any nested `require's that occur. */
2618 record_unwind_protect (require_unwind
, require_nesting_list
);
2619 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2621 /* Value saved here is to be restored into Vautoload_queue */
2622 record_unwind_protect (un_autoload
, Vautoload_queue
);
2623 Vautoload_queue
= Qt
;
2625 /* Load the file. */
2626 GCPRO2 (feature
, filename
);
2627 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2628 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2631 /* If load failed entirely, return nil. */
2633 return unbind_to (count
, Qnil
);
2635 tem
= Fmemq (feature
, Vfeatures
);
2637 error ("Required feature `%s' was not provided",
2638 XSYMBOL (feature
)->name
->data
);
2640 /* Once loading finishes, don't undo it. */
2641 Vautoload_queue
= Qt
;
2642 feature
= unbind_to (count
, feature
);
2648 /* Primitives for work of the "widget" library.
2649 In an ideal world, this section would not have been necessary.
2650 However, lisp function calls being as slow as they are, it turns
2651 out that some functions in the widget library (wid-edit.el) are the
2652 bottleneck of Widget operation. Here is their translation to C,
2653 for the sole reason of efficiency. */
2655 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2656 doc
: /* Return non-nil if PLIST has the property PROP.
2657 PLIST is a property list, which is a list of the form
2658 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2659 Unlike `plist-get', this allows you to distinguish between a missing
2660 property and a property with the value nil.
2661 The value is actually the tail of PLIST whose car is PROP. */)
2663 Lisp_Object plist
, prop
;
2665 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2668 plist
= XCDR (plist
);
2669 plist
= CDR (plist
);
2674 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2675 doc
: /* In WIDGET, set PROPERTY to VALUE.
2676 The value can later be retrieved with `widget-get'. */)
2677 (widget
, property
, value
)
2678 Lisp_Object widget
, property
, value
;
2680 CHECK_CONS (widget
);
2681 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2685 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2686 doc
: /* In WIDGET, get the value of PROPERTY.
2687 The value could either be specified when the widget was created, or
2688 later with `widget-put'. */)
2690 Lisp_Object widget
, property
;
2698 CHECK_CONS (widget
);
2699 tmp
= Fplist_member (XCDR (widget
), property
);
2705 tmp
= XCAR (widget
);
2708 widget
= Fget (tmp
, Qwidget_type
);
2712 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2713 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2714 ARGS are passed as extra arguments to the function.
2715 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2720 /* This function can GC. */
2721 Lisp_Object newargs
[3];
2722 struct gcpro gcpro1
, gcpro2
;
2725 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2726 newargs
[1] = args
[0];
2727 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2728 GCPRO2 (newargs
[0], newargs
[2]);
2729 result
= Fapply (3, newargs
);
2734 /* base64 encode/decode functions (RFC 2045).
2735 Based on code from GNU recode. */
2737 #define MIME_LINE_LENGTH 76
2739 #define IS_ASCII(Character) \
2741 #define IS_BASE64(Character) \
2742 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2743 #define IS_BASE64_IGNORABLE(Character) \
2744 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2745 || (Character) == '\f' || (Character) == '\r')
2747 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2748 character or return retval if there are no characters left to
2750 #define READ_QUADRUPLET_BYTE(retval) \
2755 if (nchars_return) \
2756 *nchars_return = nchars; \
2761 while (IS_BASE64_IGNORABLE (c))
2763 /* Don't use alloca for regions larger than this, lest we overflow
2765 #define MAX_ALLOCA 16*1024
2767 /* Table of characters coding the 64 values. */
2768 static char base64_value_to_char
[64] =
2770 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2771 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2772 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2773 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2774 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2775 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2776 '8', '9', '+', '/' /* 60-63 */
2779 /* Table of base64 values for first 128 characters. */
2780 static short base64_char_to_value
[128] =
2782 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2783 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2784 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2785 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2786 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2787 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2788 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2789 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2790 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2791 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2792 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2793 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2794 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2797 /* The following diagram shows the logical steps by which three octets
2798 get transformed into four base64 characters.
2800 .--------. .--------. .--------.
2801 |aaaaaabb| |bbbbcccc| |ccdddddd|
2802 `--------' `--------' `--------'
2804 .--------+--------+--------+--------.
2805 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2806 `--------+--------+--------+--------'
2808 .--------+--------+--------+--------.
2809 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2810 `--------+--------+--------+--------'
2812 The octets are divided into 6 bit chunks, which are then encoded into
2813 base64 characters. */
2816 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
2817 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
2819 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2821 doc
: /* Base64-encode the region between BEG and END.
2822 Return the length of the encoded text.
2823 Optional third argument NO-LINE-BREAK means do not break long lines
2824 into shorter lines. */)
2825 (beg
, end
, no_line_break
)
2826 Lisp_Object beg
, end
, no_line_break
;
2829 int allength
, length
;
2830 int ibeg
, iend
, encoded_length
;
2833 validate_region (&beg
, &end
);
2835 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2836 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2837 move_gap_both (XFASTINT (beg
), ibeg
);
2839 /* We need to allocate enough room for encoding the text.
2840 We need 33 1/3% more space, plus a newline every 76
2841 characters, and then we round up. */
2842 length
= iend
- ibeg
;
2843 allength
= length
+ length
/3 + 1;
2844 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2846 if (allength
<= MAX_ALLOCA
)
2847 encoded
= (char *) alloca (allength
);
2849 encoded
= (char *) xmalloc (allength
);
2850 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2851 NILP (no_line_break
),
2852 !NILP (current_buffer
->enable_multibyte_characters
));
2853 if (encoded_length
> allength
)
2856 if (encoded_length
< 0)
2858 /* The encoding wasn't possible. */
2859 if (length
> MAX_ALLOCA
)
2861 error ("Multibyte character in data for base64 encoding");
2864 /* Now we have encoded the region, so we insert the new contents
2865 and delete the old. (Insert first in order to preserve markers.) */
2866 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2867 insert (encoded
, encoded_length
);
2868 if (allength
> MAX_ALLOCA
)
2870 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2872 /* If point was outside of the region, restore it exactly; else just
2873 move to the beginning of the region. */
2874 if (old_pos
>= XFASTINT (end
))
2875 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2876 else if (old_pos
> XFASTINT (beg
))
2877 old_pos
= XFASTINT (beg
);
2880 /* We return the length of the encoded text. */
2881 return make_number (encoded_length
);
2884 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2886 doc
: /* Base64-encode STRING and return the result.
2887 Optional second argument NO-LINE-BREAK means do not break long lines
2888 into shorter lines. */)
2889 (string
, no_line_break
)
2890 Lisp_Object string
, no_line_break
;
2892 int allength
, length
, encoded_length
;
2894 Lisp_Object encoded_string
;
2896 CHECK_STRING (string
);
2898 /* We need to allocate enough room for encoding the text.
2899 We need 33 1/3% more space, plus a newline every 76
2900 characters, and then we round up. */
2901 length
= STRING_BYTES (XSTRING (string
));
2902 allength
= length
+ length
/3 + 1;
2903 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2905 /* We need to allocate enough room for decoding the text. */
2906 if (allength
<= MAX_ALLOCA
)
2907 encoded
= (char *) alloca (allength
);
2909 encoded
= (char *) xmalloc (allength
);
2911 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
2912 encoded
, length
, NILP (no_line_break
),
2913 STRING_MULTIBYTE (string
));
2914 if (encoded_length
> allength
)
2917 if (encoded_length
< 0)
2919 /* The encoding wasn't possible. */
2920 if (length
> MAX_ALLOCA
)
2922 error ("Multibyte character in data for base64 encoding");
2925 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
2926 if (allength
> MAX_ALLOCA
)
2929 return encoded_string
;
2933 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
2940 int counter
= 0, i
= 0;
2950 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
2958 /* Wrap line every 76 characters. */
2962 if (counter
< MIME_LINE_LENGTH
/ 4)
2971 /* Process first byte of a triplet. */
2973 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
2974 value
= (0x03 & c
) << 4;
2976 /* Process second byte of a triplet. */
2980 *e
++ = base64_value_to_char
[value
];
2988 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
2996 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
2997 value
= (0x0f & c
) << 2;
2999 /* Process third byte of a triplet. */
3003 *e
++ = base64_value_to_char
[value
];
3010 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3018 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3019 *e
++ = base64_value_to_char
[0x3f & c
];
3026 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3028 doc
: /* Base64-decode the region between BEG and END.
3029 Return the length of the decoded text.
3030 If the region can't be decoded, signal an error and don't modify the buffer. */)
3032 Lisp_Object beg
, end
;
3034 int ibeg
, iend
, length
, allength
;
3039 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3041 validate_region (&beg
, &end
);
3043 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3044 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3046 length
= iend
- ibeg
;
3048 /* We need to allocate enough room for decoding the text. If we are
3049 working on a multibyte buffer, each decoded code may occupy at
3051 allength
= multibyte
? length
* 2 : length
;
3052 if (allength
<= MAX_ALLOCA
)
3053 decoded
= (char *) alloca (allength
);
3055 decoded
= (char *) xmalloc (allength
);
3057 move_gap_both (XFASTINT (beg
), ibeg
);
3058 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3059 multibyte
, &inserted_chars
);
3060 if (decoded_length
> allength
)
3063 if (decoded_length
< 0)
3065 /* The decoding wasn't possible. */
3066 if (allength
> MAX_ALLOCA
)
3068 error ("Invalid base64 data");
3071 /* Now we have decoded the region, so we insert the new contents
3072 and delete the old. (Insert first in order to preserve markers.) */
3073 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3074 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3075 if (allength
> MAX_ALLOCA
)
3077 /* Delete the original text. */
3078 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3079 iend
+ decoded_length
, 1);
3081 /* If point was outside of the region, restore it exactly; else just
3082 move to the beginning of the region. */
3083 if (old_pos
>= XFASTINT (end
))
3084 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3085 else if (old_pos
> XFASTINT (beg
))
3086 old_pos
= XFASTINT (beg
);
3087 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3089 return make_number (inserted_chars
);
3092 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3094 doc
: /* Base64-decode STRING and return the result. */)
3099 int length
, decoded_length
;
3100 Lisp_Object decoded_string
;
3102 CHECK_STRING (string
);
3104 length
= STRING_BYTES (XSTRING (string
));
3105 /* We need to allocate enough room for decoding the text. */
3106 if (length
<= MAX_ALLOCA
)
3107 decoded
= (char *) alloca (length
);
3109 decoded
= (char *) xmalloc (length
);
3111 /* The decoded result should be unibyte. */
3112 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
,
3114 if (decoded_length
> length
)
3116 else if (decoded_length
>= 0)
3117 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3119 decoded_string
= Qnil
;
3121 if (length
> MAX_ALLOCA
)
3123 if (!STRINGP (decoded_string
))
3124 error ("Invalid base64 data");
3126 return decoded_string
;
3129 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3130 MULTIBYTE is nonzero, the decoded result should be in multibyte
3131 form. If NCHARS_RETRUN is not NULL, store the number of produced
3132 characters in *NCHARS_RETURN. */
3135 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3145 unsigned long value
;
3150 /* Process first byte of a quadruplet. */
3152 READ_QUADRUPLET_BYTE (e
-to
);
3156 value
= base64_char_to_value
[c
] << 18;
3158 /* Process second byte of a quadruplet. */
3160 READ_QUADRUPLET_BYTE (-1);
3164 value
|= base64_char_to_value
[c
] << 12;
3166 c
= (unsigned char) (value
>> 16);
3168 e
+= CHAR_STRING (c
, e
);
3173 /* Process third byte of a quadruplet. */
3175 READ_QUADRUPLET_BYTE (-1);
3179 READ_QUADRUPLET_BYTE (-1);
3188 value
|= base64_char_to_value
[c
] << 6;
3190 c
= (unsigned char) (0xff & value
>> 8);
3192 e
+= CHAR_STRING (c
, e
);
3197 /* Process fourth byte of a quadruplet. */
3199 READ_QUADRUPLET_BYTE (-1);
3206 value
|= base64_char_to_value
[c
];
3208 c
= (unsigned char) (0xff & value
);
3210 e
+= CHAR_STRING (c
, e
);
3219 /***********************************************************************
3221 ***** Hash Tables *****
3223 ***********************************************************************/
3225 /* Implemented by gerd@gnu.org. This hash table implementation was
3226 inspired by CMUCL hash tables. */
3230 1. For small tables, association lists are probably faster than
3231 hash tables because they have lower overhead.
3233 For uses of hash tables where the O(1) behavior of table
3234 operations is not a requirement, it might therefore be a good idea
3235 not to hash. Instead, we could just do a linear search in the
3236 key_and_value vector of the hash table. This could be done
3237 if a `:linear-search t' argument is given to make-hash-table. */
3240 /* Value is the index of the next entry following the one at IDX
3243 #define HASH_NEXT(H, IDX) AREF ((H)->next, (IDX))
3245 /* Value is the hash code computed for entry IDX in hash table H. */
3247 #define HASH_HASH(H, IDX) AREF ((H)->hash, (IDX))
3249 /* Value is the index of the element in hash table H that is the
3250 start of the collision list at index IDX in the index vector of H. */
3252 #define HASH_INDEX(H, IDX) AREF ((H)->index, (IDX))
3254 /* Value is the size of hash table H. */
3256 #define HASH_TABLE_SIZE(H) XVECTOR ((H)->next)->size
3258 /* The list of all weak hash tables. Don't staticpro this one. */
3260 Lisp_Object Vweak_hash_tables
;
3262 /* Various symbols. */
3264 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3265 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3266 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3268 /* Function prototypes. */
3270 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3271 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3272 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3273 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3274 Lisp_Object
, unsigned));
3275 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3276 Lisp_Object
, unsigned));
3277 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3278 unsigned, Lisp_Object
, unsigned));
3279 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3280 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3281 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3282 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3284 static unsigned sxhash_string
P_ ((unsigned char *, int));
3285 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3286 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3287 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3288 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3292 /***********************************************************************
3294 ***********************************************************************/
3296 /* If OBJ is a Lisp hash table, return a pointer to its struct
3297 Lisp_Hash_Table. Otherwise, signal an error. */
3299 static struct Lisp_Hash_Table
*
3300 check_hash_table (obj
)
3303 CHECK_HASH_TABLE (obj
);
3304 return XHASH_TABLE (obj
);
3308 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3312 next_almost_prime (n
)
3325 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3326 which USED[I] is non-zero. If found at index I in ARGS, set
3327 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3328 -1. This function is used to extract a keyword/argument pair from
3329 a DEFUN parameter list. */
3332 get_key_arg (key
, nargs
, args
, used
)
3340 for (i
= 0; i
< nargs
- 1; ++i
)
3341 if (!used
[i
] && EQ (args
[i
], key
))
3356 /* Return a Lisp vector which has the same contents as VEC but has
3357 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3358 vector that are not copied from VEC are set to INIT. */
3361 larger_vector (vec
, new_size
, init
)
3366 struct Lisp_Vector
*v
;
3369 xassert (VECTORP (vec
));
3370 old_size
= XVECTOR (vec
)->size
;
3371 xassert (new_size
>= old_size
);
3373 v
= allocate_vector (new_size
);
3374 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3375 old_size
* sizeof *v
->contents
);
3376 for (i
= old_size
; i
< new_size
; ++i
)
3377 v
->contents
[i
] = init
;
3378 XSETVECTOR (vec
, v
);
3383 /***********************************************************************
3385 ***********************************************************************/
3387 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3388 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3389 KEY2 are the same. */
3392 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3393 struct Lisp_Hash_Table
*h
;
3394 Lisp_Object key1
, key2
;
3395 unsigned hash1
, hash2
;
3397 return (FLOATP (key1
)
3399 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3403 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3404 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3405 KEY2 are the same. */
3408 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3409 struct Lisp_Hash_Table
*h
;
3410 Lisp_Object key1
, key2
;
3411 unsigned hash1
, hash2
;
3413 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3417 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3418 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3419 if KEY1 and KEY2 are the same. */
3422 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3423 struct Lisp_Hash_Table
*h
;
3424 Lisp_Object key1
, key2
;
3425 unsigned hash1
, hash2
;
3429 Lisp_Object args
[3];
3431 args
[0] = h
->user_cmp_function
;
3434 return !NILP (Ffuncall (3, args
));
3441 /* Value is a hash code for KEY for use in hash table H which uses
3442 `eq' to compare keys. The hash code returned is guaranteed to fit
3443 in a Lisp integer. */
3447 struct Lisp_Hash_Table
*h
;
3450 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3451 xassert ((hash
& ~VALMASK
) == 0);
3456 /* Value is a hash code for KEY for use in hash table H which uses
3457 `eql' to compare keys. The hash code returned is guaranteed to fit
3458 in a Lisp integer. */
3462 struct Lisp_Hash_Table
*h
;
3467 hash
= sxhash (key
, 0);
3469 hash
= XUINT (key
) ^ XGCTYPE (key
);
3470 xassert ((hash
& ~VALMASK
) == 0);
3475 /* Value is a hash code for KEY for use in hash table H which uses
3476 `equal' to compare keys. The hash code returned is guaranteed to fit
3477 in a Lisp integer. */
3480 hashfn_equal (h
, key
)
3481 struct Lisp_Hash_Table
*h
;
3484 unsigned hash
= sxhash (key
, 0);
3485 xassert ((hash
& ~VALMASK
) == 0);
3490 /* Value is a hash code for KEY for use in hash table H which uses as
3491 user-defined function to compare keys. The hash code returned is
3492 guaranteed to fit in a Lisp integer. */
3495 hashfn_user_defined (h
, key
)
3496 struct Lisp_Hash_Table
*h
;
3499 Lisp_Object args
[2], hash
;
3501 args
[0] = h
->user_hash_function
;
3503 hash
= Ffuncall (2, args
);
3504 if (!INTEGERP (hash
))
3506 list2 (build_string ("Invalid hash code returned from \
3507 user-supplied hash function"),
3509 return XUINT (hash
);
3513 /* Create and initialize a new hash table.
3515 TEST specifies the test the hash table will use to compare keys.
3516 It must be either one of the predefined tests `eq', `eql' or
3517 `equal' or a symbol denoting a user-defined test named TEST with
3518 test and hash functions USER_TEST and USER_HASH.
3520 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3522 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3523 new size when it becomes full is computed by adding REHASH_SIZE to
3524 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3525 table's new size is computed by multiplying its old size with
3528 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3529 be resized when the ratio of (number of entries in the table) /
3530 (table size) is >= REHASH_THRESHOLD.
3532 WEAK specifies the weakness of the table. If non-nil, it must be
3533 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3536 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3537 user_test
, user_hash
)
3538 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3539 Lisp_Object user_test
, user_hash
;
3541 struct Lisp_Hash_Table
*h
;
3543 int index_size
, i
, sz
;
3545 /* Preconditions. */
3546 xassert (SYMBOLP (test
));
3547 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3548 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3549 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3550 xassert (FLOATP (rehash_threshold
)
3551 && XFLOATINT (rehash_threshold
) > 0
3552 && XFLOATINT (rehash_threshold
) <= 1.0);
3554 if (XFASTINT (size
) == 0)
3555 size
= make_number (1);
3557 /* Allocate a table and initialize it. */
3558 h
= allocate_hash_table ();
3560 /* Initialize hash table slots. */
3561 sz
= XFASTINT (size
);
3564 if (EQ (test
, Qeql
))
3566 h
->cmpfn
= cmpfn_eql
;
3567 h
->hashfn
= hashfn_eql
;
3569 else if (EQ (test
, Qeq
))
3572 h
->hashfn
= hashfn_eq
;
3574 else if (EQ (test
, Qequal
))
3576 h
->cmpfn
= cmpfn_equal
;
3577 h
->hashfn
= hashfn_equal
;
3581 h
->user_cmp_function
= user_test
;
3582 h
->user_hash_function
= user_hash
;
3583 h
->cmpfn
= cmpfn_user_defined
;
3584 h
->hashfn
= hashfn_user_defined
;
3588 h
->rehash_threshold
= rehash_threshold
;
3589 h
->rehash_size
= rehash_size
;
3590 h
->count
= make_number (0);
3591 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3592 h
->hash
= Fmake_vector (size
, Qnil
);
3593 h
->next
= Fmake_vector (size
, Qnil
);
3594 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3595 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3596 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3598 /* Set up the free list. */
3599 for (i
= 0; i
< sz
- 1; ++i
)
3600 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3601 h
->next_free
= make_number (0);
3603 XSET_HASH_TABLE (table
, h
);
3604 xassert (HASH_TABLE_P (table
));
3605 xassert (XHASH_TABLE (table
) == h
);
3607 /* Maybe add this hash table to the list of all weak hash tables. */
3609 h
->next_weak
= Qnil
;
3612 h
->next_weak
= Vweak_hash_tables
;
3613 Vweak_hash_tables
= table
;
3620 /* Return a copy of hash table H1. Keys and values are not copied,
3621 only the table itself is. */
3624 copy_hash_table (h1
)
3625 struct Lisp_Hash_Table
*h1
;
3628 struct Lisp_Hash_Table
*h2
;
3629 struct Lisp_Vector
*next
;
3631 h2
= allocate_hash_table ();
3632 next
= h2
->vec_next
;
3633 bcopy (h1
, h2
, sizeof *h2
);
3634 h2
->vec_next
= next
;
3635 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3636 h2
->hash
= Fcopy_sequence (h1
->hash
);
3637 h2
->next
= Fcopy_sequence (h1
->next
);
3638 h2
->index
= Fcopy_sequence (h1
->index
);
3639 XSET_HASH_TABLE (table
, h2
);
3641 /* Maybe add this hash table to the list of all weak hash tables. */
3642 if (!NILP (h2
->weak
))
3644 h2
->next_weak
= Vweak_hash_tables
;
3645 Vweak_hash_tables
= table
;
3652 /* Resize hash table H if it's too full. If H cannot be resized
3653 because it's already too large, throw an error. */
3656 maybe_resize_hash_table (h
)
3657 struct Lisp_Hash_Table
*h
;
3659 if (NILP (h
->next_free
))
3661 int old_size
= HASH_TABLE_SIZE (h
);
3662 int i
, new_size
, index_size
;
3664 if (INTEGERP (h
->rehash_size
))
3665 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3667 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3668 new_size
= max (old_size
+ 1, new_size
);
3669 index_size
= next_almost_prime ((int)
3671 / XFLOATINT (h
->rehash_threshold
)));
3672 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3673 error ("Hash table too large to resize");
3675 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3676 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3677 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3678 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3680 /* Update the free list. Do it so that new entries are added at
3681 the end of the free list. This makes some operations like
3683 for (i
= old_size
; i
< new_size
- 1; ++i
)
3684 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3686 if (!NILP (h
->next_free
))
3688 Lisp_Object last
, next
;
3690 last
= h
->next_free
;
3691 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3695 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3698 XSETFASTINT (h
->next_free
, old_size
);
3701 for (i
= 0; i
< old_size
; ++i
)
3702 if (!NILP (HASH_HASH (h
, i
)))
3704 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
3705 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3706 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3707 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3713 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3714 the hash code of KEY. Value is the index of the entry in H
3715 matching KEY, or -1 if not found. */
3718 hash_lookup (h
, key
, hash
)
3719 struct Lisp_Hash_Table
*h
;
3724 int start_of_bucket
;
3727 hash_code
= h
->hashfn (h
, key
);
3731 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3732 idx
= HASH_INDEX (h
, start_of_bucket
);
3734 /* We need not gcpro idx since it's either an integer or nil. */
3737 int i
= XFASTINT (idx
);
3738 if (EQ (key
, HASH_KEY (h
, i
))
3740 && h
->cmpfn (h
, key
, hash_code
,
3741 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3743 idx
= HASH_NEXT (h
, i
);
3746 return NILP (idx
) ? -1 : XFASTINT (idx
);
3750 /* Put an entry into hash table H that associates KEY with VALUE.
3751 HASH is a previously computed hash code of KEY.
3752 Value is the index of the entry in H matching KEY. */
3755 hash_put (h
, key
, value
, hash
)
3756 struct Lisp_Hash_Table
*h
;
3757 Lisp_Object key
, value
;
3760 int start_of_bucket
, i
;
3762 xassert ((hash
& ~VALMASK
) == 0);
3764 /* Increment count after resizing because resizing may fail. */
3765 maybe_resize_hash_table (h
);
3766 h
->count
= make_number (XFASTINT (h
->count
) + 1);
3768 /* Store key/value in the key_and_value vector. */
3769 i
= XFASTINT (h
->next_free
);
3770 h
->next_free
= HASH_NEXT (h
, i
);
3771 HASH_KEY (h
, i
) = key
;
3772 HASH_VALUE (h
, i
) = value
;
3774 /* Remember its hash code. */
3775 HASH_HASH (h
, i
) = make_number (hash
);
3777 /* Add new entry to its collision chain. */
3778 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
3779 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
3780 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
3785 /* Remove the entry matching KEY from hash table H, if there is one. */
3788 hash_remove (h
, key
)
3789 struct Lisp_Hash_Table
*h
;
3793 int start_of_bucket
;
3794 Lisp_Object idx
, prev
;
3796 hash_code
= h
->hashfn (h
, key
);
3797 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
3798 idx
= HASH_INDEX (h
, start_of_bucket
);
3801 /* We need not gcpro idx, prev since they're either integers or nil. */
3804 int i
= XFASTINT (idx
);
3806 if (EQ (key
, HASH_KEY (h
, i
))
3808 && h
->cmpfn (h
, key
, hash_code
,
3809 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
3811 /* Take entry out of collision chain. */
3813 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
3815 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
3817 /* Clear slots in key_and_value and add the slots to
3819 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
3820 HASH_NEXT (h
, i
) = h
->next_free
;
3821 h
->next_free
= make_number (i
);
3822 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3823 xassert (XINT (h
->count
) >= 0);
3829 idx
= HASH_NEXT (h
, i
);
3835 /* Clear hash table H. */
3839 struct Lisp_Hash_Table
*h
;
3841 if (XFASTINT (h
->count
) > 0)
3843 int i
, size
= HASH_TABLE_SIZE (h
);
3845 for (i
= 0; i
< size
; ++i
)
3847 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
3848 HASH_KEY (h
, i
) = Qnil
;
3849 HASH_VALUE (h
, i
) = Qnil
;
3850 HASH_HASH (h
, i
) = Qnil
;
3853 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
3854 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
3856 h
->next_free
= make_number (0);
3857 h
->count
= make_number (0);
3863 /************************************************************************
3865 ************************************************************************/
3867 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
3868 entries from the table that don't survive the current GC.
3869 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
3870 non-zero if anything was marked. */
3873 sweep_weak_table (h
, remove_entries_p
)
3874 struct Lisp_Hash_Table
*h
;
3875 int remove_entries_p
;
3877 int bucket
, n
, marked
;
3879 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
3882 for (bucket
= 0; bucket
< n
; ++bucket
)
3884 Lisp_Object idx
, next
, prev
;
3886 /* Follow collision chain, removing entries that
3887 don't survive this garbage collection. */
3889 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
3891 int i
= XFASTINT (idx
);
3892 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
3893 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
3896 if (EQ (h
->weak
, Qkey
))
3897 remove_p
= !key_known_to_survive_p
;
3898 else if (EQ (h
->weak
, Qvalue
))
3899 remove_p
= !value_known_to_survive_p
;
3900 else if (EQ (h
->weak
, Qkey_or_value
))
3901 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
3902 else if (EQ (h
->weak
, Qkey_and_value
))
3903 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
3907 next
= HASH_NEXT (h
, i
);
3909 if (remove_entries_p
)
3913 /* Take out of collision chain. */
3915 HASH_INDEX (h
, bucket
) = next
;
3917 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
3919 /* Add to free list. */
3920 HASH_NEXT (h
, i
) = h
->next_free
;
3923 /* Clear key, value, and hash. */
3924 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
3925 HASH_HASH (h
, i
) = Qnil
;
3927 h
->count
= make_number (XFASTINT (h
->count
) - 1);
3934 /* Make sure key and value survive. */
3935 if (!key_known_to_survive_p
)
3937 mark_object (&HASH_KEY (h
, i
));
3941 if (!value_known_to_survive_p
)
3943 mark_object (&HASH_VALUE (h
, i
));
3954 /* Remove elements from weak hash tables that don't survive the
3955 current garbage collection. Remove weak tables that don't survive
3956 from Vweak_hash_tables. Called from gc_sweep. */
3959 sweep_weak_hash_tables ()
3961 Lisp_Object table
, used
, next
;
3962 struct Lisp_Hash_Table
*h
;
3965 /* Mark all keys and values that are in use. Keep on marking until
3966 there is no more change. This is necessary for cases like
3967 value-weak table A containing an entry X -> Y, where Y is used in a
3968 key-weak table B, Z -> Y. If B comes after A in the list of weak
3969 tables, X -> Y might be removed from A, although when looking at B
3970 one finds that it shouldn't. */
3974 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
3976 h
= XHASH_TABLE (table
);
3977 if (h
->size
& ARRAY_MARK_FLAG
)
3978 marked
|= sweep_weak_table (h
, 0);
3983 /* Remove tables and entries that aren't used. */
3984 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
3986 h
= XHASH_TABLE (table
);
3987 next
= h
->next_weak
;
3989 if (h
->size
& ARRAY_MARK_FLAG
)
3991 /* TABLE is marked as used. Sweep its contents. */
3992 if (XFASTINT (h
->count
) > 0)
3993 sweep_weak_table (h
, 1);
3995 /* Add table to the list of used weak hash tables. */
3996 h
->next_weak
= used
;
4001 Vweak_hash_tables
= used
;
4006 /***********************************************************************
4007 Hash Code Computation
4008 ***********************************************************************/
4010 /* Maximum depth up to which to dive into Lisp structures. */
4012 #define SXHASH_MAX_DEPTH 3
4014 /* Maximum length up to which to take list and vector elements into
4017 #define SXHASH_MAX_LEN 7
4019 /* Combine two integers X and Y for hashing. */
4021 #define SXHASH_COMBINE(X, Y) \
4022 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4026 /* Return a hash for string PTR which has length LEN. The hash
4027 code returned is guaranteed to fit in a Lisp integer. */
4030 sxhash_string (ptr
, len
)
4034 unsigned char *p
= ptr
;
4035 unsigned char *end
= p
+ len
;
4044 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4047 return hash
& VALMASK
;
4051 /* Return a hash for list LIST. DEPTH is the current depth in the
4052 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4055 sxhash_list (list
, depth
)
4062 if (depth
< SXHASH_MAX_DEPTH
)
4064 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4065 list
= XCDR (list
), ++i
)
4067 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4068 hash
= SXHASH_COMBINE (hash
, hash2
);
4075 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4076 the Lisp structure. */
4079 sxhash_vector (vec
, depth
)
4083 unsigned hash
= XVECTOR (vec
)->size
;
4086 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4087 for (i
= 0; i
< n
; ++i
)
4089 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4090 hash
= SXHASH_COMBINE (hash
, hash2
);
4097 /* Return a hash for bool-vector VECTOR. */
4100 sxhash_bool_vector (vec
)
4103 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4106 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4107 for (i
= 0; i
< n
; ++i
)
4108 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4114 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4115 structure. Value is an unsigned integer clipped to VALMASK. */
4124 if (depth
> SXHASH_MAX_DEPTH
)
4127 switch (XTYPE (obj
))
4134 hash
= sxhash_string (XSYMBOL (obj
)->name
->data
,
4135 XSYMBOL (obj
)->name
->size
);
4143 hash
= sxhash_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
4146 /* This can be everything from a vector to an overlay. */
4147 case Lisp_Vectorlike
:
4149 /* According to the CL HyperSpec, two arrays are equal only if
4150 they are `eq', except for strings and bit-vectors. In
4151 Emacs, this works differently. We have to compare element
4153 hash
= sxhash_vector (obj
, depth
);
4154 else if (BOOL_VECTOR_P (obj
))
4155 hash
= sxhash_bool_vector (obj
);
4157 /* Others are `equal' if they are `eq', so let's take their
4163 hash
= sxhash_list (obj
, depth
);
4168 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4169 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4170 for (hash
= 0; p
< e
; ++p
)
4171 hash
= SXHASH_COMBINE (hash
, *p
);
4179 return hash
& VALMASK
;
4184 /***********************************************************************
4186 ***********************************************************************/
4189 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4190 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4194 unsigned hash
= sxhash (obj
, 0);;
4195 return make_number (hash
);
4199 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4200 doc
: /* Create and return a new hash table.
4202 Arguments are specified as keyword/argument pairs. The following
4203 arguments are defined:
4205 :test TEST -- TEST must be a symbol that specifies how to compare
4206 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4207 `equal'. User-supplied test and hash functions can be specified via
4208 `define-hash-table-test'.
4210 :size SIZE -- A hint as to how many elements will be put in the table.
4213 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4214 fills up. If REHASH-SIZE is an integer, add that many space. If it
4215 is a float, it must be > 1.0, and the new size is computed by
4216 multiplying the old size with that factor. Default is 1.5.
4218 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4219 Resize the hash table when ratio of the number of entries in the
4220 table. Default is 0.8.
4222 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4223 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4224 returned is a weak table. Key/value pairs are removed from a weak
4225 hash table when there are no non-weak references pointing to their
4226 key, value, one of key or value, or both key and value, depending on
4227 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4230 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4235 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4236 Lisp_Object user_test
, user_hash
;
4240 /* The vector `used' is used to keep track of arguments that
4241 have been consumed. */
4242 used
= (char *) alloca (nargs
* sizeof *used
);
4243 bzero (used
, nargs
* sizeof *used
);
4245 /* See if there's a `:test TEST' among the arguments. */
4246 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4247 test
= i
< 0 ? Qeql
: args
[i
];
4248 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4250 /* See if it is a user-defined test. */
4253 prop
= Fget (test
, Qhash_table_test
);
4254 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4255 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4257 user_test
= XCAR (prop
);
4258 user_hash
= XCAR (XCDR (prop
));
4261 user_test
= user_hash
= Qnil
;
4263 /* See if there's a `:size SIZE' argument. */
4264 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4265 size
= i
< 0 ? make_number (DEFAULT_HASH_SIZE
) : args
[i
];
4266 if (!INTEGERP (size
) || XINT (size
) < 0)
4268 list2 (build_string ("Invalid hash table size"),
4271 /* Look for `:rehash-size SIZE'. */
4272 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4273 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4274 if (!NUMBERP (rehash_size
)
4275 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4276 || XFLOATINT (rehash_size
) <= 1.0)
4278 list2 (build_string ("Invalid hash table rehash size"),
4281 /* Look for `:rehash-threshold THRESHOLD'. */
4282 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4283 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4284 if (!FLOATP (rehash_threshold
)
4285 || XFLOATINT (rehash_threshold
) <= 0.0
4286 || XFLOATINT (rehash_threshold
) > 1.0)
4288 list2 (build_string ("Invalid hash table rehash threshold"),
4291 /* Look for `:weakness WEAK'. */
4292 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4293 weak
= i
< 0 ? Qnil
: args
[i
];
4295 weak
= Qkey_and_value
;
4298 && !EQ (weak
, Qvalue
)
4299 && !EQ (weak
, Qkey_or_value
)
4300 && !EQ (weak
, Qkey_and_value
))
4301 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4304 /* Now, all args should have been used up, or there's a problem. */
4305 for (i
= 0; i
< nargs
; ++i
)
4308 list2 (build_string ("Invalid argument list"), args
[i
]));
4310 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4311 user_test
, user_hash
);
4315 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4316 doc
: /* Return a copy of hash table TABLE. */)
4320 return copy_hash_table (check_hash_table (table
));
4324 DEFUN ("makehash", Fmakehash
, Smakehash
, 0, 1, 0,
4325 doc
: /* Create a new hash table.
4327 Optional first argument TEST specifies how to compare keys in the
4328 table. Predefined tests are `eq', `eql', and `equal'. Default is
4329 `eql'. New tests can be defined with `define-hash-table-test'. */)
4333 Lisp_Object args
[2];
4335 args
[1] = NILP (test
) ? Qeql
: test
;
4336 return Fmake_hash_table (2, args
);
4340 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4341 doc
: /* Return the number of elements in TABLE. */)
4345 return check_hash_table (table
)->count
;
4349 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4350 Shash_table_rehash_size
, 1, 1, 0,
4351 doc
: /* Return the current rehash size of TABLE. */)
4355 return check_hash_table (table
)->rehash_size
;
4359 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4360 Shash_table_rehash_threshold
, 1, 1, 0,
4361 doc
: /* Return the current rehash threshold of TABLE. */)
4365 return check_hash_table (table
)->rehash_threshold
;
4369 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4370 doc
: /* Return the size of TABLE.
4371 The size can be used as an argument to `make-hash-table' to create
4372 a hash table than can hold as many elements of TABLE holds
4373 without need for resizing. */)
4377 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4378 return make_number (HASH_TABLE_SIZE (h
));
4382 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4383 doc
: /* Return the test TABLE uses. */)
4387 return check_hash_table (table
)->test
;
4391 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4393 doc
: /* Return the weakness of TABLE. */)
4397 return check_hash_table (table
)->weak
;
4401 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4402 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4406 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4410 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4411 doc
: /* Clear hash table TABLE. */)
4415 hash_clear (check_hash_table (table
));
4420 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4421 doc
: /* Look up KEY in TABLE and return its associated value.
4422 If KEY is not found, return DFLT which defaults to nil. */)
4424 Lisp_Object key
, table
, dflt
;
4426 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4427 int i
= hash_lookup (h
, key
, NULL
);
4428 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4432 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4433 doc
: /* Associate KEY with VALUE in hash table TABLE.
4434 If KEY is already present in table, replace its current value with
4437 Lisp_Object key
, value
, table
;
4439 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4443 i
= hash_lookup (h
, key
, &hash
);
4445 HASH_VALUE (h
, i
) = value
;
4447 hash_put (h
, key
, value
, hash
);
4453 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4454 doc
: /* Remove KEY from TABLE. */)
4456 Lisp_Object key
, table
;
4458 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4459 hash_remove (h
, key
);
4464 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4465 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4466 FUNCTION is called with 2 arguments KEY and VALUE. */)
4468 Lisp_Object function
, table
;
4470 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4471 Lisp_Object args
[3];
4474 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4475 if (!NILP (HASH_HASH (h
, i
)))
4478 args
[1] = HASH_KEY (h
, i
);
4479 args
[2] = HASH_VALUE (h
, i
);
4487 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4488 Sdefine_hash_table_test
, 3, 3, 0,
4489 doc
: /* Define a new hash table test with name NAME, a symbol.
4491 In hash tables created with NAME specified as test, use TEST to
4492 compare keys, and HASH for computing hash codes of keys.
4494 TEST must be a function taking two arguments and returning non-nil if
4495 both arguments are the same. HASH must be a function taking one
4496 argument and return an integer that is the hash code of the argument.
4497 Hash code computation should use the whole value range of integers,
4498 including negative integers. */)
4500 Lisp_Object name
, test
, hash
;
4502 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4507 /************************************************************************
4509 ************************************************************************/
4514 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4515 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4517 A message digest is a cryptographic checksum of a document, and the
4518 algorithm to calculate it is defined in RFC 1321.
4520 The two optional arguments START and END are character positions
4521 specifying for which part of OBJECT the message digest should be
4522 computed. If nil or omitted, the digest is computed for the whole
4525 The MD5 message digest is computed from the result of encoding the
4526 text in a coding system, not directly from the internal Emacs form of
4527 the text. The optional fourth argument CODING-SYSTEM specifies which
4528 coding system to encode the text with. It should be the same coding
4529 system that you used or will use when actually writing the text into a
4532 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4533 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4534 system would be chosen by default for writing this text into a file.
4536 If OBJECT is a string, the most preferred coding system (see the
4537 command `prefer-coding-system') is used.
4539 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4540 guesswork fails. Normally, an error is signaled in such case. */)
4541 (object
, start
, end
, coding_system
, noerror
)
4542 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4544 unsigned char digest
[16];
4545 unsigned char value
[33];
4549 int start_char
= 0, end_char
= 0;
4550 int start_byte
= 0, end_byte
= 0;
4552 register struct buffer
*bp
;
4555 if (STRINGP (object
))
4557 if (NILP (coding_system
))
4559 /* Decide the coding-system to encode the data with. */
4561 if (STRING_MULTIBYTE (object
))
4562 /* use default, we can't guess correct value */
4563 coding_system
= preferred_coding_system ();
4565 coding_system
= Qraw_text
;
4568 if (NILP (Fcoding_system_p (coding_system
)))
4570 /* Invalid coding system. */
4572 if (!NILP (noerror
))
4573 coding_system
= Qraw_text
;
4576 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4579 if (STRING_MULTIBYTE (object
))
4580 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4582 size
= XSTRING (object
)->size
;
4583 size_byte
= STRING_BYTES (XSTRING (object
));
4587 CHECK_NUMBER (start
);
4589 start_char
= XINT (start
);
4594 start_byte
= string_char_to_byte (object
, start_char
);
4600 end_byte
= size_byte
;
4606 end_char
= XINT (end
);
4611 end_byte
= string_char_to_byte (object
, end_char
);
4614 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4615 args_out_of_range_3 (object
, make_number (start_char
),
4616 make_number (end_char
));
4620 CHECK_BUFFER (object
);
4622 bp
= XBUFFER (object
);
4628 CHECK_NUMBER_COERCE_MARKER (start
);
4636 CHECK_NUMBER_COERCE_MARKER (end
);
4641 temp
= b
, b
= e
, e
= temp
;
4643 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
4644 args_out_of_range (start
, end
);
4646 if (NILP (coding_system
))
4648 /* Decide the coding-system to encode the data with.
4649 See fileio.c:Fwrite-region */
4651 if (!NILP (Vcoding_system_for_write
))
4652 coding_system
= Vcoding_system_for_write
;
4655 int force_raw_text
= 0;
4657 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4658 if (NILP (coding_system
)
4659 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4661 coding_system
= Qnil
;
4662 if (NILP (current_buffer
->enable_multibyte_characters
))
4666 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4668 /* Check file-coding-system-alist. */
4669 Lisp_Object args
[4], val
;
4671 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4672 args
[3] = Fbuffer_file_name(object
);
4673 val
= Ffind_operation_coding_system (4, args
);
4674 if (CONSP (val
) && !NILP (XCDR (val
)))
4675 coding_system
= XCDR (val
);
4678 if (NILP (coding_system
)
4679 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4681 /* If we still have not decided a coding system, use the
4682 default value of buffer-file-coding-system. */
4683 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4687 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4688 /* Confirm that VAL can surely encode the current region. */
4689 coding_system
= call3 (Vselect_safe_coding_system_function
,
4690 make_number (b
), make_number (e
),
4694 coding_system
= Qraw_text
;
4697 if (NILP (Fcoding_system_p (coding_system
)))
4699 /* Invalid coding system. */
4701 if (!NILP (noerror
))
4702 coding_system
= Qraw_text
;
4705 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4709 object
= make_buffer_string (b
, e
, 0);
4711 if (STRING_MULTIBYTE (object
))
4712 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4715 md5_buffer (XSTRING (object
)->data
+ start_byte
,
4716 STRING_BYTES(XSTRING (object
)) - (size_byte
- end_byte
),
4719 for (i
= 0; i
< 16; i
++)
4720 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
4723 return make_string (value
, 32);
4730 /* Hash table stuff. */
4731 Qhash_table_p
= intern ("hash-table-p");
4732 staticpro (&Qhash_table_p
);
4733 Qeq
= intern ("eq");
4735 Qeql
= intern ("eql");
4737 Qequal
= intern ("equal");
4738 staticpro (&Qequal
);
4739 QCtest
= intern (":test");
4740 staticpro (&QCtest
);
4741 QCsize
= intern (":size");
4742 staticpro (&QCsize
);
4743 QCrehash_size
= intern (":rehash-size");
4744 staticpro (&QCrehash_size
);
4745 QCrehash_threshold
= intern (":rehash-threshold");
4746 staticpro (&QCrehash_threshold
);
4747 QCweakness
= intern (":weakness");
4748 staticpro (&QCweakness
);
4749 Qkey
= intern ("key");
4751 Qvalue
= intern ("value");
4752 staticpro (&Qvalue
);
4753 Qhash_table_test
= intern ("hash-table-test");
4754 staticpro (&Qhash_table_test
);
4755 Qkey_or_value
= intern ("key-or-value");
4756 staticpro (&Qkey_or_value
);
4757 Qkey_and_value
= intern ("key-and-value");
4758 staticpro (&Qkey_and_value
);
4761 defsubr (&Smake_hash_table
);
4762 defsubr (&Scopy_hash_table
);
4763 defsubr (&Smakehash
);
4764 defsubr (&Shash_table_count
);
4765 defsubr (&Shash_table_rehash_size
);
4766 defsubr (&Shash_table_rehash_threshold
);
4767 defsubr (&Shash_table_size
);
4768 defsubr (&Shash_table_test
);
4769 defsubr (&Shash_table_weakness
);
4770 defsubr (&Shash_table_p
);
4771 defsubr (&Sclrhash
);
4772 defsubr (&Sgethash
);
4773 defsubr (&Sputhash
);
4774 defsubr (&Sremhash
);
4775 defsubr (&Smaphash
);
4776 defsubr (&Sdefine_hash_table_test
);
4778 Qstring_lessp
= intern ("string-lessp");
4779 staticpro (&Qstring_lessp
);
4780 Qprovide
= intern ("provide");
4781 staticpro (&Qprovide
);
4782 Qrequire
= intern ("require");
4783 staticpro (&Qrequire
);
4784 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
4785 staticpro (&Qyes_or_no_p_history
);
4786 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
4787 staticpro (&Qcursor_in_echo_area
);
4788 Qwidget_type
= intern ("widget-type");
4789 staticpro (&Qwidget_type
);
4791 staticpro (&string_char_byte_cache_string
);
4792 string_char_byte_cache_string
= Qnil
;
4794 require_nesting_list
= Qnil
;
4795 staticpro (&require_nesting_list
);
4797 Fset (Qyes_or_no_p_history
, Qnil
);
4799 DEFVAR_LISP ("features", &Vfeatures
,
4800 doc
: /* A list of symbols which are the features of the executing emacs.
4801 Used by `featurep' and `require', and altered by `provide'. */);
4803 Qsubfeatures
= intern ("subfeatures");
4804 staticpro (&Qsubfeatures
);
4806 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
4807 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
4808 This applies to y-or-n and yes-or-no questions asked by commands
4809 invoked by mouse clicks and mouse menu items. */);
4812 defsubr (&Sidentity
);
4815 defsubr (&Ssafe_length
);
4816 defsubr (&Sstring_bytes
);
4817 defsubr (&Sstring_equal
);
4818 defsubr (&Scompare_strings
);
4819 defsubr (&Sstring_lessp
);
4822 defsubr (&Svconcat
);
4823 defsubr (&Scopy_sequence
);
4824 defsubr (&Sstring_make_multibyte
);
4825 defsubr (&Sstring_make_unibyte
);
4826 defsubr (&Sstring_as_multibyte
);
4827 defsubr (&Sstring_as_unibyte
);
4828 defsubr (&Scopy_alist
);
4829 defsubr (&Ssubstring
);
4841 defsubr (&Snreverse
);
4842 defsubr (&Sreverse
);
4844 defsubr (&Splist_get
);
4846 defsubr (&Splist_put
);
4849 defsubr (&Sfillarray
);
4853 defsubr (&Smapconcat
);
4854 defsubr (&Sy_or_n_p
);
4855 defsubr (&Syes_or_no_p
);
4856 defsubr (&Sload_average
);
4857 defsubr (&Sfeaturep
);
4858 defsubr (&Srequire
);
4859 defsubr (&Sprovide
);
4860 defsubr (&Splist_member
);
4861 defsubr (&Swidget_put
);
4862 defsubr (&Swidget_get
);
4863 defsubr (&Swidget_apply
);
4864 defsubr (&Sbase64_encode_region
);
4865 defsubr (&Sbase64_decode_region
);
4866 defsubr (&Sbase64_encode_string
);
4867 defsubr (&Sbase64_decode_string
);
4875 Vweak_hash_tables
= Qnil
;