1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 02, 2003
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
30 /* On Mac OS X, defining this conflicts with precompiled headers. */
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
37 #endif /* ! MAC_OSX */
41 #include "character.h"
46 #include "intervals.h"
49 #include "blockinput.h"
50 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
55 #define NULL ((POINTER_TYPE *)0)
58 /* Nonzero enables use of dialog boxes for questions
59 asked by mouse commands. */
62 extern int minibuffer_auto_raise
;
63 extern Lisp_Object minibuf_window
;
64 extern Lisp_Object Vlocale_coding_system
;
66 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
67 Lisp_Object Qyes_or_no_p_history
;
68 Lisp_Object Qcursor_in_echo_area
;
69 Lisp_Object Qwidget_type
;
70 Lisp_Object Qcodeset
, Qdays
, Qmonths
, Qpaper
;
72 extern Lisp_Object Qinput_method_function
;
74 static int internal_equal ();
76 extern long get_random ();
77 extern void seed_random ();
83 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
84 doc
: /* Return the argument unchanged. */)
91 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
92 doc
: /* Return a pseudo-random number.
93 All integers representable in Lisp are equally likely.
94 On most systems, this is 28 bits' worth.
95 With positive integer argument N, return random number in interval [0,N).
96 With argument t, set the random number seed from the current time and pid. */)
101 Lisp_Object lispy_val
;
102 unsigned long denominator
;
105 seed_random (getpid () + time (NULL
));
106 if (NATNUMP (n
) && XFASTINT (n
) != 0)
108 /* Try to take our random number from the higher bits of VAL,
109 not the lower, since (says Gentzel) the low bits of `random'
110 are less random than the higher ones. We do this by using the
111 quotient rather than the remainder. At the high end of the RNG
112 it's possible to get a quotient larger than n; discarding
113 these values eliminates the bias that would otherwise appear
114 when using a large n. */
115 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
117 val
= get_random () / denominator
;
118 while (val
>= XFASTINT (n
));
122 XSETINT (lispy_val
, val
);
126 /* Random data-structure functions */
128 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
129 doc
: /* Return the length of vector, list or string SEQUENCE.
130 A byte-code function object is also allowed.
131 If the string contains multibyte characters, this is not necessarily
132 the number of bytes in the string; it is the number of characters.
133 To get the number of bytes, use `string-bytes'. */)
135 register Lisp_Object sequence
;
137 register Lisp_Object val
;
141 if (STRINGP (sequence
))
142 XSETFASTINT (val
, SCHARS (sequence
));
143 else if (VECTORP (sequence
))
144 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
145 else if (CHAR_TABLE_P (sequence
))
146 XSETFASTINT (val
, MAX_CHAR
);
147 else if (BOOL_VECTOR_P (sequence
))
148 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
149 else if (COMPILEDP (sequence
))
150 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
151 else if (CONSP (sequence
))
154 while (CONSP (sequence
))
156 sequence
= XCDR (sequence
);
159 if (!CONSP (sequence
))
162 sequence
= XCDR (sequence
);
167 if (!NILP (sequence
))
168 wrong_type_argument (Qlistp
, sequence
);
170 val
= make_number (i
);
172 else if (NILP (sequence
))
173 XSETFASTINT (val
, 0);
176 sequence
= wrong_type_argument (Qsequencep
, sequence
);
182 /* This does not check for quits. That is safe
183 since it must terminate. */
185 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
186 doc
: /* Return the length of a list, but avoid error or infinite loop.
187 This function never gets an error. If LIST is not really a list,
188 it returns 0. If LIST is circular, it returns a finite value
189 which is at least the number of distinct elements. */)
193 Lisp_Object tail
, halftail
, length
;
196 /* halftail is used to detect circular lists. */
198 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
200 if (EQ (tail
, halftail
) && len
!= 0)
204 halftail
= XCDR (halftail
);
207 XSETINT (length
, len
);
211 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
212 doc
: /* Return the number of bytes in STRING.
213 If STRING is a multibyte string, this is greater than the length of STRING. */)
217 CHECK_STRING (string
);
218 return make_number (SBYTES (string
));
221 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
222 doc
: /* Return t if two strings have identical contents.
223 Case is significant, but text properties are ignored.
224 Symbols are also allowed; their print names are used instead. */)
226 register Lisp_Object s1
, s2
;
229 s1
= SYMBOL_NAME (s1
);
231 s2
= SYMBOL_NAME (s2
);
235 if (SCHARS (s1
) != SCHARS (s2
)
236 || SBYTES (s1
) != SBYTES (s2
)
237 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
242 DEFUN ("compare-strings", Fcompare_strings
,
243 Scompare_strings
, 6, 7, 0,
244 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
245 In string STR1, skip the first START1 characters and stop at END1.
246 In string STR2, skip the first START2 characters and stop at END2.
247 END1 and END2 default to the full lengths of the respective strings.
249 Case is significant in this comparison if IGNORE-CASE is nil.
250 Unibyte strings are converted to multibyte for comparison.
252 The value is t if the strings (or specified portions) match.
253 If string STR1 is less, the value is a negative number N;
254 - 1 - N is the number of characters that match at the beginning.
255 If string STR1 is greater, the value is a positive number N;
256 N - 1 is the number of characters that match at the beginning. */)
257 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
258 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
260 register int end1_char
, end2_char
;
261 register int i1
, i1_byte
, i2
, i2_byte
;
266 start1
= make_number (0);
268 start2
= make_number (0);
269 CHECK_NATNUM (start1
);
270 CHECK_NATNUM (start2
);
279 i1_byte
= string_char_to_byte (str1
, i1
);
280 i2_byte
= string_char_to_byte (str2
, i2
);
282 end1_char
= SCHARS (str1
);
283 if (! NILP (end1
) && end1_char
> XINT (end1
))
284 end1_char
= XINT (end1
);
286 end2_char
= SCHARS (str2
);
287 if (! NILP (end2
) && end2_char
> XINT (end2
))
288 end2_char
= XINT (end2
);
290 while (i1
< end1_char
&& i2
< end2_char
)
292 /* When we find a mismatch, we must compare the
293 characters, not just the bytes. */
296 if (STRING_MULTIBYTE (str1
))
297 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
300 c1
= SREF (str1
, i1
++);
301 c1
= unibyte_char_to_multibyte (c1
);
304 if (STRING_MULTIBYTE (str2
))
305 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
308 c2
= SREF (str2
, i2
++);
309 c2
= unibyte_char_to_multibyte (c2
);
315 if (! NILP (ignore_case
))
319 tem
= Fupcase (make_number (c1
));
321 tem
= Fupcase (make_number (c2
));
328 /* Note that I1 has already been incremented
329 past the character that we are comparing;
330 hence we don't add or subtract 1 here. */
332 return make_number (- i1
+ XINT (start1
));
334 return make_number (i1
- XINT (start1
));
338 return make_number (i1
- XINT (start1
) + 1);
340 return make_number (- i1
+ XINT (start1
) - 1);
345 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
346 doc
: /* Return t if first arg string is less than second in lexicographic order.
348 Symbols are also allowed; their print names are used instead. */)
350 register Lisp_Object s1
, s2
;
353 register int i1
, i1_byte
, i2
, i2_byte
;
356 s1
= SYMBOL_NAME (s1
);
358 s2
= SYMBOL_NAME (s2
);
362 i1
= i1_byte
= i2
= i2_byte
= 0;
365 if (end
> SCHARS (s2
))
370 /* When we find a mismatch, we must compare the
371 characters, not just the bytes. */
374 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
375 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
378 return c1
< c2
? Qt
: Qnil
;
380 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
383 static Lisp_Object
concat ();
394 return concat (2, args
, Lisp_String
, 0);
396 return concat (2, &s1
, Lisp_String
, 0);
397 #endif /* NO_ARG_ARRAY */
403 Lisp_Object s1
, s2
, s3
;
410 return concat (3, args
, Lisp_String
, 0);
412 return concat (3, &s1
, Lisp_String
, 0);
413 #endif /* NO_ARG_ARRAY */
416 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
417 doc
: /* Concatenate all the arguments and make the result a list.
418 The result is a list whose elements are the elements of all the arguments.
419 Each argument may be a list, vector or string.
420 The last argument is not copied, just used as the tail of the new list.
421 usage: (append &rest SEQUENCES) */)
426 return concat (nargs
, args
, Lisp_Cons
, 1);
429 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
430 doc
: /* Concatenate all the arguments and make the result a string.
431 The result is a string whose elements are the elements of all the arguments.
432 Each argument may be a string or a list or vector of characters (integers).
433 usage: (concat &rest SEQUENCES) */)
438 return concat (nargs
, args
, Lisp_String
, 0);
441 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
442 doc
: /* Concatenate all the arguments and make the result a vector.
443 The result is a vector whose elements are the elements of all the arguments.
444 Each argument may be a list, vector or string.
445 usage: (vconcat &rest SEQUENCES) */)
450 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
454 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
455 doc
: /* Return a copy of a list, vector, string or char-table.
456 The elements of a list or vector are not copied; they are shared
457 with the original. */)
461 if (NILP (arg
)) return arg
;
463 if (CHAR_TABLE_P (arg
))
465 return copy_char_table (arg
);
468 if (BOOL_VECTOR_P (arg
))
472 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
474 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
475 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
480 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
481 arg
= wrong_type_argument (Qsequencep
, arg
);
482 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
486 /* In string STR of length LEN, see if bytes before STR[I] combine
487 with bytes after STR[I] to form a single character. If so, return
488 the number of bytes after STR[I] which combine in this way.
489 Otherwize, return 0. */
492 count_combining (str
, len
, i
)
496 int j
= i
- 1, bytes
;
498 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
500 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
501 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
503 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
504 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
508 /* This structure holds information of an argument of `concat' that is
509 a string and has text properties to be copied. */
512 int argnum
; /* refer to ARGS (arguments of `concat') */
513 int from
; /* refer to ARGS[argnum] (argument string) */
514 int to
; /* refer to VAL (the target string) */
518 concat (nargs
, args
, target_type
, last_special
)
521 enum Lisp_Type target_type
;
525 register Lisp_Object tail
;
526 register Lisp_Object
this;
528 int toindex_byte
= 0;
529 register int result_len
;
530 register int result_len_byte
;
532 Lisp_Object last_tail
;
535 /* When we make a multibyte string, we can't copy text properties
536 while concatinating each string because the length of resulting
537 string can't be decided until we finish the whole concatination.
538 So, we record strings that have text properties to be copied
539 here, and copy the text properties after the concatination. */
540 struct textprop_rec
*textprops
= NULL
;
541 /* Number of elments in textprops. */
542 int num_textprops
= 0;
546 /* In append, the last arg isn't treated like the others */
547 if (last_special
&& nargs
> 0)
550 last_tail
= args
[nargs
];
555 /* Canonicalize each argument. */
556 for (argnum
= 0; argnum
< nargs
; argnum
++)
559 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
560 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
562 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
566 /* Compute total length in chars of arguments in RESULT_LEN.
567 If desired output is a string, also compute length in bytes
568 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
569 whether the result should be a multibyte string. */
573 for (argnum
= 0; argnum
< nargs
; argnum
++)
577 len
= XFASTINT (Flength (this));
578 if (target_type
== Lisp_String
)
580 /* We must count the number of bytes needed in the string
581 as well as the number of characters. */
587 for (i
= 0; i
< len
; i
++)
589 ch
= XVECTOR (this)->contents
[i
];
590 if (! CHARACTERP (ch
))
591 wrong_type_argument (Qcharacterp
, ch
);
592 this_len_byte
= CHAR_BYTES (XINT (ch
));
593 result_len_byte
+= this_len_byte
;
594 if (! ASCII_CHAR_P (XINT (ch
)))
597 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
598 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
599 else if (CONSP (this))
600 for (; CONSP (this); this = XCDR (this))
603 if (! CHARACTERP (ch
))
604 wrong_type_argument (Qcharacterp
, ch
);
605 this_len_byte
= CHAR_BYTES (XINT (ch
));
606 result_len_byte
+= this_len_byte
;
607 if (! ASCII_CHAR_P (XINT (ch
)))
610 else if (STRINGP (this))
612 if (STRING_MULTIBYTE (this))
615 result_len_byte
+= SBYTES (this);
618 result_len_byte
+= count_size_as_multibyte (SDATA (this),
626 if (! some_multibyte
)
627 result_len_byte
= result_len
;
629 /* Create the output object. */
630 if (target_type
== Lisp_Cons
)
631 val
= Fmake_list (make_number (result_len
), Qnil
);
632 else if (target_type
== Lisp_Vectorlike
)
633 val
= Fmake_vector (make_number (result_len
), Qnil
);
634 else if (some_multibyte
)
635 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
637 val
= make_uninit_string (result_len
);
639 /* In `append', if all but last arg are nil, return last arg. */
640 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
643 /* Copy the contents of the args into the result. */
645 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
647 toindex
= 0, toindex_byte
= 0;
652 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
654 for (argnum
= 0; argnum
< nargs
; argnum
++)
658 register unsigned int thisindex
= 0;
659 register unsigned int thisindex_byte
= 0;
663 thislen
= Flength (this), thisleni
= XINT (thislen
);
665 /* Between strings of the same kind, copy fast. */
666 if (STRINGP (this) && STRINGP (val
)
667 && STRING_MULTIBYTE (this) == some_multibyte
)
669 int thislen_byte
= SBYTES (this);
671 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
673 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
675 textprops
[num_textprops
].argnum
= argnum
;
676 textprops
[num_textprops
].from
= 0;
677 textprops
[num_textprops
++].to
= toindex
;
679 toindex_byte
+= thislen_byte
;
682 /* Copy a single-byte string to a multibyte string. */
683 else if (STRINGP (this) && STRINGP (val
))
685 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
687 textprops
[num_textprops
].argnum
= argnum
;
688 textprops
[num_textprops
].from
= 0;
689 textprops
[num_textprops
++].to
= toindex
;
691 toindex_byte
+= copy_text (SDATA (this),
692 SDATA (val
) + toindex_byte
,
693 SCHARS (this), 0, 1);
697 /* Copy element by element. */
700 register Lisp_Object elt
;
702 /* Fetch next element of `this' arg into `elt', or break if
703 `this' is exhausted. */
704 if (NILP (this)) break;
706 elt
= XCAR (this), this = XCDR (this);
707 else if (thisindex
>= thisleni
)
709 else if (STRINGP (this))
712 if (STRING_MULTIBYTE (this))
714 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
717 XSETFASTINT (elt
, c
);
721 XSETFASTINT (elt
, SREF (this, thisindex
++));
723 && XINT (elt
) >= 0200
724 && XINT (elt
) < 0400)
726 c
= unibyte_char_to_multibyte (XINT (elt
));
731 else if (BOOL_VECTOR_P (this))
734 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
735 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
742 elt
= XVECTOR (this)->contents
[thisindex
++];
744 /* Store this element into the result. */
751 else if (VECTORP (val
))
752 XVECTOR (val
)->contents
[toindex
++] = elt
;
757 toindex_byte
+= CHAR_STRING (XINT (elt
),
758 SDATA (val
) + toindex_byte
);
760 SSET (val
, toindex_byte
++, XINT (elt
));
766 XSETCDR (prev
, last_tail
);
768 if (num_textprops
> 0)
771 int last_to_end
= -1;
773 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
775 this = args
[textprops
[argnum
].argnum
];
776 props
= text_property_list (this,
778 make_number (SCHARS (this)),
780 /* If successive arguments have properites, be sure that the
781 value of `composition' property be the copy. */
782 if (last_to_end
== textprops
[argnum
].to
)
783 make_composition_value_copy (props
);
784 add_text_properties_from_list (val
, props
,
785 make_number (textprops
[argnum
].to
));
786 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
792 static Lisp_Object string_char_byte_cache_string
;
793 static int string_char_byte_cache_charpos
;
794 static int string_char_byte_cache_bytepos
;
797 clear_string_char_byte_cache ()
799 string_char_byte_cache_string
= Qnil
;
802 /* Return the character index corresponding to CHAR_INDEX in STRING. */
805 string_char_to_byte (string
, char_index
)
810 int best_below
, best_below_byte
;
811 int best_above
, best_above_byte
;
813 if (! STRING_MULTIBYTE (string
))
816 best_below
= best_below_byte
= 0;
817 best_above
= SCHARS (string
);
818 best_above_byte
= SBYTES (string
);
820 if (EQ (string
, string_char_byte_cache_string
))
822 if (string_char_byte_cache_charpos
< char_index
)
824 best_below
= string_char_byte_cache_charpos
;
825 best_below_byte
= string_char_byte_cache_bytepos
;
829 best_above
= string_char_byte_cache_charpos
;
830 best_above_byte
= string_char_byte_cache_bytepos
;
834 if (char_index
- best_below
< best_above
- char_index
)
836 unsigned char *p
= SDATA (string
) + best_below_byte
;
838 while (best_below
< char_index
)
840 p
+= BYTES_BY_CHAR_HEAD (*p
);
843 i_byte
= p
- SDATA (string
);
847 unsigned char *p
= SDATA (string
) + best_above_byte
;
849 while (best_above
> char_index
)
852 while (!CHAR_HEAD_P (*p
)) p
--;
855 i_byte
= p
- SDATA (string
);
858 string_char_byte_cache_bytepos
= i_byte
;
859 string_char_byte_cache_charpos
= char_index
;
860 string_char_byte_cache_string
= string
;
865 /* Return the character index corresponding to BYTE_INDEX in STRING. */
868 string_byte_to_char (string
, byte_index
)
873 int best_below
, best_below_byte
;
874 int best_above
, best_above_byte
;
876 if (! STRING_MULTIBYTE (string
))
879 best_below
= best_below_byte
= 0;
880 best_above
= SCHARS (string
);
881 best_above_byte
= SBYTES (string
);
883 if (EQ (string
, string_char_byte_cache_string
))
885 if (string_char_byte_cache_bytepos
< byte_index
)
887 best_below
= string_char_byte_cache_charpos
;
888 best_below_byte
= string_char_byte_cache_bytepos
;
892 best_above
= string_char_byte_cache_charpos
;
893 best_above_byte
= string_char_byte_cache_bytepos
;
897 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
899 unsigned char *p
= SDATA (string
) + best_below_byte
;
900 unsigned char *pend
= SDATA (string
) + byte_index
;
904 p
+= BYTES_BY_CHAR_HEAD (*p
);
908 i_byte
= p
- SDATA (string
);
912 unsigned char *p
= SDATA (string
) + best_above_byte
;
913 unsigned char *pbeg
= SDATA (string
) + byte_index
;
918 while (!CHAR_HEAD_P (*p
)) p
--;
922 i_byte
= p
- SDATA (string
);
925 string_char_byte_cache_bytepos
= i_byte
;
926 string_char_byte_cache_charpos
= i
;
927 string_char_byte_cache_string
= string
;
932 /* Convert STRING to a multibyte string. */
935 string_make_multibyte (string
)
941 if (STRING_MULTIBYTE (string
))
944 nbytes
= count_size_as_multibyte (SDATA (string
),
946 /* If all the chars are ASCII, they won't need any more bytes
947 once converted. In that case, we can return STRING itself. */
948 if (nbytes
== SBYTES (string
))
951 buf
= (unsigned char *) alloca (nbytes
);
952 copy_text (SDATA (string
), buf
, SBYTES (string
),
955 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
959 /* Convert STRING (if unibyte) to a multibyte string without changing
960 the number of characters. Characters 0200 trough 0237 are
961 converted to eight-bit characters. */
964 string_to_multibyte (string
)
970 if (STRING_MULTIBYTE (string
))
973 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
974 /* If all the chars are ASCII, they won't need any more bytes once
976 if (nbytes
== SBYTES (string
))
977 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
979 buf
= (unsigned char *) alloca (nbytes
);
980 bcopy (SDATA (string
), buf
, SBYTES (string
));
981 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
983 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
987 /* Convert STRING to a single-byte string. */
990 string_make_unibyte (string
)
995 if (! STRING_MULTIBYTE (string
))
998 buf
= (unsigned char *) alloca (SCHARS (string
));
1000 copy_text (SDATA (string
), buf
, SBYTES (string
),
1003 return make_unibyte_string (buf
, SCHARS (string
));
1006 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1008 doc
: /* Return the multibyte equivalent of STRING.
1009 The function `unibyte-char-to-multibyte' is used to convert
1010 each unibyte character to a multibyte character. */)
1014 CHECK_STRING (string
);
1016 return string_make_multibyte (string
);
1019 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1021 doc
: /* Return the unibyte equivalent of STRING.
1022 Multibyte character codes are converted to unibyte according to
1023 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1024 If the lookup in the translation table fails, this function takes just
1025 the low 8 bits of each character. */)
1029 CHECK_STRING (string
);
1031 return string_make_unibyte (string
);
1034 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1036 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1037 If STRING is unibyte, the result is STRING itself.
1038 Otherwise it is a newly created string, with no text properties.
1039 If STRING is multibyte and contains a character of charset
1040 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1041 corresponding single byte. */)
1045 CHECK_STRING (string
);
1047 if (STRING_MULTIBYTE (string
))
1049 int bytes
= SBYTES (string
);
1050 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1052 bcopy (SDATA (string
), str
, bytes
);
1053 bytes
= str_as_unibyte (str
, bytes
);
1054 string
= make_unibyte_string (str
, bytes
);
1060 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1062 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1063 If STRING is multibyte, the result is STRING itself.
1064 Otherwise it is a newly created string, with no text properties.
1066 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1067 part of a correct utf-8 sequence), it is converted to the corresponding
1068 multibyte character of charset `eight-bit'.
1069 See also `string-to-multibyte'. */)
1073 CHECK_STRING (string
);
1075 if (! STRING_MULTIBYTE (string
))
1077 Lisp_Object new_string
;
1080 parse_str_as_multibyte (SDATA (string
),
1083 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1084 bcopy (SDATA (string
), SDATA (new_string
),
1086 if (nbytes
!= SBYTES (string
))
1087 str_as_multibyte (SDATA (new_string
), nbytes
,
1088 SBYTES (string
), NULL
);
1089 string
= new_string
;
1090 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1095 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1097 doc
: /* Return a multibyte string with the same individual chars as STRING.
1098 If STRING is multibyte, the result is STRING itself.
1099 Otherwise it is a newly created string, with no text properties.
1101 If STRING is unibyte and contains an 8-bit byte, it is converted to
1102 the corresponding multibyte character of charset `eight-bit'.
1104 This differs from `string-as-multibyte' by converting each byte of a correct
1105 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1106 correct sequence. */)
1110 CHECK_STRING (string
);
1112 return string_to_multibyte (string
);
1116 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1117 doc
: /* Return a copy of ALIST.
1118 This is an alist which represents the same mapping from objects to objects,
1119 but does not share the alist structure with ALIST.
1120 The objects mapped (cars and cdrs of elements of the alist)
1121 are shared, however.
1122 Elements of ALIST that are not conses are also shared. */)
1126 register Lisp_Object tem
;
1131 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1132 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1134 register Lisp_Object car
;
1138 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1143 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1144 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1145 TO may be nil or omitted; then the substring runs to the end of STRING.
1146 FROM and TO start at 0. If either is negative, it counts from the end.
1148 This function allows vectors as well as strings. */)
1151 register Lisp_Object from
, to
;
1156 int from_char
, to_char
;
1157 int from_byte
= 0, to_byte
= 0;
1159 if (! (STRINGP (string
) || VECTORP (string
)))
1160 wrong_type_argument (Qarrayp
, string
);
1162 CHECK_NUMBER (from
);
1164 if (STRINGP (string
))
1166 size
= SCHARS (string
);
1167 size_byte
= SBYTES (string
);
1170 size
= XVECTOR (string
)->size
;
1175 to_byte
= size_byte
;
1181 to_char
= XINT (to
);
1185 if (STRINGP (string
))
1186 to_byte
= string_char_to_byte (string
, to_char
);
1189 from_char
= XINT (from
);
1192 if (STRINGP (string
))
1193 from_byte
= string_char_to_byte (string
, from_char
);
1195 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1196 args_out_of_range_3 (string
, make_number (from_char
),
1197 make_number (to_char
));
1199 if (STRINGP (string
))
1201 res
= make_specified_string (SDATA (string
) + from_byte
,
1202 to_char
- from_char
, to_byte
- from_byte
,
1203 STRING_MULTIBYTE (string
));
1204 copy_text_properties (make_number (from_char
), make_number (to_char
),
1205 string
, make_number (0), res
, Qnil
);
1208 res
= Fvector (to_char
- from_char
,
1209 XVECTOR (string
)->contents
+ from_char
);
1215 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1216 doc
: /* Return a substring of STRING, without text properties.
1217 It starts at index FROM and ending before TO.
1218 TO may be nil or omitted; then the substring runs to the end of STRING.
1219 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1220 If FROM or TO is negative, it counts from the end.
1222 With one argument, just copy STRING without its properties. */)
1225 register Lisp_Object from
, to
;
1227 int size
, size_byte
;
1228 int from_char
, to_char
;
1229 int from_byte
, to_byte
;
1231 CHECK_STRING (string
);
1233 size
= SCHARS (string
);
1234 size_byte
= SBYTES (string
);
1237 from_char
= from_byte
= 0;
1240 CHECK_NUMBER (from
);
1241 from_char
= XINT (from
);
1245 from_byte
= string_char_to_byte (string
, from_char
);
1251 to_byte
= size_byte
;
1257 to_char
= XINT (to
);
1261 to_byte
= string_char_to_byte (string
, to_char
);
1264 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1265 args_out_of_range_3 (string
, make_number (from_char
),
1266 make_number (to_char
));
1268 return make_specified_string (SDATA (string
) + from_byte
,
1269 to_char
- from_char
, to_byte
- from_byte
,
1270 STRING_MULTIBYTE (string
));
1273 /* Extract a substring of STRING, giving start and end positions
1274 both in characters and in bytes. */
1277 substring_both (string
, from
, from_byte
, to
, to_byte
)
1279 int from
, from_byte
, to
, to_byte
;
1285 if (! (STRINGP (string
) || VECTORP (string
)))
1286 wrong_type_argument (Qarrayp
, string
);
1288 if (STRINGP (string
))
1290 size
= SCHARS (string
);
1291 size_byte
= SBYTES (string
);
1294 size
= XVECTOR (string
)->size
;
1296 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1297 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1299 if (STRINGP (string
))
1301 res
= make_specified_string (SDATA (string
) + from_byte
,
1302 to
- from
, to_byte
- from_byte
,
1303 STRING_MULTIBYTE (string
));
1304 copy_text_properties (make_number (from
), make_number (to
),
1305 string
, make_number (0), res
, Qnil
);
1308 res
= Fvector (to
- from
,
1309 XVECTOR (string
)->contents
+ from
);
1314 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1315 doc
: /* Take cdr N times on LIST, returns the result. */)
1318 register Lisp_Object list
;
1320 register int i
, num
;
1323 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1327 wrong_type_argument (Qlistp
, list
);
1333 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1334 doc
: /* Return the Nth element of LIST.
1335 N counts from zero. If LIST is not that long, nil is returned. */)
1337 Lisp_Object n
, list
;
1339 return Fcar (Fnthcdr (n
, list
));
1342 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1343 doc
: /* Return element of SEQUENCE at index N. */)
1345 register Lisp_Object sequence
, n
;
1350 if (CONSP (sequence
) || NILP (sequence
))
1351 return Fcar (Fnthcdr (n
, sequence
));
1352 else if (STRINGP (sequence
) || VECTORP (sequence
)
1353 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1354 return Faref (sequence
, n
);
1356 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1360 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1361 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1362 The value is actually the tail of LIST whose car is ELT. */)
1364 register Lisp_Object elt
;
1367 register Lisp_Object tail
;
1368 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1370 register Lisp_Object tem
;
1372 wrong_type_argument (Qlistp
, list
);
1374 if (! NILP (Fequal (elt
, tem
)))
1381 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1382 doc
: /* Return non-nil if ELT is an element of LIST.
1383 Comparison done with EQ. The value is actually the tail of LIST
1384 whose car is ELT. */)
1386 Lisp_Object elt
, list
;
1390 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1394 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1398 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1405 if (!CONSP (list
) && !NILP (list
))
1406 list
= wrong_type_argument (Qlistp
, list
);
1411 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1412 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1413 The value is actually the element of LIST whose car is KEY.
1414 Elements of LIST that are not conses are ignored. */)
1416 Lisp_Object key
, list
;
1423 || (CONSP (XCAR (list
))
1424 && EQ (XCAR (XCAR (list
)), key
)))
1429 || (CONSP (XCAR (list
))
1430 && EQ (XCAR (XCAR (list
)), key
)))
1435 || (CONSP (XCAR (list
))
1436 && EQ (XCAR (XCAR (list
)), key
)))
1444 result
= XCAR (list
);
1445 else if (NILP (list
))
1448 result
= wrong_type_argument (Qlistp
, list
);
1453 /* Like Fassq but never report an error and do not allow quits.
1454 Use only on lists known never to be circular. */
1457 assq_no_quit (key
, list
)
1458 Lisp_Object key
, list
;
1461 && (!CONSP (XCAR (list
))
1462 || !EQ (XCAR (XCAR (list
)), key
)))
1465 return CONSP (list
) ? XCAR (list
) : Qnil
;
1468 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1469 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1470 The value is actually the element of LIST whose car equals KEY. */)
1472 Lisp_Object key
, list
;
1474 Lisp_Object result
, car
;
1479 || (CONSP (XCAR (list
))
1480 && (car
= XCAR (XCAR (list
)),
1481 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1486 || (CONSP (XCAR (list
))
1487 && (car
= XCAR (XCAR (list
)),
1488 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1493 || (CONSP (XCAR (list
))
1494 && (car
= XCAR (XCAR (list
)),
1495 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1503 result
= XCAR (list
);
1504 else if (NILP (list
))
1507 result
= wrong_type_argument (Qlistp
, list
);
1512 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1513 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1514 The value is actually the element of LIST whose cdr is KEY. */)
1516 register Lisp_Object key
;
1524 || (CONSP (XCAR (list
))
1525 && EQ (XCDR (XCAR (list
)), key
)))
1530 || (CONSP (XCAR (list
))
1531 && EQ (XCDR (XCAR (list
)), key
)))
1536 || (CONSP (XCAR (list
))
1537 && EQ (XCDR (XCAR (list
)), key
)))
1546 else if (CONSP (list
))
1547 result
= XCAR (list
);
1549 result
= wrong_type_argument (Qlistp
, list
);
1554 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1555 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1556 The value is actually the element of LIST whose cdr equals KEY. */)
1558 Lisp_Object key
, list
;
1560 Lisp_Object result
, cdr
;
1565 || (CONSP (XCAR (list
))
1566 && (cdr
= XCDR (XCAR (list
)),
1567 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1572 || (CONSP (XCAR (list
))
1573 && (cdr
= XCDR (XCAR (list
)),
1574 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1579 || (CONSP (XCAR (list
))
1580 && (cdr
= XCDR (XCAR (list
)),
1581 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1589 result
= XCAR (list
);
1590 else if (NILP (list
))
1593 result
= wrong_type_argument (Qlistp
, list
);
1598 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1599 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1600 The modified LIST is returned. Comparison is done with `eq'.
1601 If the first member of LIST is ELT, there is no way to remove it by side effect;
1602 therefore, write `(setq foo (delq element foo))'
1603 to be sure of changing the value of `foo'. */)
1605 register Lisp_Object elt
;
1608 register Lisp_Object tail
, prev
;
1609 register Lisp_Object tem
;
1613 while (!NILP (tail
))
1616 wrong_type_argument (Qlistp
, list
);
1623 Fsetcdr (prev
, XCDR (tail
));
1633 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1634 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1635 SEQ must be a list, a vector, or a string.
1636 The modified SEQ is returned. Comparison is done with `equal'.
1637 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1638 is not a side effect; it is simply using a different sequence.
1639 Therefore, write `(setq foo (delete element foo))'
1640 to be sure of changing the value of `foo'. */)
1642 Lisp_Object elt
, seq
;
1648 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1649 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1652 if (n
!= ASIZE (seq
))
1654 struct Lisp_Vector
*p
= allocate_vector (n
);
1656 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1657 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1658 p
->contents
[n
++] = AREF (seq
, i
);
1660 XSETVECTOR (seq
, p
);
1663 else if (STRINGP (seq
))
1665 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1668 for (i
= nchars
= nbytes
= ibyte
= 0;
1670 ++i
, ibyte
+= cbytes
)
1672 if (STRING_MULTIBYTE (seq
))
1674 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1675 SBYTES (seq
) - ibyte
);
1676 cbytes
= CHAR_BYTES (c
);
1684 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1691 if (nchars
!= SCHARS (seq
))
1695 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1696 if (!STRING_MULTIBYTE (seq
))
1697 STRING_SET_UNIBYTE (tem
);
1699 for (i
= nchars
= nbytes
= ibyte
= 0;
1701 ++i
, ibyte
+= cbytes
)
1703 if (STRING_MULTIBYTE (seq
))
1705 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1706 SBYTES (seq
) - ibyte
);
1707 cbytes
= CHAR_BYTES (c
);
1715 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1717 unsigned char *from
= SDATA (seq
) + ibyte
;
1718 unsigned char *to
= SDATA (tem
) + nbytes
;
1724 for (n
= cbytes
; n
--; )
1734 Lisp_Object tail
, prev
;
1736 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1739 wrong_type_argument (Qlistp
, seq
);
1741 if (!NILP (Fequal (elt
, XCAR (tail
))))
1746 Fsetcdr (prev
, XCDR (tail
));
1757 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1758 doc
: /* Reverse LIST by modifying cdr pointers.
1759 Returns the beginning of the reversed list. */)
1763 register Lisp_Object prev
, tail
, next
;
1765 if (NILP (list
)) return list
;
1768 while (!NILP (tail
))
1772 wrong_type_argument (Qlistp
, list
);
1774 Fsetcdr (tail
, prev
);
1781 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1782 doc
: /* Reverse LIST, copying. Returns the beginning of the reversed list.
1783 See also the function `nreverse', which is used more often. */)
1789 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1792 new = Fcons (XCAR (list
), new);
1795 wrong_type_argument (Qconsp
, list
);
1799 Lisp_Object
merge ();
1801 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1802 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1803 Returns the sorted list. LIST is modified by side effects.
1804 PREDICATE is called with two elements of LIST, and should return t
1805 if the first element is "less" than the second. */)
1807 Lisp_Object list
, predicate
;
1809 Lisp_Object front
, back
;
1810 register Lisp_Object len
, tem
;
1811 struct gcpro gcpro1
, gcpro2
;
1812 register int length
;
1815 len
= Flength (list
);
1816 length
= XINT (len
);
1820 XSETINT (len
, (length
/ 2) - 1);
1821 tem
= Fnthcdr (len
, list
);
1823 Fsetcdr (tem
, Qnil
);
1825 GCPRO2 (front
, back
);
1826 front
= Fsort (front
, predicate
);
1827 back
= Fsort (back
, predicate
);
1829 return merge (front
, back
, predicate
);
1833 merge (org_l1
, org_l2
, pred
)
1834 Lisp_Object org_l1
, org_l2
;
1838 register Lisp_Object tail
;
1840 register Lisp_Object l1
, l2
;
1841 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1848 /* It is sufficient to protect org_l1 and org_l2.
1849 When l1 and l2 are updated, we copy the new values
1850 back into the org_ vars. */
1851 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1871 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1887 Fsetcdr (tail
, tem
);
1893 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1894 doc
: /* Extract a value from a property list.
1895 PLIST is a property list, which is a list of the form
1896 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1897 corresponding to the given PROP, or nil if PROP is not
1898 one of the properties on the list. */)
1906 CONSP (tail
) && CONSP (XCDR (tail
));
1907 tail
= XCDR (XCDR (tail
)))
1909 if (EQ (prop
, XCAR (tail
)))
1910 return XCAR (XCDR (tail
));
1912 /* This function can be called asynchronously
1913 (setup_coding_system). Don't QUIT in that case. */
1914 if (!interrupt_input_blocked
)
1919 wrong_type_argument (Qlistp
, prop
);
1924 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1925 doc
: /* Return the value of SYMBOL's PROPNAME property.
1926 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1928 Lisp_Object symbol
, propname
;
1930 CHECK_SYMBOL (symbol
);
1931 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1934 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1935 doc
: /* Change value in PLIST of PROP to VAL.
1936 PLIST is a property list, which is a list of the form
1937 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1938 If PROP is already a property on the list, its value is set to VAL,
1939 otherwise the new PROP VAL pair is added. The new plist is returned;
1940 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1941 The PLIST is modified by side effects. */)
1944 register Lisp_Object prop
;
1947 register Lisp_Object tail
, prev
;
1948 Lisp_Object newcell
;
1950 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
1951 tail
= XCDR (XCDR (tail
)))
1953 if (EQ (prop
, XCAR (tail
)))
1955 Fsetcar (XCDR (tail
), val
);
1962 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1966 Fsetcdr (XCDR (prev
), newcell
);
1970 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1971 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
1972 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
1973 (symbol
, propname
, value
)
1974 Lisp_Object symbol
, propname
, value
;
1976 CHECK_SYMBOL (symbol
);
1977 XSYMBOL (symbol
)->plist
1978 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1982 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
1983 doc
: /* Extract a value from a property list, comparing with `equal'.
1984 PLIST is a property list, which is a list of the form
1985 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1986 corresponding to the given PROP, or nil if PROP is not
1987 one of the properties on the list. */)
1995 CONSP (tail
) && CONSP (XCDR (tail
));
1996 tail
= XCDR (XCDR (tail
)))
1998 if (! NILP (Fequal (prop
, XCAR (tail
))))
1999 return XCAR (XCDR (tail
));
2005 wrong_type_argument (Qlistp
, prop
);
2010 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2011 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2012 PLIST is a property list, which is a list of the form
2013 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2014 If PROP is already a property on the list, its value is set to VAL,
2015 otherwise the new PROP VAL pair is added. The new plist is returned;
2016 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2017 The PLIST is modified by side effects. */)
2020 register Lisp_Object prop
;
2023 register Lisp_Object tail
, prev
;
2024 Lisp_Object newcell
;
2026 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2027 tail
= XCDR (XCDR (tail
)))
2029 if (! NILP (Fequal (prop
, XCAR (tail
))))
2031 Fsetcar (XCDR (tail
), val
);
2038 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2042 Fsetcdr (XCDR (prev
), newcell
);
2046 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2047 doc
: /* Return t if two Lisp objects have similar structure and contents.
2048 They must have the same data type.
2049 Conses are compared by comparing the cars and the cdrs.
2050 Vectors and strings are compared element by element.
2051 Numbers are compared by value, but integers cannot equal floats.
2052 (Use `=' if you want integers and floats to be able to be equal.)
2053 Symbols must match exactly. */)
2055 register Lisp_Object o1
, o2
;
2057 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2061 internal_equal (o1
, o2
, depth
)
2062 register Lisp_Object o1
, o2
;
2066 error ("Stack overflow in equal");
2072 if (XTYPE (o1
) != XTYPE (o2
))
2078 return (extract_float (o1
) == extract_float (o2
));
2081 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2088 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2092 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2094 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2097 o1
= XOVERLAY (o1
)->plist
;
2098 o2
= XOVERLAY (o2
)->plist
;
2103 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2104 && (XMARKER (o1
)->buffer
== 0
2105 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2109 case Lisp_Vectorlike
:
2111 register int i
, size
;
2112 size
= XVECTOR (o1
)->size
;
2113 /* Pseudovectors have the type encoded in the size field, so this test
2114 actually checks that the objects have the same type as well as the
2116 if (XVECTOR (o2
)->size
!= size
)
2118 /* Boolvectors are compared much like strings. */
2119 if (BOOL_VECTOR_P (o1
))
2122 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2124 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2126 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2131 if (WINDOW_CONFIGURATIONP (o1
))
2132 return compare_window_configurations (o1
, o2
, 0);
2134 /* Aside from them, only true vectors, char-tables, and compiled
2135 functions are sensible to compare, so eliminate the others now. */
2136 if (size
& PSEUDOVECTOR_FLAG
)
2138 if (!(size
& (PVEC_COMPILED
2139 | PVEC_CHAR_TABLE
| PVEC_SUB_CHAR_TABLE
)))
2141 size
&= PSEUDOVECTOR_SIZE_MASK
;
2143 for (i
= 0; i
< size
; i
++)
2146 v1
= XVECTOR (o1
)->contents
[i
];
2147 v2
= XVECTOR (o2
)->contents
[i
];
2148 if (!internal_equal (v1
, v2
, depth
+ 1))
2156 if (SCHARS (o1
) != SCHARS (o2
))
2158 if (SBYTES (o1
) != SBYTES (o2
))
2160 if (bcmp (SDATA (o1
), SDATA (o2
),
2167 case Lisp_Type_Limit
:
2174 extern Lisp_Object
Fmake_char_internal ();
2176 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2177 doc
: /* Store each element of ARRAY with ITEM.
2178 ARRAY is a vector, string, char-table, or bool-vector. */)
2180 Lisp_Object array
, item
;
2182 register int size
, index
, charval
;
2184 if (VECTORP (array
))
2186 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2187 size
= XVECTOR (array
)->size
;
2188 for (index
= 0; index
< size
; index
++)
2191 else if (CHAR_TABLE_P (array
))
2195 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2196 XCHAR_TABLE (array
)->contents
[i
] = item
;
2197 XCHAR_TABLE (array
)->defalt
= item
;
2199 else if (STRINGP (array
))
2201 register unsigned char *p
= SDATA (array
);
2202 CHECK_NUMBER (item
);
2203 charval
= XINT (item
);
2204 size
= SCHARS (array
);
2205 if (STRING_MULTIBYTE (array
))
2207 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2208 int len
= CHAR_STRING (charval
, str
);
2209 int size_byte
= SBYTES (array
);
2210 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2213 if (size
!= size_byte
)
2216 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2217 if (len
!= this_len
)
2218 error ("Attempt to change byte length of a string");
2221 for (i
= 0; i
< size_byte
; i
++)
2222 *p
++ = str
[i
% len
];
2225 for (index
= 0; index
< size
; index
++)
2228 else if (BOOL_VECTOR_P (array
))
2230 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2232 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2234 charval
= (! NILP (item
) ? -1 : 0);
2235 for (index
= 0; index
< size_in_chars
; index
++)
2240 array
= wrong_type_argument (Qarrayp
, array
);
2246 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2248 doc
: /* Clear the contents of STRING.
2249 This makes STRING unibyte and may change its length. */)
2253 int len
= SBYTES (string
);
2254 bzero (SDATA (string
), len
);
2255 STRING_SET_CHARS (string
, len
);
2256 STRING_SET_UNIBYTE (string
);
2266 Lisp_Object args
[2];
2269 return Fnconc (2, args
);
2271 return Fnconc (2, &s1
);
2272 #endif /* NO_ARG_ARRAY */
2275 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2276 doc
: /* Concatenate any number of lists by altering them.
2277 Only the last argument is not altered, and need not be a list.
2278 usage: (nconc &rest LISTS) */)
2283 register int argnum
;
2284 register Lisp_Object tail
, tem
, val
;
2288 for (argnum
= 0; argnum
< nargs
; argnum
++)
2291 if (NILP (tem
)) continue;
2296 if (argnum
+ 1 == nargs
) break;
2299 tem
= wrong_type_argument (Qlistp
, tem
);
2308 tem
= args
[argnum
+ 1];
2309 Fsetcdr (tail
, tem
);
2311 args
[argnum
+ 1] = tail
;
2317 /* This is the guts of all mapping functions.
2318 Apply FN to each element of SEQ, one by one,
2319 storing the results into elements of VALS, a C vector of Lisp_Objects.
2320 LENI is the length of VALS, which should also be the length of SEQ. */
2323 mapcar1 (leni
, vals
, fn
, seq
)
2326 Lisp_Object fn
, seq
;
2328 register Lisp_Object tail
;
2331 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2335 /* Don't let vals contain any garbage when GC happens. */
2336 for (i
= 0; i
< leni
; i
++)
2339 GCPRO3 (dummy
, fn
, seq
);
2341 gcpro1
.nvars
= leni
;
2345 /* We need not explicitly protect `tail' because it is used only on lists, and
2346 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2350 for (i
= 0; i
< leni
; i
++)
2352 dummy
= XVECTOR (seq
)->contents
[i
];
2353 dummy
= call1 (fn
, dummy
);
2358 else if (BOOL_VECTOR_P (seq
))
2360 for (i
= 0; i
< leni
; i
++)
2363 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2364 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2369 dummy
= call1 (fn
, dummy
);
2374 else if (STRINGP (seq
))
2378 for (i
= 0, i_byte
= 0; i
< leni
;)
2383 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2384 XSETFASTINT (dummy
, c
);
2385 dummy
= call1 (fn
, dummy
);
2387 vals
[i_before
] = dummy
;
2390 else /* Must be a list, since Flength did not get an error */
2393 for (i
= 0; i
< leni
; i
++)
2395 dummy
= call1 (fn
, Fcar (tail
));
2405 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2406 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2407 In between each pair of results, stick in SEPARATOR. Thus, " " as
2408 SEPARATOR results in spaces between the values returned by FUNCTION.
2409 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2410 (function
, sequence
, separator
)
2411 Lisp_Object function
, sequence
, separator
;
2416 register Lisp_Object
*args
;
2418 struct gcpro gcpro1
;
2420 len
= Flength (sequence
);
2422 nargs
= leni
+ leni
- 1;
2423 if (nargs
< 0) return build_string ("");
2425 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2428 mapcar1 (leni
, args
, function
, sequence
);
2431 for (i
= leni
- 1; i
>= 0; i
--)
2432 args
[i
+ i
] = args
[i
];
2434 for (i
= 1; i
< nargs
; i
+= 2)
2435 args
[i
] = separator
;
2437 return Fconcat (nargs
, args
);
2440 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2441 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2442 The result is a list just as long as SEQUENCE.
2443 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2444 (function
, sequence
)
2445 Lisp_Object function
, sequence
;
2447 register Lisp_Object len
;
2449 register Lisp_Object
*args
;
2451 len
= Flength (sequence
);
2452 leni
= XFASTINT (len
);
2453 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2455 mapcar1 (leni
, args
, function
, sequence
);
2457 return Flist (leni
, args
);
2460 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2461 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2462 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2463 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2464 (function
, sequence
)
2465 Lisp_Object function
, sequence
;
2469 leni
= XFASTINT (Flength (sequence
));
2470 mapcar1 (leni
, 0, function
, sequence
);
2475 /* Anything that calls this function must protect from GC! */
2477 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2478 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2479 Takes one argument, which is the string to display to ask the question.
2480 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2481 No confirmation of the answer is requested; a single character is enough.
2482 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
2483 the bindings in `query-replace-map'; see the documentation of that variable
2484 for more information. In this case, the useful bindings are `act', `skip',
2485 `recenter', and `quit'.\)
2487 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2488 is nil and `use-dialog-box' is non-nil. */)
2492 register Lisp_Object obj
, key
, def
, map
;
2493 register int answer
;
2494 Lisp_Object xprompt
;
2495 Lisp_Object args
[2];
2496 struct gcpro gcpro1
, gcpro2
;
2497 int count
= SPECPDL_INDEX ();
2499 specbind (Qcursor_in_echo_area
, Qt
);
2501 map
= Fsymbol_value (intern ("query-replace-map"));
2503 CHECK_STRING (prompt
);
2505 GCPRO2 (prompt
, xprompt
);
2507 #ifdef HAVE_X_WINDOWS
2508 if (display_hourglass_p
)
2509 cancel_hourglass ();
2516 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2520 Lisp_Object pane
, menu
;
2521 redisplay_preserve_echo_area (3);
2522 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2523 Fcons (Fcons (build_string ("No"), Qnil
),
2525 menu
= Fcons (prompt
, pane
);
2526 obj
= Fx_popup_dialog (Qt
, menu
);
2527 answer
= !NILP (obj
);
2530 #endif /* HAVE_MENUS */
2531 cursor_in_echo_area
= 1;
2532 choose_minibuf_frame ();
2535 Lisp_Object pargs
[3];
2537 /* Colorize prompt according to `minibuffer-prompt' face. */
2538 pargs
[0] = build_string ("%s(y or n) ");
2539 pargs
[1] = intern ("face");
2540 pargs
[2] = intern ("minibuffer-prompt");
2541 args
[0] = Fpropertize (3, pargs
);
2546 if (minibuffer_auto_raise
)
2548 Lisp_Object mini_frame
;
2550 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2552 Fraise_frame (mini_frame
);
2555 obj
= read_filtered_event (1, 0, 0, 0);
2556 cursor_in_echo_area
= 0;
2557 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2560 key
= Fmake_vector (make_number (1), obj
);
2561 def
= Flookup_key (map
, key
, Qt
);
2563 if (EQ (def
, intern ("skip")))
2568 else if (EQ (def
, intern ("act")))
2573 else if (EQ (def
, intern ("recenter")))
2579 else if (EQ (def
, intern ("quit")))
2581 /* We want to exit this command for exit-prefix,
2582 and this is the only way to do it. */
2583 else if (EQ (def
, intern ("exit-prefix")))
2588 /* If we don't clear this, then the next call to read_char will
2589 return quit_char again, and we'll enter an infinite loop. */
2594 if (EQ (xprompt
, prompt
))
2596 args
[0] = build_string ("Please answer y or n. ");
2598 xprompt
= Fconcat (2, args
);
2603 if (! noninteractive
)
2605 cursor_in_echo_area
= -1;
2606 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2610 unbind_to (count
, Qnil
);
2611 return answer
? Qt
: Qnil
;
2614 /* This is how C code calls `yes-or-no-p' and allows the user
2617 Anything that calls this function must protect from GC! */
2620 do_yes_or_no_p (prompt
)
2623 return call1 (intern ("yes-or-no-p"), prompt
);
2626 /* Anything that calls this function must protect from GC! */
2628 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2629 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
2630 Takes one argument, which is the string to display to ask the question.
2631 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2632 The user must confirm the answer with RET,
2633 and can edit it until it has been confirmed.
2635 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2636 is nil, and `use-dialog-box' is non-nil. */)
2640 register Lisp_Object ans
;
2641 Lisp_Object args
[2];
2642 struct gcpro gcpro1
;
2644 CHECK_STRING (prompt
);
2647 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2651 Lisp_Object pane
, menu
, obj
;
2652 redisplay_preserve_echo_area (4);
2653 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2654 Fcons (Fcons (build_string ("No"), Qnil
),
2657 menu
= Fcons (prompt
, pane
);
2658 obj
= Fx_popup_dialog (Qt
, menu
);
2662 #endif /* HAVE_MENUS */
2665 args
[1] = build_string ("(yes or no) ");
2666 prompt
= Fconcat (2, args
);
2672 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2673 Qyes_or_no_p_history
, Qnil
,
2675 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
2680 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
2688 message ("Please answer yes or no.");
2689 Fsleep_for (make_number (2), Qnil
);
2693 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2694 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2696 Each of the three load averages is multiplied by 100, then converted
2699 When USE-FLOATS is non-nil, floats will be used instead of integers.
2700 These floats are not multiplied by 100.
2702 If the 5-minute or 15-minute load averages are not available, return a
2703 shortened list, containing only those averages which are available.
2705 An error is thrown if the load average can't be obtained. In some
2706 cases making it work would require Emacs being installed setuid or
2707 setgid so that it can read kernel information, and that usually isn't
2710 Lisp_Object use_floats
;
2713 int loads
= getloadavg (load_ave
, 3);
2714 Lisp_Object ret
= Qnil
;
2717 error ("load-average not implemented for this operating system");
2721 Lisp_Object load
= (NILP (use_floats
) ?
2722 make_number ((int) (100.0 * load_ave
[loads
]))
2723 : make_float (load_ave
[loads
]));
2724 ret
= Fcons (load
, ret
);
2730 Lisp_Object Vfeatures
, Qsubfeatures
;
2731 extern Lisp_Object Vafter_load_alist
;
2733 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2734 doc
: /* Returns t if FEATURE is present in this Emacs.
2736 Use this to conditionalize execution of lisp code based on the
2737 presence or absence of emacs or environment extensions.
2738 Use `provide' to declare that a feature is available. This function
2739 looks at the value of the variable `features'. The optional argument
2740 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2741 (feature
, subfeature
)
2742 Lisp_Object feature
, subfeature
;
2744 register Lisp_Object tem
;
2745 CHECK_SYMBOL (feature
);
2746 tem
= Fmemq (feature
, Vfeatures
);
2747 if (!NILP (tem
) && !NILP (subfeature
))
2748 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2749 return (NILP (tem
)) ? Qnil
: Qt
;
2752 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2753 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2754 The optional argument SUBFEATURES should be a list of symbols listing
2755 particular subfeatures supported in this version of FEATURE. */)
2756 (feature
, subfeatures
)
2757 Lisp_Object feature
, subfeatures
;
2759 register Lisp_Object tem
;
2760 CHECK_SYMBOL (feature
);
2761 CHECK_LIST (subfeatures
);
2762 if (!NILP (Vautoload_queue
))
2763 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2764 tem
= Fmemq (feature
, Vfeatures
);
2766 Vfeatures
= Fcons (feature
, Vfeatures
);
2767 if (!NILP (subfeatures
))
2768 Fput (feature
, Qsubfeatures
, subfeatures
);
2769 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2771 /* Run any load-hooks for this file. */
2772 tem
= Fassq (feature
, Vafter_load_alist
);
2774 Fprogn (XCDR (tem
));
2779 /* `require' and its subroutines. */
2781 /* List of features currently being require'd, innermost first. */
2783 Lisp_Object require_nesting_list
;
2786 require_unwind (old_value
)
2787 Lisp_Object old_value
;
2789 return require_nesting_list
= old_value
;
2792 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2793 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2794 If FEATURE is not a member of the list `features', then the feature
2795 is not loaded; so load the file FILENAME.
2796 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2797 and `load' will try to load this name appended with the suffix `.elc',
2798 `.el' or the unmodified name, in that order.
2799 If the optional third argument NOERROR is non-nil,
2800 then return nil if the file is not found instead of signaling an error.
2801 Normally the return value is FEATURE.
2802 The normal messages at start and end of loading FILENAME are suppressed. */)
2803 (feature
, filename
, noerror
)
2804 Lisp_Object feature
, filename
, noerror
;
2806 register Lisp_Object tem
;
2807 struct gcpro gcpro1
, gcpro2
;
2809 CHECK_SYMBOL (feature
);
2811 tem
= Fmemq (feature
, Vfeatures
);
2815 int count
= SPECPDL_INDEX ();
2818 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2820 /* This is to make sure that loadup.el gives a clear picture
2821 of what files are preloaded and when. */
2822 if (! NILP (Vpurify_flag
))
2823 error ("(require %s) while preparing to dump",
2824 SDATA (SYMBOL_NAME (feature
)));
2826 /* A certain amount of recursive `require' is legitimate,
2827 but if we require the same feature recursively 3 times,
2829 tem
= require_nesting_list
;
2830 while (! NILP (tem
))
2832 if (! NILP (Fequal (feature
, XCAR (tem
))))
2837 error ("Recursive `require' for feature `%s'",
2838 SDATA (SYMBOL_NAME (feature
)));
2840 /* Update the list for any nested `require's that occur. */
2841 record_unwind_protect (require_unwind
, require_nesting_list
);
2842 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2844 /* Value saved here is to be restored into Vautoload_queue */
2845 record_unwind_protect (un_autoload
, Vautoload_queue
);
2846 Vautoload_queue
= Qt
;
2848 /* Load the file. */
2849 GCPRO2 (feature
, filename
);
2850 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2851 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2854 /* If load failed entirely, return nil. */
2856 return unbind_to (count
, Qnil
);
2858 tem
= Fmemq (feature
, Vfeatures
);
2860 error ("Required feature `%s' was not provided",
2861 SDATA (SYMBOL_NAME (feature
)));
2863 /* Once loading finishes, don't undo it. */
2864 Vautoload_queue
= Qt
;
2865 feature
= unbind_to (count
, feature
);
2871 /* Primitives for work of the "widget" library.
2872 In an ideal world, this section would not have been necessary.
2873 However, lisp function calls being as slow as they are, it turns
2874 out that some functions in the widget library (wid-edit.el) are the
2875 bottleneck of Widget operation. Here is their translation to C,
2876 for the sole reason of efficiency. */
2878 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2879 doc
: /* Return non-nil if PLIST has the property PROP.
2880 PLIST is a property list, which is a list of the form
2881 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2882 Unlike `plist-get', this allows you to distinguish between a missing
2883 property and a property with the value nil.
2884 The value is actually the tail of PLIST whose car is PROP. */)
2886 Lisp_Object plist
, prop
;
2888 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2891 plist
= XCDR (plist
);
2892 plist
= CDR (plist
);
2897 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2898 doc
: /* In WIDGET, set PROPERTY to VALUE.
2899 The value can later be retrieved with `widget-get'. */)
2900 (widget
, property
, value
)
2901 Lisp_Object widget
, property
, value
;
2903 CHECK_CONS (widget
);
2904 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2908 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2909 doc
: /* In WIDGET, get the value of PROPERTY.
2910 The value could either be specified when the widget was created, or
2911 later with `widget-put'. */)
2913 Lisp_Object widget
, property
;
2921 CHECK_CONS (widget
);
2922 tmp
= Fplist_member (XCDR (widget
), property
);
2928 tmp
= XCAR (widget
);
2931 widget
= Fget (tmp
, Qwidget_type
);
2935 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2936 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2937 ARGS are passed as extra arguments to the function.
2938 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2943 /* This function can GC. */
2944 Lisp_Object newargs
[3];
2945 struct gcpro gcpro1
, gcpro2
;
2948 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2949 newargs
[1] = args
[0];
2950 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2951 GCPRO2 (newargs
[0], newargs
[2]);
2952 result
= Fapply (3, newargs
);
2957 #ifdef HAVE_LANGINFO_CODESET
2958 #include <langinfo.h>
2961 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2962 doc
: /* Access locale data ITEM for the current C locale, if available.
2963 ITEM should be one of the following:
2965 `codeset', returning the character set as a string (locale item CODESET);
2967 `days', returning a 7-element vector of day names (locale items DAY_n);
2969 `months', returning a 12-element vector of month names (locale items MON_n);
2971 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2972 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2974 If the system can't provide such information through a call to
2975 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2977 See also Info node `(libc)Locales'.
2979 The data read from the system are decoded using `locale-coding-system'. */)
2984 #ifdef HAVE_LANGINFO_CODESET
2986 if (EQ (item
, Qcodeset
))
2988 str
= nl_langinfo (CODESET
);
2989 return build_string (str
);
2992 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2994 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2995 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2997 synchronize_system_time_locale ();
2998 for (i
= 0; i
< 7; i
++)
3000 str
= nl_langinfo (days
[i
]);
3001 val
= make_unibyte_string (str
, strlen (str
));
3002 /* Fixme: Is this coding system necessarily right, even if
3003 it is consistent with CODESET? If not, what to do? */
3004 Faset (v
, make_number (i
),
3005 code_convert_string_norecord (val
, Vlocale_coding_system
,
3012 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3014 struct Lisp_Vector
*p
= allocate_vector (12);
3015 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3016 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3018 synchronize_system_time_locale ();
3019 for (i
= 0; i
< 12; i
++)
3021 str
= nl_langinfo (months
[i
]);
3022 val
= make_unibyte_string (str
, strlen (str
));
3024 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3026 XSETVECTOR (val
, p
);
3030 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3031 but is in the locale files. This could be used by ps-print. */
3033 else if (EQ (item
, Qpaper
))
3035 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3036 make_number (nl_langinfo (PAPER_HEIGHT
)));
3038 #endif /* PAPER_WIDTH */
3039 #endif /* HAVE_LANGINFO_CODESET*/
3043 /* base64 encode/decode functions (RFC 2045).
3044 Based on code from GNU recode. */
3046 #define MIME_LINE_LENGTH 76
3048 #define IS_ASCII(Character) \
3050 #define IS_BASE64(Character) \
3051 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3052 #define IS_BASE64_IGNORABLE(Character) \
3053 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3054 || (Character) == '\f' || (Character) == '\r')
3056 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3057 character or return retval if there are no characters left to
3059 #define READ_QUADRUPLET_BYTE(retval) \
3064 if (nchars_return) \
3065 *nchars_return = nchars; \
3070 while (IS_BASE64_IGNORABLE (c))
3072 /* Don't use alloca for regions larger than this, lest we overflow
3074 #define MAX_ALLOCA 16*1024
3076 /* Table of characters coding the 64 values. */
3077 static char base64_value_to_char
[64] =
3079 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3080 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3081 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3082 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3083 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3084 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3085 '8', '9', '+', '/' /* 60-63 */
3088 /* Table of base64 values for first 128 characters. */
3089 static short base64_char_to_value
[128] =
3091 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3092 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3093 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3094 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3095 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3096 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3097 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3098 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3099 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3100 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3101 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3102 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3103 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3106 /* The following diagram shows the logical steps by which three octets
3107 get transformed into four base64 characters.
3109 .--------. .--------. .--------.
3110 |aaaaaabb| |bbbbcccc| |ccdddddd|
3111 `--------' `--------' `--------'
3113 .--------+--------+--------+--------.
3114 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3115 `--------+--------+--------+--------'
3117 .--------+--------+--------+--------.
3118 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3119 `--------+--------+--------+--------'
3121 The octets are divided into 6 bit chunks, which are then encoded into
3122 base64 characters. */
3125 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3126 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3128 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3130 doc
: /* Base64-encode the region between BEG and END.
3131 Return the length of the encoded text.
3132 Optional third argument NO-LINE-BREAK means do not break long lines
3133 into shorter lines. */)
3134 (beg
, end
, no_line_break
)
3135 Lisp_Object beg
, end
, no_line_break
;
3138 int allength
, length
;
3139 int ibeg
, iend
, encoded_length
;
3142 validate_region (&beg
, &end
);
3144 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3145 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3146 move_gap_both (XFASTINT (beg
), ibeg
);
3148 /* We need to allocate enough room for encoding the text.
3149 We need 33 1/3% more space, plus a newline every 76
3150 characters, and then we round up. */
3151 length
= iend
- ibeg
;
3152 allength
= length
+ length
/3 + 1;
3153 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3155 if (allength
<= MAX_ALLOCA
)
3156 encoded
= (char *) alloca (allength
);
3158 encoded
= (char *) xmalloc (allength
);
3159 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3160 NILP (no_line_break
),
3161 !NILP (current_buffer
->enable_multibyte_characters
));
3162 if (encoded_length
> allength
)
3165 if (encoded_length
< 0)
3167 /* The encoding wasn't possible. */
3168 if (length
> MAX_ALLOCA
)
3170 error ("Multibyte character in data for base64 encoding");
3173 /* Now we have encoded the region, so we insert the new contents
3174 and delete the old. (Insert first in order to preserve markers.) */
3175 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3176 insert (encoded
, encoded_length
);
3177 if (allength
> MAX_ALLOCA
)
3179 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3181 /* If point was outside of the region, restore it exactly; else just
3182 move to the beginning of the region. */
3183 if (old_pos
>= XFASTINT (end
))
3184 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3185 else if (old_pos
> XFASTINT (beg
))
3186 old_pos
= XFASTINT (beg
);
3189 /* We return the length of the encoded text. */
3190 return make_number (encoded_length
);
3193 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3195 doc
: /* Base64-encode STRING and return the result.
3196 Optional second argument NO-LINE-BREAK means do not break long lines
3197 into shorter lines. */)
3198 (string
, no_line_break
)
3199 Lisp_Object string
, no_line_break
;
3201 int allength
, length
, encoded_length
;
3203 Lisp_Object encoded_string
;
3205 CHECK_STRING (string
);
3207 /* We need to allocate enough room for encoding the text.
3208 We need 33 1/3% more space, plus a newline every 76
3209 characters, and then we round up. */
3210 length
= SBYTES (string
);
3211 allength
= length
+ length
/3 + 1;
3212 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3214 /* We need to allocate enough room for decoding the text. */
3215 if (allength
<= MAX_ALLOCA
)
3216 encoded
= (char *) alloca (allength
);
3218 encoded
= (char *) xmalloc (allength
);
3220 encoded_length
= base64_encode_1 (SDATA (string
),
3221 encoded
, length
, NILP (no_line_break
),
3222 STRING_MULTIBYTE (string
));
3223 if (encoded_length
> allength
)
3226 if (encoded_length
< 0)
3228 /* The encoding wasn't possible. */
3229 if (length
> MAX_ALLOCA
)
3231 error ("Multibyte character in data for base64 encoding");
3234 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3235 if (allength
> MAX_ALLOCA
)
3238 return encoded_string
;
3242 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3249 int counter
= 0, i
= 0;
3259 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3260 if (CHAR_BYTE8_P (c
))
3261 c
= CHAR_TO_BYTE8 (c
);
3269 /* Wrap line every 76 characters. */
3273 if (counter
< MIME_LINE_LENGTH
/ 4)
3282 /* Process first byte of a triplet. */
3284 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3285 value
= (0x03 & c
) << 4;
3287 /* Process second byte of a triplet. */
3291 *e
++ = base64_value_to_char
[value
];
3299 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3300 if (CHAR_BYTE8_P (c
))
3301 c
= CHAR_TO_BYTE8 (c
);
3308 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3309 value
= (0x0f & c
) << 2;
3311 /* Process third byte of a triplet. */
3315 *e
++ = base64_value_to_char
[value
];
3322 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3323 if (CHAR_BYTE8_P (c
))
3324 c
= CHAR_TO_BYTE8 (c
);
3332 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3333 *e
++ = base64_value_to_char
[0x3f & c
];
3340 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3342 doc
: /* Base64-decode the region between BEG and END.
3343 Return the length of the decoded text.
3344 If the region can't be decoded, signal an error and don't modify the buffer. */)
3346 Lisp_Object beg
, end
;
3348 int ibeg
, iend
, length
, allength
;
3353 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3355 validate_region (&beg
, &end
);
3357 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3358 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3360 length
= iend
- ibeg
;
3362 /* We need to allocate enough room for decoding the text. If we are
3363 working on a multibyte buffer, each decoded code may occupy at
3365 allength
= multibyte
? length
* 2 : length
;
3366 if (allength
<= MAX_ALLOCA
)
3367 decoded
= (char *) alloca (allength
);
3369 decoded
= (char *) xmalloc (allength
);
3371 move_gap_both (XFASTINT (beg
), ibeg
);
3372 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3373 multibyte
, &inserted_chars
);
3374 if (decoded_length
> allength
)
3377 if (decoded_length
< 0)
3379 /* The decoding wasn't possible. */
3380 if (allength
> MAX_ALLOCA
)
3382 error ("Invalid base64 data");
3385 /* Now we have decoded the region, so we insert the new contents
3386 and delete the old. (Insert first in order to preserve markers.) */
3387 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3388 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3389 if (allength
> MAX_ALLOCA
)
3391 /* Delete the original text. */
3392 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3393 iend
+ decoded_length
, 1);
3395 /* If point was outside of the region, restore it exactly; else just
3396 move to the beginning of the region. */
3397 if (old_pos
>= XFASTINT (end
))
3398 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3399 else if (old_pos
> XFASTINT (beg
))
3400 old_pos
= XFASTINT (beg
);
3401 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3403 return make_number (inserted_chars
);
3406 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3408 doc
: /* Base64-decode STRING and return the result. */)
3413 int length
, decoded_length
;
3414 Lisp_Object decoded_string
;
3416 CHECK_STRING (string
);
3418 length
= SBYTES (string
);
3419 /* We need to allocate enough room for decoding the text. */
3420 if (length
<= MAX_ALLOCA
)
3421 decoded
= (char *) alloca (length
);
3423 decoded
= (char *) xmalloc (length
);
3425 /* The decoded result should be unibyte. */
3426 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3428 if (decoded_length
> length
)
3430 else if (decoded_length
>= 0)
3431 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3433 decoded_string
= Qnil
;
3435 if (length
> MAX_ALLOCA
)
3437 if (!STRINGP (decoded_string
))
3438 error ("Invalid base64 data");
3440 return decoded_string
;
3443 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3444 MULTIBYTE is nonzero, the decoded result should be in multibyte
3445 form. If NCHARS_RETRUN is not NULL, store the number of produced
3446 characters in *NCHARS_RETURN. */
3449 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3459 unsigned long value
;
3464 /* Process first byte of a quadruplet. */
3466 READ_QUADRUPLET_BYTE (e
-to
);
3470 value
= base64_char_to_value
[c
] << 18;
3472 /* Process second byte of a quadruplet. */
3474 READ_QUADRUPLET_BYTE (-1);
3478 value
|= base64_char_to_value
[c
] << 12;
3480 c
= (unsigned char) (value
>> 16);
3481 if (multibyte
&& c
>= 128)
3482 e
+= BYTE8_STRING (c
, e
);
3487 /* Process third byte of a quadruplet. */
3489 READ_QUADRUPLET_BYTE (-1);
3493 READ_QUADRUPLET_BYTE (-1);
3502 value
|= base64_char_to_value
[c
] << 6;
3504 c
= (unsigned char) (0xff & value
>> 8);
3505 if (multibyte
&& c
>= 128)
3506 e
+= BYTE8_STRING (c
, e
);
3511 /* Process fourth byte of a quadruplet. */
3513 READ_QUADRUPLET_BYTE (-1);
3520 value
|= base64_char_to_value
[c
];
3522 c
= (unsigned char) (0xff & value
);
3523 if (multibyte
&& c
>= 128)
3524 e
+= BYTE8_STRING (c
, e
);
3533 /***********************************************************************
3535 ***** Hash Tables *****
3537 ***********************************************************************/
3539 /* Implemented by gerd@gnu.org. This hash table implementation was
3540 inspired by CMUCL hash tables. */
3544 1. For small tables, association lists are probably faster than
3545 hash tables because they have lower overhead.
3547 For uses of hash tables where the O(1) behavior of table
3548 operations is not a requirement, it might therefore be a good idea
3549 not to hash. Instead, we could just do a linear search in the
3550 key_and_value vector of the hash table. This could be done
3551 if a `:linear-search t' argument is given to make-hash-table. */
3554 /* The list of all weak hash tables. Don't staticpro this one. */
3556 Lisp_Object Vweak_hash_tables
;
3558 /* Various symbols. */
3560 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
3561 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
3562 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
3564 /* Function prototypes. */
3566 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
3567 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
3568 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
3569 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3570 Lisp_Object
, unsigned));
3571 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
3572 Lisp_Object
, unsigned));
3573 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
3574 unsigned, Lisp_Object
, unsigned));
3575 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3576 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3577 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
3578 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
3580 static unsigned sxhash_string
P_ ((unsigned char *, int));
3581 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
3582 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
3583 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
3584 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
3588 /***********************************************************************
3590 ***********************************************************************/
3592 /* If OBJ is a Lisp hash table, return a pointer to its struct
3593 Lisp_Hash_Table. Otherwise, signal an error. */
3595 static struct Lisp_Hash_Table
*
3596 check_hash_table (obj
)
3599 CHECK_HASH_TABLE (obj
);
3600 return XHASH_TABLE (obj
);
3604 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3608 next_almost_prime (n
)
3621 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3622 which USED[I] is non-zero. If found at index I in ARGS, set
3623 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3624 -1. This function is used to extract a keyword/argument pair from
3625 a DEFUN parameter list. */
3628 get_key_arg (key
, nargs
, args
, used
)
3636 for (i
= 0; i
< nargs
- 1; ++i
)
3637 if (!used
[i
] && EQ (args
[i
], key
))
3652 /* Return a Lisp vector which has the same contents as VEC but has
3653 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
3654 vector that are not copied from VEC are set to INIT. */
3657 larger_vector (vec
, new_size
, init
)
3662 struct Lisp_Vector
*v
;
3665 xassert (VECTORP (vec
));
3666 old_size
= XVECTOR (vec
)->size
;
3667 xassert (new_size
>= old_size
);
3669 v
= allocate_vector (new_size
);
3670 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
3671 old_size
* sizeof *v
->contents
);
3672 for (i
= old_size
; i
< new_size
; ++i
)
3673 v
->contents
[i
] = init
;
3674 XSETVECTOR (vec
, v
);
3679 /***********************************************************************
3681 ***********************************************************************/
3683 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3684 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
3685 KEY2 are the same. */
3688 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
3689 struct Lisp_Hash_Table
*h
;
3690 Lisp_Object key1
, key2
;
3691 unsigned hash1
, hash2
;
3693 return (FLOATP (key1
)
3695 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3699 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3700 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
3701 KEY2 are the same. */
3704 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
3705 struct Lisp_Hash_Table
*h
;
3706 Lisp_Object key1
, key2
;
3707 unsigned hash1
, hash2
;
3709 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
3713 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3714 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
3715 if KEY1 and KEY2 are the same. */
3718 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
3719 struct Lisp_Hash_Table
*h
;
3720 Lisp_Object key1
, key2
;
3721 unsigned hash1
, hash2
;
3725 Lisp_Object args
[3];
3727 args
[0] = h
->user_cmp_function
;
3730 return !NILP (Ffuncall (3, args
));
3737 /* Value is a hash code for KEY for use in hash table H which uses
3738 `eq' to compare keys. The hash code returned is guaranteed to fit
3739 in a Lisp integer. */
3743 struct Lisp_Hash_Table
*h
;
3746 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
3747 xassert ((hash
& ~VALMASK
) == 0);
3752 /* Value is a hash code for KEY for use in hash table H which uses
3753 `eql' to compare keys. The hash code returned is guaranteed to fit
3754 in a Lisp integer. */
3758 struct Lisp_Hash_Table
*h
;
3763 hash
= sxhash (key
, 0);
3765 hash
= XUINT (key
) ^ XGCTYPE (key
);
3766 xassert ((hash
& ~VALMASK
) == 0);
3771 /* Value is a hash code for KEY for use in hash table H which uses
3772 `equal' to compare keys. The hash code returned is guaranteed to fit
3773 in a Lisp integer. */
3776 hashfn_equal (h
, key
)
3777 struct Lisp_Hash_Table
*h
;
3780 unsigned hash
= sxhash (key
, 0);
3781 xassert ((hash
& ~VALMASK
) == 0);
3786 /* Value is a hash code for KEY for use in hash table H which uses as
3787 user-defined function to compare keys. The hash code returned is
3788 guaranteed to fit in a Lisp integer. */
3791 hashfn_user_defined (h
, key
)
3792 struct Lisp_Hash_Table
*h
;
3795 Lisp_Object args
[2], hash
;
3797 args
[0] = h
->user_hash_function
;
3799 hash
= Ffuncall (2, args
);
3800 if (!INTEGERP (hash
))
3802 list2 (build_string ("Invalid hash code returned from \
3803 user-supplied hash function"),
3805 return XUINT (hash
);
3809 /* Create and initialize a new hash table.
3811 TEST specifies the test the hash table will use to compare keys.
3812 It must be either one of the predefined tests `eq', `eql' or
3813 `equal' or a symbol denoting a user-defined test named TEST with
3814 test and hash functions USER_TEST and USER_HASH.
3816 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3818 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3819 new size when it becomes full is computed by adding REHASH_SIZE to
3820 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3821 table's new size is computed by multiplying its old size with
3824 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3825 be resized when the ratio of (number of entries in the table) /
3826 (table size) is >= REHASH_THRESHOLD.
3828 WEAK specifies the weakness of the table. If non-nil, it must be
3829 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3832 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
3833 user_test
, user_hash
)
3834 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
3835 Lisp_Object user_test
, user_hash
;
3837 struct Lisp_Hash_Table
*h
;
3839 int index_size
, i
, sz
;
3841 /* Preconditions. */
3842 xassert (SYMBOLP (test
));
3843 xassert (INTEGERP (size
) && XINT (size
) >= 0);
3844 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3845 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
3846 xassert (FLOATP (rehash_threshold
)
3847 && XFLOATINT (rehash_threshold
) > 0
3848 && XFLOATINT (rehash_threshold
) <= 1.0);
3850 if (XFASTINT (size
) == 0)
3851 size
= make_number (1);
3853 /* Allocate a table and initialize it. */
3854 h
= allocate_hash_table ();
3856 /* Initialize hash table slots. */
3857 sz
= XFASTINT (size
);
3860 if (EQ (test
, Qeql
))
3862 h
->cmpfn
= cmpfn_eql
;
3863 h
->hashfn
= hashfn_eql
;
3865 else if (EQ (test
, Qeq
))
3868 h
->hashfn
= hashfn_eq
;
3870 else if (EQ (test
, Qequal
))
3872 h
->cmpfn
= cmpfn_equal
;
3873 h
->hashfn
= hashfn_equal
;
3877 h
->user_cmp_function
= user_test
;
3878 h
->user_hash_function
= user_hash
;
3879 h
->cmpfn
= cmpfn_user_defined
;
3880 h
->hashfn
= hashfn_user_defined
;
3884 h
->rehash_threshold
= rehash_threshold
;
3885 h
->rehash_size
= rehash_size
;
3886 h
->count
= make_number (0);
3887 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3888 h
->hash
= Fmake_vector (size
, Qnil
);
3889 h
->next
= Fmake_vector (size
, Qnil
);
3890 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
3891 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
3892 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3894 /* Set up the free list. */
3895 for (i
= 0; i
< sz
- 1; ++i
)
3896 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3897 h
->next_free
= make_number (0);
3899 XSET_HASH_TABLE (table
, h
);
3900 xassert (HASH_TABLE_P (table
));
3901 xassert (XHASH_TABLE (table
) == h
);
3903 /* Maybe add this hash table to the list of all weak hash tables. */
3905 h
->next_weak
= Qnil
;
3908 h
->next_weak
= Vweak_hash_tables
;
3909 Vweak_hash_tables
= table
;
3916 /* Return a copy of hash table H1. Keys and values are not copied,
3917 only the table itself is. */
3920 copy_hash_table (h1
)
3921 struct Lisp_Hash_Table
*h1
;
3924 struct Lisp_Hash_Table
*h2
;
3925 struct Lisp_Vector
*next
;
3927 h2
= allocate_hash_table ();
3928 next
= h2
->vec_next
;
3929 bcopy (h1
, h2
, sizeof *h2
);
3930 h2
->vec_next
= next
;
3931 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3932 h2
->hash
= Fcopy_sequence (h1
->hash
);
3933 h2
->next
= Fcopy_sequence (h1
->next
);
3934 h2
->index
= Fcopy_sequence (h1
->index
);
3935 XSET_HASH_TABLE (table
, h2
);
3937 /* Maybe add this hash table to the list of all weak hash tables. */
3938 if (!NILP (h2
->weak
))
3940 h2
->next_weak
= Vweak_hash_tables
;
3941 Vweak_hash_tables
= table
;
3948 /* Resize hash table H if it's too full. If H cannot be resized
3949 because it's already too large, throw an error. */
3952 maybe_resize_hash_table (h
)
3953 struct Lisp_Hash_Table
*h
;
3955 if (NILP (h
->next_free
))
3957 int old_size
= HASH_TABLE_SIZE (h
);
3958 int i
, new_size
, index_size
;
3960 if (INTEGERP (h
->rehash_size
))
3961 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3963 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
3964 new_size
= max (old_size
+ 1, new_size
);
3965 index_size
= next_almost_prime ((int)
3967 / XFLOATINT (h
->rehash_threshold
)));
3968 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
3969 error ("Hash table too large to resize");
3971 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
3972 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
3973 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
3974 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3976 /* Update the free list. Do it so that new entries are added at
3977 the end of the free list. This makes some operations like
3979 for (i
= old_size
; i
< new_size
- 1; ++i
)
3980 HASH_NEXT (h
, i
) = make_number (i
+ 1);
3982 if (!NILP (h
->next_free
))
3984 Lisp_Object last
, next
;
3986 last
= h
->next_free
;
3987 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3991 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
3994 XSETFASTINT (h
->next_free
, old_size
);
3997 for (i
= 0; i
< old_size
; ++i
)
3998 if (!NILP (HASH_HASH (h
, i
)))
4000 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4001 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4002 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4003 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4009 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4010 the hash code of KEY. Value is the index of the entry in H
4011 matching KEY, or -1 if not found. */
4014 hash_lookup (h
, key
, hash
)
4015 struct Lisp_Hash_Table
*h
;
4020 int start_of_bucket
;
4023 hash_code
= h
->hashfn (h
, key
);
4027 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4028 idx
= HASH_INDEX (h
, start_of_bucket
);
4030 /* We need not gcpro idx since it's either an integer or nil. */
4033 int i
= XFASTINT (idx
);
4034 if (EQ (key
, HASH_KEY (h
, i
))
4036 && h
->cmpfn (h
, key
, hash_code
,
4037 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4039 idx
= HASH_NEXT (h
, i
);
4042 return NILP (idx
) ? -1 : XFASTINT (idx
);
4046 /* Put an entry into hash table H that associates KEY with VALUE.
4047 HASH is a previously computed hash code of KEY.
4048 Value is the index of the entry in H matching KEY. */
4051 hash_put (h
, key
, value
, hash
)
4052 struct Lisp_Hash_Table
*h
;
4053 Lisp_Object key
, value
;
4056 int start_of_bucket
, i
;
4058 xassert ((hash
& ~VALMASK
) == 0);
4060 /* Increment count after resizing because resizing may fail. */
4061 maybe_resize_hash_table (h
);
4062 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4064 /* Store key/value in the key_and_value vector. */
4065 i
= XFASTINT (h
->next_free
);
4066 h
->next_free
= HASH_NEXT (h
, i
);
4067 HASH_KEY (h
, i
) = key
;
4068 HASH_VALUE (h
, i
) = value
;
4070 /* Remember its hash code. */
4071 HASH_HASH (h
, i
) = make_number (hash
);
4073 /* Add new entry to its collision chain. */
4074 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4075 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4076 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4081 /* Remove the entry matching KEY from hash table H, if there is one. */
4084 hash_remove (h
, key
)
4085 struct Lisp_Hash_Table
*h
;
4089 int start_of_bucket
;
4090 Lisp_Object idx
, prev
;
4092 hash_code
= h
->hashfn (h
, key
);
4093 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4094 idx
= HASH_INDEX (h
, start_of_bucket
);
4097 /* We need not gcpro idx, prev since they're either integers or nil. */
4100 int i
= XFASTINT (idx
);
4102 if (EQ (key
, HASH_KEY (h
, i
))
4104 && h
->cmpfn (h
, key
, hash_code
,
4105 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4107 /* Take entry out of collision chain. */
4109 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4111 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4113 /* Clear slots in key_and_value and add the slots to
4115 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4116 HASH_NEXT (h
, i
) = h
->next_free
;
4117 h
->next_free
= make_number (i
);
4118 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4119 xassert (XINT (h
->count
) >= 0);
4125 idx
= HASH_NEXT (h
, i
);
4131 /* Clear hash table H. */
4135 struct Lisp_Hash_Table
*h
;
4137 if (XFASTINT (h
->count
) > 0)
4139 int i
, size
= HASH_TABLE_SIZE (h
);
4141 for (i
= 0; i
< size
; ++i
)
4143 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4144 HASH_KEY (h
, i
) = Qnil
;
4145 HASH_VALUE (h
, i
) = Qnil
;
4146 HASH_HASH (h
, i
) = Qnil
;
4149 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4150 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4152 h
->next_free
= make_number (0);
4153 h
->count
= make_number (0);
4159 /************************************************************************
4161 ************************************************************************/
4163 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4164 entries from the table that don't survive the current GC.
4165 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4166 non-zero if anything was marked. */
4169 sweep_weak_table (h
, remove_entries_p
)
4170 struct Lisp_Hash_Table
*h
;
4171 int remove_entries_p
;
4173 int bucket
, n
, marked
;
4175 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4178 for (bucket
= 0; bucket
< n
; ++bucket
)
4180 Lisp_Object idx
, next
, prev
;
4182 /* Follow collision chain, removing entries that
4183 don't survive this garbage collection. */
4185 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4187 int i
= XFASTINT (idx
);
4188 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4189 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4192 if (EQ (h
->weak
, Qkey
))
4193 remove_p
= !key_known_to_survive_p
;
4194 else if (EQ (h
->weak
, Qvalue
))
4195 remove_p
= !value_known_to_survive_p
;
4196 else if (EQ (h
->weak
, Qkey_or_value
))
4197 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4198 else if (EQ (h
->weak
, Qkey_and_value
))
4199 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4203 next
= HASH_NEXT (h
, i
);
4205 if (remove_entries_p
)
4209 /* Take out of collision chain. */
4211 HASH_INDEX (h
, bucket
) = next
;
4213 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4215 /* Add to free list. */
4216 HASH_NEXT (h
, i
) = h
->next_free
;
4219 /* Clear key, value, and hash. */
4220 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4221 HASH_HASH (h
, i
) = Qnil
;
4223 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4230 /* Make sure key and value survive. */
4231 if (!key_known_to_survive_p
)
4233 mark_object (HASH_KEY (h
, i
));
4237 if (!value_known_to_survive_p
)
4239 mark_object (HASH_VALUE (h
, i
));
4250 /* Remove elements from weak hash tables that don't survive the
4251 current garbage collection. Remove weak tables that don't survive
4252 from Vweak_hash_tables. Called from gc_sweep. */
4255 sweep_weak_hash_tables ()
4257 Lisp_Object table
, used
, next
;
4258 struct Lisp_Hash_Table
*h
;
4261 /* Mark all keys and values that are in use. Keep on marking until
4262 there is no more change. This is necessary for cases like
4263 value-weak table A containing an entry X -> Y, where Y is used in a
4264 key-weak table B, Z -> Y. If B comes after A in the list of weak
4265 tables, X -> Y might be removed from A, although when looking at B
4266 one finds that it shouldn't. */
4270 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4272 h
= XHASH_TABLE (table
);
4273 if (h
->size
& ARRAY_MARK_FLAG
)
4274 marked
|= sweep_weak_table (h
, 0);
4279 /* Remove tables and entries that aren't used. */
4280 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4282 h
= XHASH_TABLE (table
);
4283 next
= h
->next_weak
;
4285 if (h
->size
& ARRAY_MARK_FLAG
)
4287 /* TABLE is marked as used. Sweep its contents. */
4288 if (XFASTINT (h
->count
) > 0)
4289 sweep_weak_table (h
, 1);
4291 /* Add table to the list of used weak hash tables. */
4292 h
->next_weak
= used
;
4297 Vweak_hash_tables
= used
;
4302 /***********************************************************************
4303 Hash Code Computation
4304 ***********************************************************************/
4306 /* Maximum depth up to which to dive into Lisp structures. */
4308 #define SXHASH_MAX_DEPTH 3
4310 /* Maximum length up to which to take list and vector elements into
4313 #define SXHASH_MAX_LEN 7
4315 /* Combine two integers X and Y for hashing. */
4317 #define SXHASH_COMBINE(X, Y) \
4318 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4322 /* Return a hash for string PTR which has length LEN. The hash
4323 code returned is guaranteed to fit in a Lisp integer. */
4326 sxhash_string (ptr
, len
)
4330 unsigned char *p
= ptr
;
4331 unsigned char *end
= p
+ len
;
4340 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4343 return hash
& VALMASK
;
4347 /* Return a hash for list LIST. DEPTH is the current depth in the
4348 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4351 sxhash_list (list
, depth
)
4358 if (depth
< SXHASH_MAX_DEPTH
)
4360 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4361 list
= XCDR (list
), ++i
)
4363 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4364 hash
= SXHASH_COMBINE (hash
, hash2
);
4371 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4372 the Lisp structure. */
4375 sxhash_vector (vec
, depth
)
4379 unsigned hash
= XVECTOR (vec
)->size
;
4382 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4383 for (i
= 0; i
< n
; ++i
)
4385 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4386 hash
= SXHASH_COMBINE (hash
, hash2
);
4393 /* Return a hash for bool-vector VECTOR. */
4396 sxhash_bool_vector (vec
)
4399 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4402 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4403 for (i
= 0; i
< n
; ++i
)
4404 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4410 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4411 structure. Value is an unsigned integer clipped to VALMASK. */
4420 if (depth
> SXHASH_MAX_DEPTH
)
4423 switch (XTYPE (obj
))
4430 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4431 SCHARS (SYMBOL_NAME (obj
)));
4439 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4442 /* This can be everything from a vector to an overlay. */
4443 case Lisp_Vectorlike
:
4445 /* According to the CL HyperSpec, two arrays are equal only if
4446 they are `eq', except for strings and bit-vectors. In
4447 Emacs, this works differently. We have to compare element
4449 hash
= sxhash_vector (obj
, depth
);
4450 else if (BOOL_VECTOR_P (obj
))
4451 hash
= sxhash_bool_vector (obj
);
4453 /* Others are `equal' if they are `eq', so let's take their
4459 hash
= sxhash_list (obj
, depth
);
4464 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4465 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4466 for (hash
= 0; p
< e
; ++p
)
4467 hash
= SXHASH_COMBINE (hash
, *p
);
4475 return hash
& VALMASK
;
4480 /***********************************************************************
4482 ***********************************************************************/
4485 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4486 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4490 unsigned hash
= sxhash (obj
, 0);;
4491 return make_number (hash
);
4495 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4496 doc
: /* Create and return a new hash table.
4498 Arguments are specified as keyword/argument pairs. The following
4499 arguments are defined:
4501 :test TEST -- TEST must be a symbol that specifies how to compare
4502 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4503 `equal'. User-supplied test and hash functions can be specified via
4504 `define-hash-table-test'.
4506 :size SIZE -- A hint as to how many elements will be put in the table.
4509 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4510 fills up. If REHASH-SIZE is an integer, add that many space. If it
4511 is a float, it must be > 1.0, and the new size is computed by
4512 multiplying the old size with that factor. Default is 1.5.
4514 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4515 Resize the hash table when ratio of the number of entries in the
4516 table. Default is 0.8.
4518 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4519 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4520 returned is a weak table. Key/value pairs are removed from a weak
4521 hash table when there are no non-weak references pointing to their
4522 key, value, one of key or value, or both key and value, depending on
4523 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4526 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4531 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4532 Lisp_Object user_test
, user_hash
;
4536 /* The vector `used' is used to keep track of arguments that
4537 have been consumed. */
4538 used
= (char *) alloca (nargs
* sizeof *used
);
4539 bzero (used
, nargs
* sizeof *used
);
4541 /* See if there's a `:test TEST' among the arguments. */
4542 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4543 test
= i
< 0 ? Qeql
: args
[i
];
4544 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
4546 /* See if it is a user-defined test. */
4549 prop
= Fget (test
, Qhash_table_test
);
4550 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4551 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
4553 user_test
= XCAR (prop
);
4554 user_hash
= XCAR (XCDR (prop
));
4557 user_test
= user_hash
= Qnil
;
4559 /* See if there's a `:size SIZE' argument. */
4560 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4561 size
= i
< 0 ? Qnil
: args
[i
];
4563 size
= make_number (DEFAULT_HASH_SIZE
);
4564 else if (!INTEGERP (size
) || XINT (size
) < 0)
4566 list2 (build_string ("Invalid hash table size"),
4569 /* Look for `:rehash-size SIZE'. */
4570 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4571 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
4572 if (!NUMBERP (rehash_size
)
4573 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
4574 || XFLOATINT (rehash_size
) <= 1.0)
4576 list2 (build_string ("Invalid hash table rehash size"),
4579 /* Look for `:rehash-threshold THRESHOLD'. */
4580 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4581 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
4582 if (!FLOATP (rehash_threshold
)
4583 || XFLOATINT (rehash_threshold
) <= 0.0
4584 || XFLOATINT (rehash_threshold
) > 1.0)
4586 list2 (build_string ("Invalid hash table rehash threshold"),
4589 /* Look for `:weakness WEAK'. */
4590 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4591 weak
= i
< 0 ? Qnil
: args
[i
];
4593 weak
= Qkey_and_value
;
4596 && !EQ (weak
, Qvalue
)
4597 && !EQ (weak
, Qkey_or_value
)
4598 && !EQ (weak
, Qkey_and_value
))
4599 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
4602 /* Now, all args should have been used up, or there's a problem. */
4603 for (i
= 0; i
< nargs
; ++i
)
4606 list2 (build_string ("Invalid argument list"), args
[i
]));
4608 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4609 user_test
, user_hash
);
4613 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4614 doc
: /* Return a copy of hash table TABLE. */)
4618 return copy_hash_table (check_hash_table (table
));
4622 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4623 doc
: /* Return the number of elements in TABLE. */)
4627 return check_hash_table (table
)->count
;
4631 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4632 Shash_table_rehash_size
, 1, 1, 0,
4633 doc
: /* Return the current rehash size of TABLE. */)
4637 return check_hash_table (table
)->rehash_size
;
4641 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4642 Shash_table_rehash_threshold
, 1, 1, 0,
4643 doc
: /* Return the current rehash threshold of TABLE. */)
4647 return check_hash_table (table
)->rehash_threshold
;
4651 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4652 doc
: /* Return the size of TABLE.
4653 The size can be used as an argument to `make-hash-table' to create
4654 a hash table than can hold as many elements of TABLE holds
4655 without need for resizing. */)
4659 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4660 return make_number (HASH_TABLE_SIZE (h
));
4664 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4665 doc
: /* Return the test TABLE uses. */)
4669 return check_hash_table (table
)->test
;
4673 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4675 doc
: /* Return the weakness of TABLE. */)
4679 return check_hash_table (table
)->weak
;
4683 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4684 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4688 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4692 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4693 doc
: /* Clear hash table TABLE. */)
4697 hash_clear (check_hash_table (table
));
4702 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4703 doc
: /* Look up KEY in TABLE and return its associated value.
4704 If KEY is not found, return DFLT which defaults to nil. */)
4706 Lisp_Object key
, table
, dflt
;
4708 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4709 int i
= hash_lookup (h
, key
, NULL
);
4710 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4714 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4715 doc
: /* Associate KEY with VALUE in hash table TABLE.
4716 If KEY is already present in table, replace its current value with
4719 Lisp_Object key
, value
, table
;
4721 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4725 i
= hash_lookup (h
, key
, &hash
);
4727 HASH_VALUE (h
, i
) = value
;
4729 hash_put (h
, key
, value
, hash
);
4735 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4736 doc
: /* Remove KEY from TABLE. */)
4738 Lisp_Object key
, table
;
4740 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4741 hash_remove (h
, key
);
4746 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4747 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4748 FUNCTION is called with 2 arguments KEY and VALUE. */)
4750 Lisp_Object function
, table
;
4752 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4753 Lisp_Object args
[3];
4756 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4757 if (!NILP (HASH_HASH (h
, i
)))
4760 args
[1] = HASH_KEY (h
, i
);
4761 args
[2] = HASH_VALUE (h
, i
);
4769 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4770 Sdefine_hash_table_test
, 3, 3, 0,
4771 doc
: /* Define a new hash table test with name NAME, a symbol.
4773 In hash tables created with NAME specified as test, use TEST to
4774 compare keys, and HASH for computing hash codes of keys.
4776 TEST must be a function taking two arguments and returning non-nil if
4777 both arguments are the same. HASH must be a function taking one
4778 argument and return an integer that is the hash code of the argument.
4779 Hash code computation should use the whole value range of integers,
4780 including negative integers. */)
4782 Lisp_Object name
, test
, hash
;
4784 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4789 /************************************************************************
4791 ************************************************************************/
4795 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4796 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4798 A message digest is a cryptographic checksum of a document, and the
4799 algorithm to calculate it is defined in RFC 1321.
4801 The two optional arguments START and END are character positions
4802 specifying for which part of OBJECT the message digest should be
4803 computed. If nil or omitted, the digest is computed for the whole
4806 The MD5 message digest is computed from the result of encoding the
4807 text in a coding system, not directly from the internal Emacs form of
4808 the text. The optional fourth argument CODING-SYSTEM specifies which
4809 coding system to encode the text with. It should be the same coding
4810 system that you used or will use when actually writing the text into a
4813 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4814 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4815 system would be chosen by default for writing this text into a file.
4817 If OBJECT is a string, the most preferred coding system (see the
4818 command `prefer-coding-system') is used.
4820 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4821 guesswork fails. Normally, an error is signaled in such case. */)
4822 (object
, start
, end
, coding_system
, noerror
)
4823 Lisp_Object object
, start
, end
, coding_system
, noerror
;
4825 unsigned char digest
[16];
4826 unsigned char value
[33];
4830 int start_char
= 0, end_char
= 0;
4831 int start_byte
= 0, end_byte
= 0;
4833 register struct buffer
*bp
;
4836 if (STRINGP (object
))
4838 if (NILP (coding_system
))
4840 /* Decide the coding-system to encode the data with. */
4842 if (STRING_MULTIBYTE (object
))
4843 /* use default, we can't guess correct value */
4844 coding_system
= preferred_coding_system ();
4846 coding_system
= Qraw_text
;
4849 if (NILP (Fcoding_system_p (coding_system
)))
4851 /* Invalid coding system. */
4853 if (!NILP (noerror
))
4854 coding_system
= Qraw_text
;
4857 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4860 if (STRING_MULTIBYTE (object
))
4861 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4863 size
= SCHARS (object
);
4864 size_byte
= SBYTES (object
);
4868 CHECK_NUMBER (start
);
4870 start_char
= XINT (start
);
4875 start_byte
= string_char_to_byte (object
, start_char
);
4881 end_byte
= size_byte
;
4887 end_char
= XINT (end
);
4892 end_byte
= string_char_to_byte (object
, end_char
);
4895 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
4896 args_out_of_range_3 (object
, make_number (start_char
),
4897 make_number (end_char
));
4901 CHECK_BUFFER (object
);
4903 bp
= XBUFFER (object
);
4909 CHECK_NUMBER_COERCE_MARKER (start
);
4917 CHECK_NUMBER_COERCE_MARKER (end
);
4922 temp
= b
, b
= e
, e
= temp
;
4924 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
4925 args_out_of_range (start
, end
);
4927 if (NILP (coding_system
))
4929 /* Decide the coding-system to encode the data with.
4930 See fileio.c:Fwrite-region */
4932 if (!NILP (Vcoding_system_for_write
))
4933 coding_system
= Vcoding_system_for_write
;
4936 int force_raw_text
= 0;
4938 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4939 if (NILP (coding_system
)
4940 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4942 coding_system
= Qnil
;
4943 if (NILP (current_buffer
->enable_multibyte_characters
))
4947 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
4949 /* Check file-coding-system-alist. */
4950 Lisp_Object args
[4], val
;
4952 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4953 args
[3] = Fbuffer_file_name(object
);
4954 val
= Ffind_operation_coding_system (4, args
);
4955 if (CONSP (val
) && !NILP (XCDR (val
)))
4956 coding_system
= XCDR (val
);
4959 if (NILP (coding_system
)
4960 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
4962 /* If we still have not decided a coding system, use the
4963 default value of buffer-file-coding-system. */
4964 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
4968 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4969 /* Confirm that VAL can surely encode the current region. */
4970 coding_system
= call4 (Vselect_safe_coding_system_function
,
4971 make_number (b
), make_number (e
),
4972 coding_system
, Qnil
);
4975 coding_system
= Qraw_text
;
4978 if (NILP (Fcoding_system_p (coding_system
)))
4980 /* Invalid coding system. */
4982 if (!NILP (noerror
))
4983 coding_system
= Qraw_text
;
4986 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
4990 object
= make_buffer_string (b
, e
, 0);
4992 if (STRING_MULTIBYTE (object
))
4993 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4996 md5_buffer (SDATA (object
) + start_byte
,
4997 SBYTES (object
) - (size_byte
- end_byte
),
5000 for (i
= 0; i
< 16; i
++)
5001 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5004 return make_string (value
, 32);
5011 /* Hash table stuff. */
5012 Qhash_table_p
= intern ("hash-table-p");
5013 staticpro (&Qhash_table_p
);
5014 Qeq
= intern ("eq");
5016 Qeql
= intern ("eql");
5018 Qequal
= intern ("equal");
5019 staticpro (&Qequal
);
5020 QCtest
= intern (":test");
5021 staticpro (&QCtest
);
5022 QCsize
= intern (":size");
5023 staticpro (&QCsize
);
5024 QCrehash_size
= intern (":rehash-size");
5025 staticpro (&QCrehash_size
);
5026 QCrehash_threshold
= intern (":rehash-threshold");
5027 staticpro (&QCrehash_threshold
);
5028 QCweakness
= intern (":weakness");
5029 staticpro (&QCweakness
);
5030 Qkey
= intern ("key");
5032 Qvalue
= intern ("value");
5033 staticpro (&Qvalue
);
5034 Qhash_table_test
= intern ("hash-table-test");
5035 staticpro (&Qhash_table_test
);
5036 Qkey_or_value
= intern ("key-or-value");
5037 staticpro (&Qkey_or_value
);
5038 Qkey_and_value
= intern ("key-and-value");
5039 staticpro (&Qkey_and_value
);
5042 defsubr (&Smake_hash_table
);
5043 defsubr (&Scopy_hash_table
);
5044 defsubr (&Shash_table_count
);
5045 defsubr (&Shash_table_rehash_size
);
5046 defsubr (&Shash_table_rehash_threshold
);
5047 defsubr (&Shash_table_size
);
5048 defsubr (&Shash_table_test
);
5049 defsubr (&Shash_table_weakness
);
5050 defsubr (&Shash_table_p
);
5051 defsubr (&Sclrhash
);
5052 defsubr (&Sgethash
);
5053 defsubr (&Sputhash
);
5054 defsubr (&Sremhash
);
5055 defsubr (&Smaphash
);
5056 defsubr (&Sdefine_hash_table_test
);
5058 Qstring_lessp
= intern ("string-lessp");
5059 staticpro (&Qstring_lessp
);
5060 Qprovide
= intern ("provide");
5061 staticpro (&Qprovide
);
5062 Qrequire
= intern ("require");
5063 staticpro (&Qrequire
);
5064 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5065 staticpro (&Qyes_or_no_p_history
);
5066 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5067 staticpro (&Qcursor_in_echo_area
);
5068 Qwidget_type
= intern ("widget-type");
5069 staticpro (&Qwidget_type
);
5071 staticpro (&string_char_byte_cache_string
);
5072 string_char_byte_cache_string
= Qnil
;
5074 require_nesting_list
= Qnil
;
5075 staticpro (&require_nesting_list
);
5077 Fset (Qyes_or_no_p_history
, Qnil
);
5079 DEFVAR_LISP ("features", &Vfeatures
,
5080 doc
: /* A list of symbols which are the features of the executing emacs.
5081 Used by `featurep' and `require', and altered by `provide'. */);
5083 Qsubfeatures
= intern ("subfeatures");
5084 staticpro (&Qsubfeatures
);
5086 #ifdef HAVE_LANGINFO_CODESET
5087 Qcodeset
= intern ("codeset");
5088 staticpro (&Qcodeset
);
5089 Qdays
= intern ("days");
5091 Qmonths
= intern ("months");
5092 staticpro (&Qmonths
);
5093 Qpaper
= intern ("paper");
5094 staticpro (&Qpaper
);
5095 #endif /* HAVE_LANGINFO_CODESET */
5097 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5098 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5099 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5100 invoked by mouse clicks and mouse menu items. */);
5103 defsubr (&Sidentity
);
5106 defsubr (&Ssafe_length
);
5107 defsubr (&Sstring_bytes
);
5108 defsubr (&Sstring_equal
);
5109 defsubr (&Scompare_strings
);
5110 defsubr (&Sstring_lessp
);
5113 defsubr (&Svconcat
);
5114 defsubr (&Scopy_sequence
);
5115 defsubr (&Sstring_make_multibyte
);
5116 defsubr (&Sstring_make_unibyte
);
5117 defsubr (&Sstring_as_multibyte
);
5118 defsubr (&Sstring_as_unibyte
);
5119 defsubr (&Sstring_to_multibyte
);
5120 defsubr (&Scopy_alist
);
5121 defsubr (&Ssubstring
);
5122 defsubr (&Ssubstring_no_properties
);
5134 defsubr (&Snreverse
);
5135 defsubr (&Sreverse
);
5137 defsubr (&Splist_get
);
5139 defsubr (&Splist_put
);
5141 defsubr (&Slax_plist_get
);
5142 defsubr (&Slax_plist_put
);
5144 defsubr (&Sfillarray
);
5145 defsubr (&Sclear_string
);
5149 defsubr (&Smapconcat
);
5150 defsubr (&Sy_or_n_p
);
5151 defsubr (&Syes_or_no_p
);
5152 defsubr (&Sload_average
);
5153 defsubr (&Sfeaturep
);
5154 defsubr (&Srequire
);
5155 defsubr (&Sprovide
);
5156 defsubr (&Splist_member
);
5157 defsubr (&Swidget_put
);
5158 defsubr (&Swidget_get
);
5159 defsubr (&Swidget_apply
);
5160 defsubr (&Sbase64_encode_region
);
5161 defsubr (&Sbase64_decode_region
);
5162 defsubr (&Sbase64_encode_string
);
5163 defsubr (&Sbase64_decode_string
);
5165 defsubr (&Slocale_info
);
5172 Vweak_hash_tables
= Qnil
;