1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001, 2002
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 */
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 (SUB_CHAR_TABLE_P (sequence
))
146 XSETFASTINT (val
, SUB_CHAR_TABLE_ORDINARY_SLOTS
);
147 else if (CHAR_TABLE_P (sequence
))
148 XSETFASTINT (val
, MAX_CHAR
);
149 else if (BOOL_VECTOR_P (sequence
))
150 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
151 else if (COMPILEDP (sequence
))
152 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
153 else if (CONSP (sequence
))
156 while (CONSP (sequence
))
158 sequence
= XCDR (sequence
);
161 if (!CONSP (sequence
))
164 sequence
= XCDR (sequence
);
169 if (!NILP (sequence
))
170 wrong_type_argument (Qlistp
, sequence
);
172 val
= make_number (i
);
174 else if (NILP (sequence
))
175 XSETFASTINT (val
, 0);
178 sequence
= wrong_type_argument (Qsequencep
, sequence
);
184 /* This does not check for quits. That is safe
185 since it must terminate. */
187 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
188 doc
: /* Return the length of a list, but avoid error or infinite loop.
189 This function never gets an error. If LIST is not really a list,
190 it returns 0. If LIST is circular, it returns a finite value
191 which is at least the number of distinct elements. */)
195 Lisp_Object tail
, halftail
, length
;
198 /* halftail is used to detect circular lists. */
200 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
202 if (EQ (tail
, halftail
) && len
!= 0)
206 halftail
= XCDR (halftail
);
209 XSETINT (length
, len
);
213 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
214 doc
: /* Return the number of bytes in STRING.
215 If STRING is a multibyte string, this is greater than the length of STRING. */)
219 CHECK_STRING (string
);
220 return make_number (SBYTES (string
));
223 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
224 doc
: /* Return t if two strings have identical contents.
225 Case is significant, but text properties are ignored.
226 Symbols are also allowed; their print names are used instead. */)
228 register Lisp_Object s1
, s2
;
231 s1
= SYMBOL_NAME (s1
);
233 s2
= SYMBOL_NAME (s2
);
237 if (SCHARS (s1
) != SCHARS (s2
)
238 || SBYTES (s1
) != SBYTES (s2
)
239 || bcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
244 DEFUN ("compare-strings", Fcompare_strings
,
245 Scompare_strings
, 6, 7, 0,
246 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
247 In string STR1, skip the first START1 characters and stop at END1.
248 In string STR2, skip the first START2 characters and stop at END2.
249 END1 and END2 default to the full lengths of the respective strings.
251 Case is significant in this comparison if IGNORE-CASE is nil.
252 Unibyte strings are converted to multibyte for comparison.
254 The value is t if the strings (or specified portions) match.
255 If string STR1 is less, the value is a negative number N;
256 - 1 - N is the number of characters that match at the beginning.
257 If string STR1 is greater, the value is a positive number N;
258 N - 1 is the number of characters that match at the beginning. */)
259 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
260 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
262 register int end1_char
, end2_char
;
263 register int i1
, i1_byte
, i2
, i2_byte
;
268 start1
= make_number (0);
270 start2
= make_number (0);
271 CHECK_NATNUM (start1
);
272 CHECK_NATNUM (start2
);
281 i1_byte
= string_char_to_byte (str1
, i1
);
282 i2_byte
= string_char_to_byte (str2
, i2
);
284 end1_char
= SCHARS (str1
);
285 if (! NILP (end1
) && end1_char
> XINT (end1
))
286 end1_char
= XINT (end1
);
288 end2_char
= SCHARS (str2
);
289 if (! NILP (end2
) && end2_char
> XINT (end2
))
290 end2_char
= XINT (end2
);
292 while (i1
< end1_char
&& i2
< end2_char
)
294 /* When we find a mismatch, we must compare the
295 characters, not just the bytes. */
298 if (STRING_MULTIBYTE (str1
))
299 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1
, str1
, i1
, i1_byte
);
302 c1
= SREF (str1
, i1
++);
303 c1
= unibyte_char_to_multibyte (c1
);
306 if (STRING_MULTIBYTE (str2
))
307 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2
, str2
, i2
, i2_byte
);
310 c2
= SREF (str2
, i2
++);
311 c2
= unibyte_char_to_multibyte (c2
);
317 if (! NILP (ignore_case
))
321 tem
= Fupcase (make_number (c1
));
323 tem
= Fupcase (make_number (c2
));
330 /* Note that I1 has already been incremented
331 past the character that we are comparing;
332 hence we don't add or subtract 1 here. */
334 return make_number (- i1
+ XINT (start1
));
336 return make_number (i1
- XINT (start1
));
340 return make_number (i1
- XINT (start1
) + 1);
342 return make_number (- i1
+ XINT (start1
) - 1);
347 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
348 doc
: /* Return t if first arg string is less than second in lexicographic order.
350 Symbols are also allowed; their print names are used instead. */)
352 register Lisp_Object s1
, s2
;
355 register int i1
, i1_byte
, i2
, i2_byte
;
358 s1
= SYMBOL_NAME (s1
);
360 s2
= SYMBOL_NAME (s2
);
364 i1
= i1_byte
= i2
= i2_byte
= 0;
367 if (end
> SCHARS (s2
))
372 /* When we find a mismatch, we must compare the
373 characters, not just the bytes. */
376 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
377 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
380 return c1
< c2
? Qt
: Qnil
;
382 return i1
< SCHARS (s2
) ? Qt
: Qnil
;
385 static Lisp_Object
concat ();
396 return concat (2, args
, Lisp_String
, 0);
398 return concat (2, &s1
, Lisp_String
, 0);
399 #endif /* NO_ARG_ARRAY */
405 Lisp_Object s1
, s2
, s3
;
412 return concat (3, args
, Lisp_String
, 0);
414 return concat (3, &s1
, Lisp_String
, 0);
415 #endif /* NO_ARG_ARRAY */
418 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
419 doc
: /* Concatenate all the arguments and make the result a list.
420 The result is a list whose elements are the elements of all the arguments.
421 Each argument may be a list, vector or string.
422 The last argument is not copied, just used as the tail of the new list.
423 usage: (append &rest SEQUENCES) */)
428 return concat (nargs
, args
, Lisp_Cons
, 1);
431 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
432 doc
: /* Concatenate all the arguments and make the result a string.
433 The result is a string whose elements are the elements of all the arguments.
434 Each argument may be a string or a list or vector of characters (integers).
435 usage: (concat &rest SEQUENCES) */)
440 return concat (nargs
, args
, Lisp_String
, 0);
443 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
444 doc
: /* Concatenate all the arguments and make the result a vector.
445 The result is a vector whose elements are the elements of all the arguments.
446 Each argument may be a list, vector or string.
447 usage: (vconcat &rest SEQUENCES) */)
452 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
455 /* Return a copy of a sub char table ARG. The elements except for a
456 nested sub char table are not copied. */
458 copy_sub_char_table (arg
)
461 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
464 /* Copy all the contents. */
465 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
466 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
467 /* Recursively copy any sub char-tables in the ordinary slots. */
468 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
469 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
470 XCHAR_TABLE (copy
)->contents
[i
]
471 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
477 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
478 doc
: /* Return a copy of a list, vector, string or char-table.
479 The elements of a list or vector are not copied; they are shared
480 with the original. */)
484 if (NILP (arg
)) return arg
;
486 if (CHAR_TABLE_P (arg
))
491 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
492 /* Copy all the slots, including the extra ones. */
493 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
494 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
495 * sizeof (Lisp_Object
)));
497 /* Recursively copy any sub char tables in the ordinary slots
498 for multibyte characters. */
499 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
500 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
501 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
502 XCHAR_TABLE (copy
)->contents
[i
]
503 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
508 if (BOOL_VECTOR_P (arg
))
512 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
514 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
515 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
520 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
521 arg
= wrong_type_argument (Qsequencep
, arg
);
522 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
525 /* In string STR of length LEN, see if bytes before STR[I] combine
526 with bytes after STR[I] to form a single character. If so, return
527 the number of bytes after STR[I] which combine in this way.
528 Otherwize, return 0. */
531 count_combining (str
, len
, i
)
535 int j
= i
- 1, bytes
;
537 if (i
== 0 || i
== len
|| CHAR_HEAD_P (str
[i
]))
539 while (j
>= 0 && !CHAR_HEAD_P (str
[j
])) j
--;
540 if (j
< 0 || ! BASE_LEADING_CODE_P (str
[j
]))
542 PARSE_MULTIBYTE_SEQ (str
+ j
, len
- j
, bytes
);
543 return (bytes
<= i
- j
? 0 : bytes
- (i
- j
));
546 /* This structure holds information of an argument of `concat' that is
547 a string and has text properties to be copied. */
550 int argnum
; /* refer to ARGS (arguments of `concat') */
551 int from
; /* refer to ARGS[argnum] (argument string) */
552 int to
; /* refer to VAL (the target string) */
556 concat (nargs
, args
, target_type
, last_special
)
559 enum Lisp_Type target_type
;
563 register Lisp_Object tail
;
564 register Lisp_Object
this;
566 int toindex_byte
= 0;
567 register int result_len
;
568 register int result_len_byte
;
570 Lisp_Object last_tail
;
573 /* When we make a multibyte string, we can't copy text properties
574 while concatinating each string because the length of resulting
575 string can't be decided until we finish the whole concatination.
576 So, we record strings that have text properties to be copied
577 here, and copy the text properties after the concatination. */
578 struct textprop_rec
*textprops
= NULL
;
579 /* Number of elments in textprops. */
580 int num_textprops
= 0;
584 /* In append, the last arg isn't treated like the others */
585 if (last_special
&& nargs
> 0)
588 last_tail
= args
[nargs
];
593 /* Canonicalize each argument. */
594 for (argnum
= 0; argnum
< nargs
; argnum
++)
597 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
598 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
600 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
604 /* Compute total length in chars of arguments in RESULT_LEN.
605 If desired output is a string, also compute length in bytes
606 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
607 whether the result should be a multibyte string. */
611 for (argnum
= 0; argnum
< nargs
; argnum
++)
615 len
= XFASTINT (Flength (this));
616 if (target_type
== Lisp_String
)
618 /* We must count the number of bytes needed in the string
619 as well as the number of characters. */
625 for (i
= 0; i
< len
; i
++)
627 ch
= XVECTOR (this)->contents
[i
];
629 wrong_type_argument (Qintegerp
, ch
);
630 this_len_byte
= CHAR_BYTES (XINT (ch
));
631 result_len_byte
+= this_len_byte
;
632 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
635 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
636 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
637 else if (CONSP (this))
638 for (; CONSP (this); this = XCDR (this))
642 wrong_type_argument (Qintegerp
, ch
);
643 this_len_byte
= CHAR_BYTES (XINT (ch
));
644 result_len_byte
+= this_len_byte
;
645 if (!SINGLE_BYTE_CHAR_P (XINT (ch
)))
648 else if (STRINGP (this))
650 if (STRING_MULTIBYTE (this))
653 result_len_byte
+= SBYTES (this);
656 result_len_byte
+= count_size_as_multibyte (SDATA (this),
664 if (! some_multibyte
)
665 result_len_byte
= result_len
;
667 /* Create the output object. */
668 if (target_type
== Lisp_Cons
)
669 val
= Fmake_list (make_number (result_len
), Qnil
);
670 else if (target_type
== Lisp_Vectorlike
)
671 val
= Fmake_vector (make_number (result_len
), Qnil
);
672 else if (some_multibyte
)
673 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
675 val
= make_uninit_string (result_len
);
677 /* In `append', if all but last arg are nil, return last arg. */
678 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
681 /* Copy the contents of the args into the result. */
683 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
685 toindex
= 0, toindex_byte
= 0;
690 = (struct textprop_rec
*) alloca (sizeof (struct textprop_rec
) * nargs
);
692 for (argnum
= 0; argnum
< nargs
; argnum
++)
696 register unsigned int thisindex
= 0;
697 register unsigned int thisindex_byte
= 0;
701 thislen
= Flength (this), thisleni
= XINT (thislen
);
703 /* Between strings of the same kind, copy fast. */
704 if (STRINGP (this) && STRINGP (val
)
705 && STRING_MULTIBYTE (this) == some_multibyte
)
707 int thislen_byte
= SBYTES (this);
710 bcopy (SDATA (this), SDATA (val
) + toindex_byte
,
712 combined
= (some_multibyte
&& toindex_byte
> 0
713 ? count_combining (SDATA (val
),
714 toindex_byte
+ thislen_byte
,
717 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
719 textprops
[num_textprops
].argnum
= argnum
;
720 /* We ignore text properties on characters being combined. */
721 textprops
[num_textprops
].from
= combined
;
722 textprops
[num_textprops
++].to
= toindex
;
724 toindex_byte
+= thislen_byte
;
725 toindex
+= thisleni
- combined
;
726 STRING_SET_CHARS (val
, SCHARS (val
) - combined
);
728 /* Copy a single-byte string to a multibyte string. */
729 else if (STRINGP (this) && STRINGP (val
))
731 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
733 textprops
[num_textprops
].argnum
= argnum
;
734 textprops
[num_textprops
].from
= 0;
735 textprops
[num_textprops
++].to
= toindex
;
737 toindex_byte
+= copy_text (SDATA (this),
738 SDATA (val
) + toindex_byte
,
739 SCHARS (this), 0, 1);
743 /* Copy element by element. */
746 register Lisp_Object elt
;
748 /* Fetch next element of `this' arg into `elt', or break if
749 `this' is exhausted. */
750 if (NILP (this)) break;
752 elt
= XCAR (this), this = XCDR (this);
753 else if (thisindex
>= thisleni
)
755 else if (STRINGP (this))
758 if (STRING_MULTIBYTE (this))
760 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
763 XSETFASTINT (elt
, c
);
767 XSETFASTINT (elt
, SREF (this, thisindex
++));
769 && (XINT (elt
) >= 0240
770 || (XINT (elt
) >= 0200
771 && ! NILP (Vnonascii_translation_table
)))
772 && XINT (elt
) < 0400)
774 c
= unibyte_char_to_multibyte (XINT (elt
));
779 else if (BOOL_VECTOR_P (this))
782 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
783 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
790 elt
= XVECTOR (this)->contents
[thisindex
++];
792 /* Store this element into the result. */
799 else if (VECTORP (val
))
800 XVECTOR (val
)->contents
[toindex
++] = elt
;
804 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
808 += CHAR_STRING (XINT (elt
),
809 SDATA (val
) + toindex_byte
);
811 SSET (val
, toindex_byte
++, XINT (elt
));
814 && count_combining (SDATA (val
),
815 toindex_byte
, toindex_byte
- 1))
816 STRING_SET_CHARS (val
, SCHARS (val
) - 1);
821 /* If we have any multibyte characters,
822 we already decided to make a multibyte string. */
825 /* P exists as a variable
826 to avoid a bug on the Masscomp C compiler. */
827 unsigned char *p
= SDATA (val
) + toindex_byte
;
829 toindex_byte
+= CHAR_STRING (c
, p
);
836 XSETCDR (prev
, last_tail
);
838 if (num_textprops
> 0)
841 int last_to_end
= -1;
843 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
845 this = args
[textprops
[argnum
].argnum
];
846 props
= text_property_list (this,
848 make_number (SCHARS (this)),
850 /* If successive arguments have properites, be sure that the
851 value of `composition' property be the copy. */
852 if (last_to_end
== textprops
[argnum
].to
)
853 make_composition_value_copy (props
);
854 add_text_properties_from_list (val
, props
,
855 make_number (textprops
[argnum
].to
));
856 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
862 static Lisp_Object string_char_byte_cache_string
;
863 static int string_char_byte_cache_charpos
;
864 static int string_char_byte_cache_bytepos
;
867 clear_string_char_byte_cache ()
869 string_char_byte_cache_string
= Qnil
;
872 /* Return the character index corresponding to CHAR_INDEX in STRING. */
875 string_char_to_byte (string
, char_index
)
880 int best_below
, best_below_byte
;
881 int best_above
, best_above_byte
;
883 if (! STRING_MULTIBYTE (string
))
886 best_below
= best_below_byte
= 0;
887 best_above
= SCHARS (string
);
888 best_above_byte
= SBYTES (string
);
890 if (EQ (string
, string_char_byte_cache_string
))
892 if (string_char_byte_cache_charpos
< char_index
)
894 best_below
= string_char_byte_cache_charpos
;
895 best_below_byte
= string_char_byte_cache_bytepos
;
899 best_above
= string_char_byte_cache_charpos
;
900 best_above_byte
= string_char_byte_cache_bytepos
;
904 if (char_index
- best_below
< best_above
- char_index
)
906 while (best_below
< char_index
)
909 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
910 best_below
, best_below_byte
);
913 i_byte
= best_below_byte
;
917 while (best_above
> char_index
)
919 unsigned char *pend
= SDATA (string
) + best_above_byte
;
920 unsigned char *pbeg
= pend
- best_above_byte
;
921 unsigned char *p
= pend
- 1;
924 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
925 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
926 if (bytes
== pend
- p
)
927 best_above_byte
-= bytes
;
928 else if (bytes
> pend
- p
)
929 best_above_byte
-= (pend
- p
);
935 i_byte
= best_above_byte
;
938 string_char_byte_cache_bytepos
= i_byte
;
939 string_char_byte_cache_charpos
= i
;
940 string_char_byte_cache_string
= string
;
945 /* Return the character index corresponding to BYTE_INDEX in STRING. */
948 string_byte_to_char (string
, byte_index
)
953 int best_below
, best_below_byte
;
954 int best_above
, best_above_byte
;
956 if (! STRING_MULTIBYTE (string
))
959 best_below
= best_below_byte
= 0;
960 best_above
= SCHARS (string
);
961 best_above_byte
= SBYTES (string
);
963 if (EQ (string
, string_char_byte_cache_string
))
965 if (string_char_byte_cache_bytepos
< byte_index
)
967 best_below
= string_char_byte_cache_charpos
;
968 best_below_byte
= string_char_byte_cache_bytepos
;
972 best_above
= string_char_byte_cache_charpos
;
973 best_above_byte
= string_char_byte_cache_bytepos
;
977 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
979 while (best_below_byte
< byte_index
)
982 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, string
,
983 best_below
, best_below_byte
);
986 i_byte
= best_below_byte
;
990 while (best_above_byte
> byte_index
)
992 unsigned char *pend
= SDATA (string
) + best_above_byte
;
993 unsigned char *pbeg
= pend
- best_above_byte
;
994 unsigned char *p
= pend
- 1;
997 while (p
> pbeg
&& !CHAR_HEAD_P (*p
)) p
--;
998 PARSE_MULTIBYTE_SEQ (p
, pend
- p
, bytes
);
999 if (bytes
== pend
- p
)
1000 best_above_byte
-= bytes
;
1001 else if (bytes
> pend
- p
)
1002 best_above_byte
-= (pend
- p
);
1008 i_byte
= best_above_byte
;
1011 string_char_byte_cache_bytepos
= i_byte
;
1012 string_char_byte_cache_charpos
= i
;
1013 string_char_byte_cache_string
= string
;
1018 /* Convert STRING to a multibyte string.
1019 Single-byte characters 0240 through 0377 are converted
1020 by adding nonascii_insert_offset to each. */
1023 string_make_multibyte (string
)
1029 if (STRING_MULTIBYTE (string
))
1032 nbytes
= count_size_as_multibyte (SDATA (string
),
1034 /* If all the chars are ASCII, they won't need any more bytes
1035 once converted. In that case, we can return STRING itself. */
1036 if (nbytes
== SBYTES (string
))
1039 buf
= (unsigned char *) alloca (nbytes
);
1040 copy_text (SDATA (string
), buf
, SBYTES (string
),
1043 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1047 /* Convert STRING to a multibyte string without changing each
1048 character codes. Thus, characters 0200 trough 0237 are converted
1049 to eight-bit-control characters, and characters 0240 through 0377
1050 are converted eight-bit-graphic characters. */
1053 string_to_multibyte (string
)
1059 if (STRING_MULTIBYTE (string
))
1062 nbytes
= parse_str_to_multibyte (SDATA (string
), SBYTES (string
));
1063 /* If all the chars are ASCII or eight-bit-graphic, they won't need
1064 any more bytes once converted. */
1065 if (nbytes
== SBYTES (string
))
1066 return make_multibyte_string (SDATA (string
), nbytes
, nbytes
);
1068 buf
= (unsigned char *) alloca (nbytes
);
1069 bcopy (SDATA (string
), buf
, SBYTES (string
));
1070 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1072 return make_multibyte_string (buf
, SCHARS (string
), nbytes
);
1076 /* Convert STRING to a single-byte string. */
1079 string_make_unibyte (string
)
1084 if (! STRING_MULTIBYTE (string
))
1087 buf
= (unsigned char *) alloca (SCHARS (string
));
1089 copy_text (SDATA (string
), buf
, SBYTES (string
),
1092 return make_unibyte_string (buf
, SCHARS (string
));
1095 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1097 doc
: /* Return the multibyte equivalent of STRING.
1098 The function `unibyte-char-to-multibyte' is used to convert
1099 each unibyte character to a multibyte character. */)
1103 CHECK_STRING (string
);
1105 return string_make_multibyte (string
);
1108 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1110 doc
: /* Return the unibyte equivalent of STRING.
1111 Multibyte character codes are converted to unibyte according to
1112 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1113 If the lookup in the translation table fails, this function takes just
1114 the low 8 bits of each character. */)
1118 CHECK_STRING (string
);
1120 return string_make_unibyte (string
);
1123 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1125 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1126 If STRING is unibyte, the result is STRING itself.
1127 Otherwise it is a newly created string, with no text properties.
1128 If STRING is multibyte and contains a character of charset
1129 `eight-bit-control' or `eight-bit-graphic', it is converted to the
1130 corresponding single byte. */)
1134 CHECK_STRING (string
);
1136 if (STRING_MULTIBYTE (string
))
1138 int bytes
= SBYTES (string
);
1139 unsigned char *str
= (unsigned char *) xmalloc (bytes
);
1141 bcopy (SDATA (string
), str
, bytes
);
1142 bytes
= str_as_unibyte (str
, bytes
);
1143 string
= make_unibyte_string (str
, bytes
);
1149 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1151 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1152 If STRING is multibyte, the result is STRING itself.
1153 Otherwise it is a newly created string, with no text properties.
1154 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1155 part of a multibyte form), it is converted to the corresponding
1156 multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
1160 CHECK_STRING (string
);
1162 if (! STRING_MULTIBYTE (string
))
1164 Lisp_Object new_string
;
1167 parse_str_as_multibyte (SDATA (string
),
1170 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1171 bcopy (SDATA (string
), SDATA (new_string
),
1173 if (nbytes
!= SBYTES (string
))
1174 str_as_multibyte (SDATA (new_string
), nbytes
,
1175 SBYTES (string
), NULL
);
1176 string
= new_string
;
1177 STRING_SET_INTERVALS (string
, NULL_INTERVAL
);
1182 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1184 doc
: /* Return a multibyte string with the same individual chars as STRING.
1185 If STRING is multibyte, the result is STRING itself.
1186 Otherwise it is a newly created string, with no text properties.
1187 Characters 0200 through 0237 are converted to eight-bit-control
1188 characters of the same character code. Characters 0240 through 0377
1189 are converted to eight-bit-control characters of the same character
1194 CHECK_STRING (string
);
1196 return string_to_multibyte (string
);
1200 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1201 doc
: /* Return a copy of ALIST.
1202 This is an alist which represents the same mapping from objects to objects,
1203 but does not share the alist structure with ALIST.
1204 The objects mapped (cars and cdrs of elements of the alist)
1205 are shared, however.
1206 Elements of ALIST that are not conses are also shared. */)
1210 register Lisp_Object tem
;
1215 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1216 for (tem
= alist
; CONSP (tem
); tem
= XCDR (tem
))
1218 register Lisp_Object car
;
1222 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1227 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1228 doc
: /* Return a substring of STRING, starting at index FROM and ending before TO.
1229 TO may be nil or omitted; then the substring runs to the end of STRING.
1230 FROM and TO start at 0. If either is negative, it counts from the end.
1232 This function allows vectors as well as strings. */)
1235 register Lisp_Object from
, to
;
1240 int from_char
, to_char
;
1241 int from_byte
= 0, to_byte
= 0;
1243 if (! (STRINGP (string
) || VECTORP (string
)))
1244 wrong_type_argument (Qarrayp
, string
);
1246 CHECK_NUMBER (from
);
1248 if (STRINGP (string
))
1250 size
= SCHARS (string
);
1251 size_byte
= SBYTES (string
);
1254 size
= XVECTOR (string
)->size
;
1259 to_byte
= size_byte
;
1265 to_char
= XINT (to
);
1269 if (STRINGP (string
))
1270 to_byte
= string_char_to_byte (string
, to_char
);
1273 from_char
= XINT (from
);
1276 if (STRINGP (string
))
1277 from_byte
= string_char_to_byte (string
, from_char
);
1279 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1280 args_out_of_range_3 (string
, make_number (from_char
),
1281 make_number (to_char
));
1283 if (STRINGP (string
))
1285 res
= make_specified_string (SDATA (string
) + from_byte
,
1286 to_char
- from_char
, to_byte
- from_byte
,
1287 STRING_MULTIBYTE (string
));
1288 copy_text_properties (make_number (from_char
), make_number (to_char
),
1289 string
, make_number (0), res
, Qnil
);
1292 res
= Fvector (to_char
- from_char
,
1293 XVECTOR (string
)->contents
+ from_char
);
1299 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1300 doc
: /* Return a substring of STRING, without text properties.
1301 It starts at index FROM and ending before TO.
1302 TO may be nil or omitted; then the substring runs to the end of STRING.
1303 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1304 If FROM or TO is negative, it counts from the end.
1306 With one argument, just copy STRING without its properties. */)
1309 register Lisp_Object from
, to
;
1311 int size
, size_byte
;
1312 int from_char
, to_char
;
1313 int from_byte
, to_byte
;
1315 CHECK_STRING (string
);
1317 size
= SCHARS (string
);
1318 size_byte
= SBYTES (string
);
1321 from_char
= from_byte
= 0;
1324 CHECK_NUMBER (from
);
1325 from_char
= XINT (from
);
1329 from_byte
= string_char_to_byte (string
, from_char
);
1335 to_byte
= size_byte
;
1341 to_char
= XINT (to
);
1345 to_byte
= string_char_to_byte (string
, to_char
);
1348 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1349 args_out_of_range_3 (string
, make_number (from_char
),
1350 make_number (to_char
));
1352 return make_specified_string (SDATA (string
) + from_byte
,
1353 to_char
- from_char
, to_byte
- from_byte
,
1354 STRING_MULTIBYTE (string
));
1357 /* Extract a substring of STRING, giving start and end positions
1358 both in characters and in bytes. */
1361 substring_both (string
, from
, from_byte
, to
, to_byte
)
1363 int from
, from_byte
, to
, to_byte
;
1369 if (! (STRINGP (string
) || VECTORP (string
)))
1370 wrong_type_argument (Qarrayp
, string
);
1372 if (STRINGP (string
))
1374 size
= SCHARS (string
);
1375 size_byte
= SBYTES (string
);
1378 size
= XVECTOR (string
)->size
;
1380 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1381 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1383 if (STRINGP (string
))
1385 res
= make_specified_string (SDATA (string
) + from_byte
,
1386 to
- from
, to_byte
- from_byte
,
1387 STRING_MULTIBYTE (string
));
1388 copy_text_properties (make_number (from
), make_number (to
),
1389 string
, make_number (0), res
, Qnil
);
1392 res
= Fvector (to
- from
,
1393 XVECTOR (string
)->contents
+ from
);
1398 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1399 doc
: /* Take cdr N times on LIST, returns the result. */)
1402 register Lisp_Object list
;
1404 register int i
, num
;
1407 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1411 wrong_type_argument (Qlistp
, list
);
1417 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1418 doc
: /* Return the Nth element of LIST.
1419 N counts from zero. If LIST is not that long, nil is returned. */)
1421 Lisp_Object n
, list
;
1423 return Fcar (Fnthcdr (n
, list
));
1426 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1427 doc
: /* Return element of SEQUENCE at index N. */)
1429 register Lisp_Object sequence
, n
;
1434 if (CONSP (sequence
) || NILP (sequence
))
1435 return Fcar (Fnthcdr (n
, sequence
));
1436 else if (STRINGP (sequence
) || VECTORP (sequence
)
1437 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1438 return Faref (sequence
, n
);
1440 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1444 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1445 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1446 The value is actually the tail of LIST whose car is ELT. */)
1448 register Lisp_Object elt
;
1451 register Lisp_Object tail
;
1452 for (tail
= list
; !NILP (tail
); tail
= XCDR (tail
))
1454 register Lisp_Object tem
;
1456 wrong_type_argument (Qlistp
, list
);
1458 if (! NILP (Fequal (elt
, tem
)))
1465 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1466 doc
: /* Return non-nil if ELT is an element of LIST.
1467 Comparison done with EQ. The value is actually the tail of LIST
1468 whose car is ELT. */)
1470 Lisp_Object elt
, list
;
1474 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1478 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1482 if (!CONSP (list
) || EQ (XCAR (list
), elt
))
1489 if (!CONSP (list
) && !NILP (list
))
1490 list
= wrong_type_argument (Qlistp
, list
);
1495 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1496 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1497 The value is actually the element of LIST whose car is KEY.
1498 Elements of LIST that are not conses are ignored. */)
1500 Lisp_Object key
, list
;
1507 || (CONSP (XCAR (list
))
1508 && EQ (XCAR (XCAR (list
)), key
)))
1513 || (CONSP (XCAR (list
))
1514 && EQ (XCAR (XCAR (list
)), key
)))
1519 || (CONSP (XCAR (list
))
1520 && EQ (XCAR (XCAR (list
)), key
)))
1528 result
= XCAR (list
);
1529 else if (NILP (list
))
1532 result
= wrong_type_argument (Qlistp
, list
);
1537 /* Like Fassq but never report an error and do not allow quits.
1538 Use only on lists known never to be circular. */
1541 assq_no_quit (key
, list
)
1542 Lisp_Object key
, list
;
1545 && (!CONSP (XCAR (list
))
1546 || !EQ (XCAR (XCAR (list
)), key
)))
1549 return CONSP (list
) ? XCAR (list
) : Qnil
;
1552 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1553 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1554 The value is actually the element of LIST whose car equals KEY. */)
1556 Lisp_Object key
, list
;
1558 Lisp_Object result
, car
;
1563 || (CONSP (XCAR (list
))
1564 && (car
= XCAR (XCAR (list
)),
1565 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1570 || (CONSP (XCAR (list
))
1571 && (car
= XCAR (XCAR (list
)),
1572 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1577 || (CONSP (XCAR (list
))
1578 && (car
= XCAR (XCAR (list
)),
1579 EQ (car
, key
) || !NILP (Fequal (car
, key
)))))
1587 result
= XCAR (list
);
1588 else if (NILP (list
))
1591 result
= wrong_type_argument (Qlistp
, list
);
1596 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1597 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1598 The value is actually the element of LIST whose cdr is KEY. */)
1600 register Lisp_Object key
;
1608 || (CONSP (XCAR (list
))
1609 && EQ (XCDR (XCAR (list
)), key
)))
1614 || (CONSP (XCAR (list
))
1615 && EQ (XCDR (XCAR (list
)), key
)))
1620 || (CONSP (XCAR (list
))
1621 && EQ (XCDR (XCAR (list
)), key
)))
1630 else if (CONSP (list
))
1631 result
= XCAR (list
);
1633 result
= wrong_type_argument (Qlistp
, list
);
1638 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1639 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1640 The value is actually the element of LIST whose cdr equals KEY. */)
1642 Lisp_Object key
, list
;
1644 Lisp_Object result
, cdr
;
1649 || (CONSP (XCAR (list
))
1650 && (cdr
= XCDR (XCAR (list
)),
1651 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1656 || (CONSP (XCAR (list
))
1657 && (cdr
= XCDR (XCAR (list
)),
1658 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1663 || (CONSP (XCAR (list
))
1664 && (cdr
= XCDR (XCAR (list
)),
1665 EQ (cdr
, key
) || !NILP (Fequal (cdr
, key
)))))
1673 result
= XCAR (list
);
1674 else if (NILP (list
))
1677 result
= wrong_type_argument (Qlistp
, list
);
1682 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1683 doc
: /* Delete by side effect any occurrences of ELT as a member of LIST.
1684 The modified LIST is returned. Comparison is done with `eq'.
1685 If the first member of LIST is ELT, there is no way to remove it by side effect;
1686 therefore, write `(setq foo (delq element foo))'
1687 to be sure of changing the value of `foo'. */)
1689 register Lisp_Object elt
;
1692 register Lisp_Object tail
, prev
;
1693 register Lisp_Object tem
;
1697 while (!NILP (tail
))
1700 wrong_type_argument (Qlistp
, list
);
1707 Fsetcdr (prev
, XCDR (tail
));
1717 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1718 doc
: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1719 SEQ must be a list, a vector, or a string.
1720 The modified SEQ is returned. Comparison is done with `equal'.
1721 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1722 is not a side effect; it is simply using a different sequence.
1723 Therefore, write `(setq foo (delete element foo))'
1724 to be sure of changing the value of `foo'. */)
1726 Lisp_Object elt
, seq
;
1732 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1733 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1736 if (n
!= ASIZE (seq
))
1738 struct Lisp_Vector
*p
= allocate_vector (n
);
1740 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1741 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1742 p
->contents
[n
++] = AREF (seq
, i
);
1744 XSETVECTOR (seq
, p
);
1747 else if (STRINGP (seq
))
1749 EMACS_INT i
, ibyte
, nchars
, nbytes
, cbytes
;
1752 for (i
= nchars
= nbytes
= ibyte
= 0;
1754 ++i
, ibyte
+= cbytes
)
1756 if (STRING_MULTIBYTE (seq
))
1758 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1759 SBYTES (seq
) - ibyte
);
1760 cbytes
= CHAR_BYTES (c
);
1768 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1775 if (nchars
!= SCHARS (seq
))
1779 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1780 if (!STRING_MULTIBYTE (seq
))
1781 STRING_SET_UNIBYTE (tem
);
1783 for (i
= nchars
= nbytes
= ibyte
= 0;
1785 ++i
, ibyte
+= cbytes
)
1787 if (STRING_MULTIBYTE (seq
))
1789 c
= STRING_CHAR (SDATA (seq
) + ibyte
,
1790 SBYTES (seq
) - ibyte
);
1791 cbytes
= CHAR_BYTES (c
);
1799 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1801 unsigned char *from
= SDATA (seq
) + ibyte
;
1802 unsigned char *to
= SDATA (tem
) + nbytes
;
1808 for (n
= cbytes
; n
--; )
1818 Lisp_Object tail
, prev
;
1820 for (tail
= seq
, prev
= Qnil
; !NILP (tail
); tail
= XCDR (tail
))
1823 wrong_type_argument (Qlistp
, seq
);
1825 if (!NILP (Fequal (elt
, XCAR (tail
))))
1830 Fsetcdr (prev
, XCDR (tail
));
1841 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1842 doc
: /* Reverse LIST by modifying cdr pointers.
1843 Returns the beginning of the reversed list. */)
1847 register Lisp_Object prev
, tail
, next
;
1849 if (NILP (list
)) return list
;
1852 while (!NILP (tail
))
1856 wrong_type_argument (Qlistp
, list
);
1858 Fsetcdr (tail
, prev
);
1865 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1866 doc
: /* Reverse LIST, copying. Returns the beginning of the reversed list.
1867 See also the function `nreverse', which is used more often. */)
1873 for (new = Qnil
; CONSP (list
); list
= XCDR (list
))
1876 new = Fcons (XCAR (list
), new);
1879 wrong_type_argument (Qconsp
, list
);
1883 Lisp_Object
merge ();
1885 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1886 doc
: /* Sort LIST, stably, comparing elements using PREDICATE.
1887 Returns the sorted list. LIST is modified by side effects.
1888 PREDICATE is called with two elements of LIST, and should return t
1889 if the first element is "less" than the second. */)
1891 Lisp_Object list
, predicate
;
1893 Lisp_Object front
, back
;
1894 register Lisp_Object len
, tem
;
1895 struct gcpro gcpro1
, gcpro2
;
1896 register int length
;
1899 len
= Flength (list
);
1900 length
= XINT (len
);
1904 XSETINT (len
, (length
/ 2) - 1);
1905 tem
= Fnthcdr (len
, list
);
1907 Fsetcdr (tem
, Qnil
);
1909 GCPRO2 (front
, back
);
1910 front
= Fsort (front
, predicate
);
1911 back
= Fsort (back
, predicate
);
1913 return merge (front
, back
, predicate
);
1917 merge (org_l1
, org_l2
, pred
)
1918 Lisp_Object org_l1
, org_l2
;
1922 register Lisp_Object tail
;
1924 register Lisp_Object l1
, l2
;
1925 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1932 /* It is sufficient to protect org_l1 and org_l2.
1933 When l1 and l2 are updated, we copy the new values
1934 back into the org_ vars. */
1935 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1955 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1971 Fsetcdr (tail
, tem
);
1977 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1978 doc
: /* Extract a value from a property list.
1979 PLIST is a property list, which is a list of the form
1980 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1981 corresponding to the given PROP, or nil if PROP is not
1982 one of the properties on the list. */)
1990 CONSP (tail
) && CONSP (XCDR (tail
));
1991 tail
= XCDR (XCDR (tail
)))
1993 if (EQ (prop
, XCAR (tail
)))
1994 return XCAR (XCDR (tail
));
1996 /* This function can be called asynchronously
1997 (setup_coding_system). Don't QUIT in that case. */
1998 if (!interrupt_input_blocked
)
2003 wrong_type_argument (Qlistp
, prop
);
2008 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2009 doc
: /* Return the value of SYMBOL's PROPNAME property.
2010 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2012 Lisp_Object symbol
, propname
;
2014 CHECK_SYMBOL (symbol
);
2015 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2018 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2019 doc
: /* Change value in PLIST of PROP to VAL.
2020 PLIST is a property list, which is a list of the form
2021 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2022 If PROP is already a property on the list, its value is set to VAL,
2023 otherwise the new PROP VAL pair is added. The new plist is returned;
2024 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2025 The PLIST is modified by side effects. */)
2028 register Lisp_Object prop
;
2031 register Lisp_Object tail
, prev
;
2032 Lisp_Object newcell
;
2034 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2035 tail
= XCDR (XCDR (tail
)))
2037 if (EQ (prop
, XCAR (tail
)))
2039 Fsetcar (XCDR (tail
), val
);
2046 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2050 Fsetcdr (XCDR (prev
), newcell
);
2054 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2055 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2056 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2057 (symbol
, propname
, value
)
2058 Lisp_Object symbol
, propname
, value
;
2060 CHECK_SYMBOL (symbol
);
2061 XSYMBOL (symbol
)->plist
2062 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
2066 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2067 doc
: /* Extract a value from a property list, comparing with `equal'.
2068 PLIST is a property list, which is a list of the form
2069 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2070 corresponding to the given PROP, or nil if PROP is not
2071 one of the properties on the list. */)
2079 CONSP (tail
) && CONSP (XCDR (tail
));
2080 tail
= XCDR (XCDR (tail
)))
2082 if (! NILP (Fequal (prop
, XCAR (tail
))))
2083 return XCAR (XCDR (tail
));
2089 wrong_type_argument (Qlistp
, prop
);
2094 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2095 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2096 PLIST is a property list, which is a list of the form
2097 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2098 If PROP is already a property on the list, its value is set to VAL,
2099 otherwise the new PROP VAL pair is added. The new plist is returned;
2100 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2101 The PLIST is modified by side effects. */)
2104 register Lisp_Object prop
;
2107 register Lisp_Object tail
, prev
;
2108 Lisp_Object newcell
;
2110 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2111 tail
= XCDR (XCDR (tail
)))
2113 if (! NILP (Fequal (prop
, XCAR (tail
))))
2115 Fsetcar (XCDR (tail
), val
);
2122 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
2126 Fsetcdr (XCDR (prev
), newcell
);
2130 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2131 doc
: /* Return t if two Lisp objects have similar structure and contents.
2132 They must have the same data type.
2133 Conses are compared by comparing the cars and the cdrs.
2134 Vectors and strings are compared element by element.
2135 Numbers are compared by value, but integers cannot equal floats.
2136 (Use `=' if you want integers and floats to be able to be equal.)
2137 Symbols must match exactly. */)
2139 register Lisp_Object o1
, o2
;
2141 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
2145 internal_equal (o1
, o2
, depth
)
2146 register Lisp_Object o1
, o2
;
2150 error ("Stack overflow in equal");
2156 if (XTYPE (o1
) != XTYPE (o2
))
2162 return (extract_float (o1
) == extract_float (o2
));
2165 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1))
2172 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2176 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2178 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2181 o1
= XOVERLAY (o1
)->plist
;
2182 o2
= XOVERLAY (o2
)->plist
;
2187 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2188 && (XMARKER (o1
)->buffer
== 0
2189 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2193 case Lisp_Vectorlike
:
2195 register int i
, size
;
2196 size
= XVECTOR (o1
)->size
;
2197 /* Pseudovectors have the type encoded in the size field, so this test
2198 actually checks that the objects have the same type as well as the
2200 if (XVECTOR (o2
)->size
!= size
)
2202 /* Boolvectors are compared much like strings. */
2203 if (BOOL_VECTOR_P (o1
))
2206 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2208 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
2210 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
2215 if (WINDOW_CONFIGURATIONP (o1
))
2216 return compare_window_configurations (o1
, o2
, 0);
2218 /* Aside from them, only true vectors, char-tables, and compiled
2219 functions are sensible to compare, so eliminate the others now. */
2220 if (size
& PSEUDOVECTOR_FLAG
)
2222 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
2224 size
&= PSEUDOVECTOR_SIZE_MASK
;
2226 for (i
= 0; i
< size
; i
++)
2229 v1
= XVECTOR (o1
)->contents
[i
];
2230 v2
= XVECTOR (o2
)->contents
[i
];
2231 if (!internal_equal (v1
, v2
, depth
+ 1))
2239 if (SCHARS (o1
) != SCHARS (o2
))
2241 if (SBYTES (o1
) != SBYTES (o2
))
2243 if (bcmp (SDATA (o1
), SDATA (o2
),
2250 case Lisp_Type_Limit
:
2257 extern Lisp_Object
Fmake_char_internal ();
2259 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2260 doc
: /* Store each element of ARRAY with ITEM.
2261 ARRAY is a vector, string, char-table, or bool-vector. */)
2263 Lisp_Object array
, item
;
2265 register int size
, index
, charval
;
2267 if (VECTORP (array
))
2269 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
2270 size
= XVECTOR (array
)->size
;
2271 for (index
= 0; index
< size
; index
++)
2274 else if (CHAR_TABLE_P (array
))
2276 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
2277 size
= CHAR_TABLE_ORDINARY_SLOTS
;
2278 for (index
= 0; index
< size
; index
++)
2280 XCHAR_TABLE (array
)->defalt
= Qnil
;
2282 else if (STRINGP (array
))
2284 register unsigned char *p
= SDATA (array
);
2285 CHECK_NUMBER (item
);
2286 charval
= XINT (item
);
2287 size
= SCHARS (array
);
2288 if (STRING_MULTIBYTE (array
))
2290 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2291 int len
= CHAR_STRING (charval
, str
);
2292 int size_byte
= SBYTES (array
);
2293 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
2296 if (size
!= size_byte
)
2299 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
2300 if (len
!= this_len
)
2301 error ("Attempt to change byte length of a string");
2304 for (i
= 0; i
< size_byte
; i
++)
2305 *p
++ = str
[i
% len
];
2308 for (index
= 0; index
< size
; index
++)
2311 else if (BOOL_VECTOR_P (array
))
2313 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
2315 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
2317 charval
= (! NILP (item
) ? -1 : 0);
2318 for (index
= 0; index
< size_in_chars
; index
++)
2323 array
= wrong_type_argument (Qarrayp
, array
);
2329 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
2331 doc
: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
2333 Lisp_Object char_table
;
2335 CHECK_CHAR_TABLE (char_table
);
2337 return XCHAR_TABLE (char_table
)->purpose
;
2340 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
2342 doc
: /* Return the parent char-table of CHAR-TABLE.
2343 The value is either nil or another char-table.
2344 If CHAR-TABLE holds nil for a given character,
2345 then the actual applicable value is inherited from the parent char-table
2346 \(or from its parents, if necessary). */)
2348 Lisp_Object char_table
;
2350 CHECK_CHAR_TABLE (char_table
);
2352 return XCHAR_TABLE (char_table
)->parent
;
2355 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
2357 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
2358 PARENT must be either nil or another char-table. */)
2359 (char_table
, parent
)
2360 Lisp_Object char_table
, parent
;
2364 CHECK_CHAR_TABLE (char_table
);
2368 CHECK_CHAR_TABLE (parent
);
2370 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
2371 if (EQ (temp
, char_table
))
2372 error ("Attempt to make a chartable be its own parent");
2375 XCHAR_TABLE (char_table
)->parent
= parent
;
2380 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
2382 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
2384 Lisp_Object char_table
, n
;
2386 CHECK_CHAR_TABLE (char_table
);
2389 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2390 args_out_of_range (char_table
, n
);
2392 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
2395 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
2396 Sset_char_table_extra_slot
,
2398 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
2399 (char_table
, n
, value
)
2400 Lisp_Object char_table
, n
, value
;
2402 CHECK_CHAR_TABLE (char_table
);
2405 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
2406 args_out_of_range (char_table
, n
);
2408 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
2411 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
2413 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
2414 RANGE should be nil (for the default value)
2415 a vector which identifies a character set or a row of a character set,
2416 a character set name, or a character code. */)
2418 Lisp_Object char_table
, range
;
2420 CHECK_CHAR_TABLE (char_table
);
2422 if (EQ (range
, Qnil
))
2423 return XCHAR_TABLE (char_table
)->defalt
;
2424 else if (INTEGERP (range
))
2425 return Faref (char_table
, range
);
2426 else if (SYMBOLP (range
))
2428 Lisp_Object charset_info
;
2430 charset_info
= Fget (range
, Qcharset
);
2431 CHECK_VECTOR (charset_info
);
2433 return Faref (char_table
,
2434 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2437 else if (VECTORP (range
))
2439 if (XVECTOR (range
)->size
== 1)
2440 return Faref (char_table
,
2441 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
2444 int size
= XVECTOR (range
)->size
;
2445 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2446 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2447 size
<= 1 ? Qnil
: val
[1],
2448 size
<= 2 ? Qnil
: val
[2]);
2449 return Faref (char_table
, ch
);
2453 error ("Invalid RANGE argument to `char-table-range'");
2457 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
2459 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
2460 RANGE should be t (for all characters), nil (for the default value)
2461 a vector which identifies a character set or a row of a character set,
2462 a coding system, or a character code. */)
2463 (char_table
, range
, value
)
2464 Lisp_Object char_table
, range
, value
;
2468 CHECK_CHAR_TABLE (char_table
);
2471 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2472 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
2473 else if (EQ (range
, Qnil
))
2474 XCHAR_TABLE (char_table
)->defalt
= value
;
2475 else if (SYMBOLP (range
))
2477 Lisp_Object charset_info
;
2479 charset_info
= Fget (range
, Qcharset
);
2480 CHECK_VECTOR (charset_info
);
2482 return Faset (char_table
,
2483 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
2487 else if (INTEGERP (range
))
2488 Faset (char_table
, range
, value
);
2489 else if (VECTORP (range
))
2491 if (XVECTOR (range
)->size
== 1)
2492 return Faset (char_table
,
2493 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2497 int size
= XVECTOR (range
)->size
;
2498 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2499 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2500 size
<= 1 ? Qnil
: val
[1],
2501 size
<= 2 ? Qnil
: val
[2]);
2502 return Faset (char_table
, ch
, value
);
2506 error ("Invalid RANGE argument to `set-char-table-range'");
2511 DEFUN ("set-char-table-default", Fset_char_table_default
,
2512 Sset_char_table_default
, 3, 3, 0,
2513 doc
: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
2514 The generic character specifies the group of characters.
2515 See also the documentation of make-char. */)
2516 (char_table
, ch
, value
)
2517 Lisp_Object char_table
, ch
, value
;
2519 int c
, charset
, code1
, code2
;
2522 CHECK_CHAR_TABLE (char_table
);
2526 SPLIT_CHAR (c
, charset
, code1
, code2
);
2528 /* Since we may want to set the default value for a character set
2529 not yet defined, we check only if the character set is in the
2530 valid range or not, instead of it is already defined or not. */
2531 if (! CHARSET_VALID_P (charset
))
2532 invalid_character (c
);
2534 if (charset
== CHARSET_ASCII
)
2535 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2537 /* Even if C is not a generic char, we had better behave as if a
2538 generic char is specified. */
2539 if (!CHARSET_DEFINED_P (charset
) || CHARSET_DIMENSION (charset
) == 1)
2541 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2544 if (SUB_CHAR_TABLE_P (temp
))
2545 XCHAR_TABLE (temp
)->defalt
= value
;
2547 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2550 if (SUB_CHAR_TABLE_P (temp
))
2553 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2554 = make_sub_char_table (temp
));
2555 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2556 if (SUB_CHAR_TABLE_P (temp
))
2557 XCHAR_TABLE (temp
)->defalt
= value
;
2559 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2563 /* Look up the element in TABLE at index CH,
2564 and return it as an integer.
2565 If the element is nil, return CH itself.
2566 (Actually we do that for any non-integer.) */
2569 char_table_translate (table
, ch
)
2574 value
= Faref (table
, make_number (ch
));
2575 if (! INTEGERP (value
))
2577 return XINT (value
);
2581 optimize_sub_char_table (table
, chars
)
2589 from
= 33, to
= 127;
2591 from
= 32, to
= 128;
2593 if (!SUB_CHAR_TABLE_P (*table
))
2595 elt
= XCHAR_TABLE (*table
)->contents
[from
++];
2596 for (; from
< to
; from
++)
2597 if (NILP (Fequal (elt
, XCHAR_TABLE (*table
)->contents
[from
])))
2602 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
2603 1, 1, 0, doc
: /* Optimize char table TABLE. */)
2611 CHECK_CHAR_TABLE (table
);
2613 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
2615 elt
= XCHAR_TABLE (table
)->contents
[i
];
2616 if (!SUB_CHAR_TABLE_P (elt
))
2618 dim
= CHARSET_DIMENSION (i
- 128);
2620 for (j
= 32; j
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; j
++)
2621 optimize_sub_char_table (XCHAR_TABLE (elt
)->contents
+ j
, dim
);
2622 optimize_sub_char_table (XCHAR_TABLE (table
)->contents
+ i
, dim
);
2628 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2629 character or group of characters that share a value.
2630 DEPTH is the current depth in the originally specified
2631 chartable, and INDICES contains the vector indices
2632 for the levels our callers have descended.
2634 ARG is passed to C_FUNCTION when that is called. */
2637 map_char_table (c_function
, function
, table
, subtable
, arg
, depth
, indices
)
2638 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2639 Lisp_Object function
, table
, subtable
, arg
, *indices
;
2646 /* At first, handle ASCII and 8-bit European characters. */
2647 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2649 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2651 elt
= XCHAR_TABLE (subtable
)->defalt
;
2653 elt
= Faref (subtable
, make_number (i
));
2655 (*c_function
) (arg
, make_number (i
), elt
);
2657 call2 (function
, make_number (i
), elt
);
2659 #if 0 /* If the char table has entries for higher characters,
2660 we should report them. */
2661 if (NILP (current_buffer
->enable_multibyte_characters
))
2664 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2668 int charset
= XFASTINT (indices
[0]) - 128;
2671 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2672 if (CHARSET_CHARS (charset
) == 94)
2681 elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2682 XSETFASTINT (indices
[depth
], i
);
2683 charset
= XFASTINT (indices
[0]) - 128;
2685 && (!CHARSET_DEFINED_P (charset
)
2686 || charset
== CHARSET_8_BIT_CONTROL
2687 || charset
== CHARSET_8_BIT_GRAPHIC
))
2690 if (SUB_CHAR_TABLE_P (elt
))
2693 error ("Too deep char table");
2694 map_char_table (c_function
, function
, table
, elt
, arg
, depth
+ 1, indices
);
2700 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2701 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2702 c
= MAKE_CHAR (charset
, c1
, c2
);
2705 elt
= XCHAR_TABLE (subtable
)->defalt
;
2707 elt
= Faref (table
, make_number (c
));
2710 (*c_function
) (arg
, make_number (c
), elt
);
2712 call2 (function
, make_number (c
), elt
);
2717 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2719 void_call2 (a
, b
, c
)
2720 Lisp_Object a
, b
, c
;
2725 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2727 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2728 FUNCTION is called with two arguments--a key and a value.
2729 The key is always a possible IDX argument to `aref'. */)
2730 (function
, char_table
)
2731 Lisp_Object function
, char_table
;
2733 /* The depth of char table is at most 3. */
2734 Lisp_Object indices
[3];
2736 CHECK_CHAR_TABLE (char_table
);
2738 /* When Lisp_Object is represented as a union, `call2' cannot directly
2739 be passed to map_char_table because it returns a Lisp_Object rather
2740 than returning nothing.
2741 Casting leads to crashes on some architectures. -stef */
2742 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2746 /* Return a value for character C in char-table TABLE. Store the
2747 actual index for that value in *IDX. Ignore the default value of
2751 char_table_ref_and_index (table
, c
, idx
)
2755 int charset
, c1
, c2
;
2758 if (SINGLE_BYTE_CHAR_P (c
))
2761 return XCHAR_TABLE (table
)->contents
[c
];
2763 SPLIT_CHAR (c
, charset
, c1
, c2
);
2764 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2765 *idx
= MAKE_CHAR (charset
, 0, 0);
2766 if (!SUB_CHAR_TABLE_P (elt
))
2768 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2769 return XCHAR_TABLE (elt
)->defalt
;
2770 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2771 *idx
= MAKE_CHAR (charset
, c1
, 0);
2772 if (!SUB_CHAR_TABLE_P (elt
))
2774 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2775 return XCHAR_TABLE (elt
)->defalt
;
2777 return XCHAR_TABLE (elt
)->contents
[c2
];
2787 Lisp_Object args
[2];
2790 return Fnconc (2, args
);
2792 return Fnconc (2, &s1
);
2793 #endif /* NO_ARG_ARRAY */
2796 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2797 doc
: /* Concatenate any number of lists by altering them.
2798 Only the last argument is not altered, and need not be a list.
2799 usage: (nconc &rest LISTS) */)
2804 register int argnum
;
2805 register Lisp_Object tail
, tem
, val
;
2809 for (argnum
= 0; argnum
< nargs
; argnum
++)
2812 if (NILP (tem
)) continue;
2817 if (argnum
+ 1 == nargs
) break;
2820 tem
= wrong_type_argument (Qlistp
, tem
);
2829 tem
= args
[argnum
+ 1];
2830 Fsetcdr (tail
, tem
);
2832 args
[argnum
+ 1] = tail
;
2838 /* This is the guts of all mapping functions.
2839 Apply FN to each element of SEQ, one by one,
2840 storing the results into elements of VALS, a C vector of Lisp_Objects.
2841 LENI is the length of VALS, which should also be the length of SEQ. */
2844 mapcar1 (leni
, vals
, fn
, seq
)
2847 Lisp_Object fn
, seq
;
2849 register Lisp_Object tail
;
2852 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2856 /* Don't let vals contain any garbage when GC happens. */
2857 for (i
= 0; i
< leni
; i
++)
2860 GCPRO3 (dummy
, fn
, seq
);
2862 gcpro1
.nvars
= leni
;
2866 /* We need not explicitly protect `tail' because it is used only on lists, and
2867 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2871 for (i
= 0; i
< leni
; i
++)
2873 dummy
= XVECTOR (seq
)->contents
[i
];
2874 dummy
= call1 (fn
, dummy
);
2879 else if (BOOL_VECTOR_P (seq
))
2881 for (i
= 0; i
< leni
; i
++)
2884 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2885 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2890 dummy
= call1 (fn
, dummy
);
2895 else if (STRINGP (seq
))
2899 for (i
= 0, i_byte
= 0; i
< leni
;)
2904 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2905 XSETFASTINT (dummy
, c
);
2906 dummy
= call1 (fn
, dummy
);
2908 vals
[i_before
] = dummy
;
2911 else /* Must be a list, since Flength did not get an error */
2914 for (i
= 0; i
< leni
; i
++)
2916 dummy
= call1 (fn
, Fcar (tail
));
2926 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2927 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2928 In between each pair of results, stick in SEPARATOR. Thus, " " as
2929 SEPARATOR results in spaces between the values returned by FUNCTION.
2930 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2931 (function
, sequence
, separator
)
2932 Lisp_Object function
, sequence
, separator
;
2937 register Lisp_Object
*args
;
2939 struct gcpro gcpro1
;
2941 len
= Flength (sequence
);
2943 nargs
= leni
+ leni
- 1;
2944 if (nargs
< 0) return build_string ("");
2946 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2949 mapcar1 (leni
, args
, function
, sequence
);
2952 for (i
= leni
- 1; i
>= 0; i
--)
2953 args
[i
+ i
] = args
[i
];
2955 for (i
= 1; i
< nargs
; i
+= 2)
2956 args
[i
] = separator
;
2958 return Fconcat (nargs
, args
);
2961 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2962 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2963 The result is a list just as long as SEQUENCE.
2964 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2965 (function
, sequence
)
2966 Lisp_Object function
, sequence
;
2968 register Lisp_Object len
;
2970 register Lisp_Object
*args
;
2972 len
= Flength (sequence
);
2973 leni
= XFASTINT (len
);
2974 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2976 mapcar1 (leni
, args
, function
, sequence
);
2978 return Flist (leni
, args
);
2981 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2982 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2983 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2984 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2985 (function
, sequence
)
2986 Lisp_Object function
, sequence
;
2990 leni
= XFASTINT (Flength (sequence
));
2991 mapcar1 (leni
, 0, function
, sequence
);
2996 /* Anything that calls this function must protect from GC! */
2998 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2999 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
3000 Takes one argument, which is the string to display to ask the question.
3001 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3002 No confirmation of the answer is requested; a single character is enough.
3003 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3004 the bindings in `query-replace-map'; see the documentation of that variable
3005 for more information. In this case, the useful bindings are `act', `skip',
3006 `recenter', and `quit'.\)
3008 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3009 is nil and `use-dialog-box' is non-nil. */)
3013 register Lisp_Object obj
, key
, def
, map
;
3014 register int answer
;
3015 Lisp_Object xprompt
;
3016 Lisp_Object args
[2];
3017 struct gcpro gcpro1
, gcpro2
;
3018 int count
= SPECPDL_INDEX ();
3020 specbind (Qcursor_in_echo_area
, Qt
);
3022 map
= Fsymbol_value (intern ("query-replace-map"));
3024 CHECK_STRING (prompt
);
3026 GCPRO2 (prompt
, xprompt
);
3028 #ifdef HAVE_X_WINDOWS
3029 if (display_hourglass_p
)
3030 cancel_hourglass ();
3037 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3041 Lisp_Object pane
, menu
;
3042 redisplay_preserve_echo_area (3);
3043 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3044 Fcons (Fcons (build_string ("No"), Qnil
),
3046 menu
= Fcons (prompt
, pane
);
3047 obj
= Fx_popup_dialog (Qt
, menu
);
3048 answer
= !NILP (obj
);
3051 #endif /* HAVE_MENUS */
3052 cursor_in_echo_area
= 1;
3053 choose_minibuf_frame ();
3056 Lisp_Object pargs
[3];
3058 /* Colorize prompt according to `minibuffer-prompt' face. */
3059 pargs
[0] = build_string ("%s(y or n) ");
3060 pargs
[1] = intern ("face");
3061 pargs
[2] = intern ("minibuffer-prompt");
3062 args
[0] = Fpropertize (3, pargs
);
3067 if (minibuffer_auto_raise
)
3069 Lisp_Object mini_frame
;
3071 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3073 Fraise_frame (mini_frame
);
3076 obj
= read_filtered_event (1, 0, 0, 0);
3077 cursor_in_echo_area
= 0;
3078 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3081 key
= Fmake_vector (make_number (1), obj
);
3082 def
= Flookup_key (map
, key
, Qt
);
3084 if (EQ (def
, intern ("skip")))
3089 else if (EQ (def
, intern ("act")))
3094 else if (EQ (def
, intern ("recenter")))
3100 else if (EQ (def
, intern ("quit")))
3102 /* We want to exit this command for exit-prefix,
3103 and this is the only way to do it. */
3104 else if (EQ (def
, intern ("exit-prefix")))
3109 /* If we don't clear this, then the next call to read_char will
3110 return quit_char again, and we'll enter an infinite loop. */
3115 if (EQ (xprompt
, prompt
))
3117 args
[0] = build_string ("Please answer y or n. ");
3119 xprompt
= Fconcat (2, args
);
3124 if (! noninteractive
)
3126 cursor_in_echo_area
= -1;
3127 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3131 unbind_to (count
, Qnil
);
3132 return answer
? Qt
: Qnil
;
3135 /* This is how C code calls `yes-or-no-p' and allows the user
3138 Anything that calls this function must protect from GC! */
3141 do_yes_or_no_p (prompt
)
3144 return call1 (intern ("yes-or-no-p"), prompt
);
3147 /* Anything that calls this function must protect from GC! */
3149 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3150 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3151 Takes one argument, which is the string to display to ask the question.
3152 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3153 The user must confirm the answer with RET,
3154 and can edit it until it has been confirmed.
3156 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3157 is nil, and `use-dialog-box' is non-nil. */)
3161 register Lisp_Object ans
;
3162 Lisp_Object args
[2];
3163 struct gcpro gcpro1
;
3165 CHECK_STRING (prompt
);
3168 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3172 Lisp_Object pane
, menu
, obj
;
3173 redisplay_preserve_echo_area (4);
3174 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3175 Fcons (Fcons (build_string ("No"), Qnil
),
3178 menu
= Fcons (prompt
, pane
);
3179 obj
= Fx_popup_dialog (Qt
, menu
);
3183 #endif /* HAVE_MENUS */
3186 args
[1] = build_string ("(yes or no) ");
3187 prompt
= Fconcat (2, args
);
3193 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3194 Qyes_or_no_p_history
, Qnil
,
3196 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3201 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3209 message ("Please answer yes or no.");
3210 Fsleep_for (make_number (2), Qnil
);
3214 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3215 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3217 Each of the three load averages is multiplied by 100, then converted
3220 When USE-FLOATS is non-nil, floats will be used instead of integers.
3221 These floats are not multiplied by 100.
3223 If the 5-minute or 15-minute load averages are not available, return a
3224 shortened list, containing only those averages which are available. */)
3226 Lisp_Object use_floats
;
3229 int loads
= getloadavg (load_ave
, 3);
3230 Lisp_Object ret
= Qnil
;
3233 error ("load-average not implemented for this operating system");
3237 Lisp_Object load
= (NILP (use_floats
) ?
3238 make_number ((int) (100.0 * load_ave
[loads
]))
3239 : make_float (load_ave
[loads
]));
3240 ret
= Fcons (load
, ret
);
3246 Lisp_Object Vfeatures
, Qsubfeatures
;
3247 extern Lisp_Object Vafter_load_alist
;
3249 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3250 doc
: /* Returns t if FEATURE is present in this Emacs.
3252 Use this to conditionalize execution of lisp code based on the
3253 presence or absence of emacs or environment extensions.
3254 Use `provide' to declare that a feature is available. This function
3255 looks at the value of the variable `features'. The optional argument
3256 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3257 (feature
, subfeature
)
3258 Lisp_Object feature
, subfeature
;
3260 register Lisp_Object tem
;
3261 CHECK_SYMBOL (feature
);
3262 tem
= Fmemq (feature
, Vfeatures
);
3263 if (!NILP (tem
) && !NILP (subfeature
))
3264 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3265 return (NILP (tem
)) ? Qnil
: Qt
;
3268 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3269 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3270 The optional argument SUBFEATURES should be a list of symbols listing
3271 particular subfeatures supported in this version of FEATURE. */)
3272 (feature
, subfeatures
)
3273 Lisp_Object feature
, subfeatures
;
3275 register Lisp_Object tem
;
3276 CHECK_SYMBOL (feature
);
3277 CHECK_LIST (subfeatures
);
3278 if (!NILP (Vautoload_queue
))
3279 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3280 tem
= Fmemq (feature
, Vfeatures
);
3282 Vfeatures
= Fcons (feature
, Vfeatures
);
3283 if (!NILP (subfeatures
))
3284 Fput (feature
, Qsubfeatures
, subfeatures
);
3285 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3287 /* Run any load-hooks for this file. */
3288 tem
= Fassq (feature
, Vafter_load_alist
);
3290 Fprogn (XCDR (tem
));
3295 /* `require' and its subroutines. */
3297 /* List of features currently being require'd, innermost first. */
3299 Lisp_Object require_nesting_list
;
3302 require_unwind (old_value
)
3303 Lisp_Object old_value
;
3305 return require_nesting_list
= old_value
;
3308 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3309 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3310 If FEATURE is not a member of the list `features', then the feature
3311 is not loaded; so load the file FILENAME.
3312 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3313 and `load' will try to load this name appended with the suffix `.elc',
3314 `.el' or the unmodified name, in that order.
3315 If the optional third argument NOERROR is non-nil,
3316 then return nil if the file is not found instead of signaling an error.
3317 Normally the return value is FEATURE.
3318 The normal messages at start and end of loading FILENAME are suppressed. */)
3319 (feature
, filename
, noerror
)
3320 Lisp_Object feature
, filename
, noerror
;
3322 register Lisp_Object tem
;
3323 struct gcpro gcpro1
, gcpro2
;
3325 CHECK_SYMBOL (feature
);
3327 tem
= Fmemq (feature
, Vfeatures
);
3331 int count
= SPECPDL_INDEX ();
3334 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3336 /* This is to make sure that loadup.el gives a clear picture
3337 of what files are preloaded and when. */
3338 if (! NILP (Vpurify_flag
))
3339 error ("(require %s) while preparing to dump",
3340 SDATA (SYMBOL_NAME (feature
)));
3342 /* A certain amount of recursive `require' is legitimate,
3343 but if we require the same feature recursively 3 times,
3345 tem
= require_nesting_list
;
3346 while (! NILP (tem
))
3348 if (! NILP (Fequal (feature
, XCAR (tem
))))
3353 error ("Recursive `require' for feature `%s'",
3354 SDATA (SYMBOL_NAME (feature
)));
3356 /* Update the list for any nested `require's that occur. */
3357 record_unwind_protect (require_unwind
, require_nesting_list
);
3358 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3360 /* Value saved here is to be restored into Vautoload_queue */
3361 record_unwind_protect (un_autoload
, Vautoload_queue
);
3362 Vautoload_queue
= Qt
;
3364 /* Load the file. */
3365 GCPRO2 (feature
, filename
);
3366 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3367 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3370 /* If load failed entirely, return nil. */
3372 return unbind_to (count
, Qnil
);
3374 tem
= Fmemq (feature
, Vfeatures
);
3376 error ("Required feature `%s' was not provided",
3377 SDATA (SYMBOL_NAME (feature
)));
3379 /* Once loading finishes, don't undo it. */
3380 Vautoload_queue
= Qt
;
3381 feature
= unbind_to (count
, feature
);
3387 /* Primitives for work of the "widget" library.
3388 In an ideal world, this section would not have been necessary.
3389 However, lisp function calls being as slow as they are, it turns
3390 out that some functions in the widget library (wid-edit.el) are the
3391 bottleneck of Widget operation. Here is their translation to C,
3392 for the sole reason of efficiency. */
3394 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3395 doc
: /* Return non-nil if PLIST has the property PROP.
3396 PLIST is a property list, which is a list of the form
3397 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3398 Unlike `plist-get', this allows you to distinguish between a missing
3399 property and a property with the value nil.
3400 The value is actually the tail of PLIST whose car is PROP. */)
3402 Lisp_Object plist
, prop
;
3404 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3407 plist
= XCDR (plist
);
3408 plist
= CDR (plist
);
3413 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3414 doc
: /* In WIDGET, set PROPERTY to VALUE.
3415 The value can later be retrieved with `widget-get'. */)
3416 (widget
, property
, value
)
3417 Lisp_Object widget
, property
, value
;
3419 CHECK_CONS (widget
);
3420 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3424 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3425 doc
: /* In WIDGET, get the value of PROPERTY.
3426 The value could either be specified when the widget was created, or
3427 later with `widget-put'. */)
3429 Lisp_Object widget
, property
;
3437 CHECK_CONS (widget
);
3438 tmp
= Fplist_member (XCDR (widget
), property
);
3444 tmp
= XCAR (widget
);
3447 widget
= Fget (tmp
, Qwidget_type
);
3451 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3452 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3453 ARGS are passed as extra arguments to the function.
3454 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3459 /* This function can GC. */
3460 Lisp_Object newargs
[3];
3461 struct gcpro gcpro1
, gcpro2
;
3464 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3465 newargs
[1] = args
[0];
3466 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3467 GCPRO2 (newargs
[0], newargs
[2]);
3468 result
= Fapply (3, newargs
);
3473 #ifdef HAVE_LANGINFO_CODESET
3474 #include <langinfo.h>
3477 DEFUN ("langinfo", Flanginfo
, Slanginfo
, 1, 1, 0,
3478 doc
: /* Access locale data ITEM, if available.
3480 ITEM may be one of the following:
3481 `codeset', returning the character set as a string (locale item CODESET);
3482 `days', returning a 7-element vector of day names (locale items DAY_n);
3483 `months', returning a 12-element vector of month names (locale items MON_n);
3484 `paper', returning a list (WIDTH, HEIGHT) for the default paper size,
3485 where the width and height are in mm (locale items PAPER_WIDTH,
3488 If the system can't provide such information through a call to
3489 nl_langinfo(3), return nil.
3491 See also Info node `(libc)Locales'.
3493 The data read from the system are decoded using `locale-coding-system'. */)
3498 #ifdef HAVE_LANGINFO_CODESET
3500 if (EQ (item
, Qcodeset
))
3502 str
= nl_langinfo (CODESET
);
3503 return build_string (str
);
3506 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3508 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3509 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3511 synchronize_system_time_locale ();
3512 for (i
= 0; i
< 7; i
++)
3514 str
= nl_langinfo (days
[i
]);
3515 val
= make_unibyte_string (str
, strlen (str
));
3516 /* Fixme: Is this coding system necessarily right, even if
3517 it is consistent with CODESET? If not, what to do? */
3518 Faset (v
, make_number (i
),
3519 code_convert_string_norecord (val
, Vlocale_coding_system
,
3526 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3528 struct Lisp_Vector
*p
= allocate_vector (12);
3529 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3530 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3532 synchronize_system_time_locale ();
3533 for (i
= 0; i
< 12; i
++)
3535 str
= nl_langinfo (months
[i
]);
3536 val
= make_unibyte_string (str
, strlen (str
));
3538 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3540 XSETVECTOR (val
, p
);
3544 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3545 but is in the locale files. This could be used by ps-print. */
3547 else if (EQ (item
, Qpaper
))
3549 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3550 make_number (nl_langinfo (PAPER_HEIGHT
)));
3552 #endif /* PAPER_WIDTH */
3553 #endif /* HAVE_LANGINFO_CODESET*/
3557 /* base64 encode/decode functions (RFC 2045).
3558 Based on code from GNU recode. */
3560 #define MIME_LINE_LENGTH 76
3562 #define IS_ASCII(Character) \
3564 #define IS_BASE64(Character) \
3565 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3566 #define IS_BASE64_IGNORABLE(Character) \
3567 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3568 || (Character) == '\f' || (Character) == '\r')
3570 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3571 character or return retval if there are no characters left to
3573 #define READ_QUADRUPLET_BYTE(retval) \
3578 if (nchars_return) \
3579 *nchars_return = nchars; \
3584 while (IS_BASE64_IGNORABLE (c))
3586 /* Don't use alloca for regions larger than this, lest we overflow
3588 #define MAX_ALLOCA 16*1024
3590 /* Table of characters coding the 64 values. */
3591 static char base64_value_to_char
[64] =
3593 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3594 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3595 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3596 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3597 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3598 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3599 '8', '9', '+', '/' /* 60-63 */
3602 /* Table of base64 values for first 128 characters. */
3603 static short base64_char_to_value
[128] =
3605 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3606 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3607 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3608 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3609 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3610 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3611 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3612 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3613 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3614 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3615 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3616 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3617 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3620 /* The following diagram shows the logical steps by which three octets
3621 get transformed into four base64 characters.
3623 .--------. .--------. .--------.
3624 |aaaaaabb| |bbbbcccc| |ccdddddd|
3625 `--------' `--------' `--------'
3627 .--------+--------+--------+--------.
3628 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3629 `--------+--------+--------+--------'
3631 .--------+--------+--------+--------.
3632 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3633 `--------+--------+--------+--------'
3635 The octets are divided into 6 bit chunks, which are then encoded into
3636 base64 characters. */
3639 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3640 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3642 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3644 doc
: /* Base64-encode the region between BEG and END.
3645 Return the length of the encoded text.
3646 Optional third argument NO-LINE-BREAK means do not break long lines
3647 into shorter lines. */)
3648 (beg
, end
, no_line_break
)
3649 Lisp_Object beg
, end
, no_line_break
;
3652 int allength
, length
;
3653 int ibeg
, iend
, encoded_length
;
3656 validate_region (&beg
, &end
);
3658 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3659 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3660 move_gap_both (XFASTINT (beg
), ibeg
);
3662 /* We need to allocate enough room for encoding the text.
3663 We need 33 1/3% more space, plus a newline every 76
3664 characters, and then we round up. */
3665 length
= iend
- ibeg
;
3666 allength
= length
+ length
/3 + 1;
3667 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3669 if (allength
<= MAX_ALLOCA
)
3670 encoded
= (char *) alloca (allength
);
3672 encoded
= (char *) xmalloc (allength
);
3673 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3674 NILP (no_line_break
),
3675 !NILP (current_buffer
->enable_multibyte_characters
));
3676 if (encoded_length
> allength
)
3679 if (encoded_length
< 0)
3681 /* The encoding wasn't possible. */
3682 if (length
> MAX_ALLOCA
)
3684 error ("Multibyte character in data for base64 encoding");
3687 /* Now we have encoded the region, so we insert the new contents
3688 and delete the old. (Insert first in order to preserve markers.) */
3689 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3690 insert (encoded
, encoded_length
);
3691 if (allength
> MAX_ALLOCA
)
3693 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3695 /* If point was outside of the region, restore it exactly; else just
3696 move to the beginning of the region. */
3697 if (old_pos
>= XFASTINT (end
))
3698 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3699 else if (old_pos
> XFASTINT (beg
))
3700 old_pos
= XFASTINT (beg
);
3703 /* We return the length of the encoded text. */
3704 return make_number (encoded_length
);
3707 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3709 doc
: /* Base64-encode STRING and return the result.
3710 Optional second argument NO-LINE-BREAK means do not break long lines
3711 into shorter lines. */)
3712 (string
, no_line_break
)
3713 Lisp_Object string
, no_line_break
;
3715 int allength
, length
, encoded_length
;
3717 Lisp_Object encoded_string
;
3719 CHECK_STRING (string
);
3721 /* We need to allocate enough room for encoding the text.
3722 We need 33 1/3% more space, plus a newline every 76
3723 characters, and then we round up. */
3724 length
= SBYTES (string
);
3725 allength
= length
+ length
/3 + 1;
3726 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3728 /* We need to allocate enough room for decoding the text. */
3729 if (allength
<= MAX_ALLOCA
)
3730 encoded
= (char *) alloca (allength
);
3732 encoded
= (char *) xmalloc (allength
);
3734 encoded_length
= base64_encode_1 (SDATA (string
),
3735 encoded
, length
, NILP (no_line_break
),
3736 STRING_MULTIBYTE (string
));
3737 if (encoded_length
> allength
)
3740 if (encoded_length
< 0)
3742 /* The encoding wasn't possible. */
3743 if (length
> MAX_ALLOCA
)
3745 error ("Multibyte character in data for base64 encoding");
3748 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3749 if (allength
> MAX_ALLOCA
)
3752 return encoded_string
;
3756 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3763 int counter
= 0, i
= 0;
3773 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3781 /* Wrap line every 76 characters. */
3785 if (counter
< MIME_LINE_LENGTH
/ 4)
3794 /* Process first byte of a triplet. */
3796 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3797 value
= (0x03 & c
) << 4;
3799 /* Process second byte of a triplet. */
3803 *e
++ = base64_value_to_char
[value
];
3811 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3819 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3820 value
= (0x0f & c
) << 2;
3822 /* Process third byte of a triplet. */
3826 *e
++ = base64_value_to_char
[value
];
3833 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3841 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3842 *e
++ = base64_value_to_char
[0x3f & c
];
3849 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3851 doc
: /* Base64-decode the region between BEG and END.
3852 Return the length of the decoded text.
3853 If the region can't be decoded, signal an error and don't modify the buffer. */)
3855 Lisp_Object beg
, end
;
3857 int ibeg
, iend
, length
, allength
;
3862 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3864 validate_region (&beg
, &end
);
3866 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3867 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3869 length
= iend
- ibeg
;
3871 /* We need to allocate enough room for decoding the text. If we are
3872 working on a multibyte buffer, each decoded code may occupy at
3874 allength
= multibyte
? length
* 2 : length
;
3875 if (allength
<= MAX_ALLOCA
)
3876 decoded
= (char *) alloca (allength
);
3878 decoded
= (char *) xmalloc (allength
);
3880 move_gap_both (XFASTINT (beg
), ibeg
);
3881 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3882 multibyte
, &inserted_chars
);
3883 if (decoded_length
> allength
)
3886 if (decoded_length
< 0)
3888 /* The decoding wasn't possible. */
3889 if (allength
> MAX_ALLOCA
)
3891 error ("Invalid base64 data");
3894 /* Now we have decoded the region, so we insert the new contents
3895 and delete the old. (Insert first in order to preserve markers.) */
3896 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3897 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3898 if (allength
> MAX_ALLOCA
)
3900 /* Delete the original text. */
3901 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3902 iend
+ decoded_length
, 1);
3904 /* If point was outside of the region, restore it exactly; else just
3905 move to the beginning of the region. */
3906 if (old_pos
>= XFASTINT (end
))
3907 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3908 else if (old_pos
> XFASTINT (beg
))
3909 old_pos
= XFASTINT (beg
);
3910 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3912 return make_number (inserted_chars
);
3915 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3917 doc
: /* Base64-decode STRING and return the result. */)
3922 int length
, decoded_length
;
3923 Lisp_Object decoded_string
;
3925 CHECK_STRING (string
);
3927 length
= SBYTES (string
);
3928 /* We need to allocate enough room for decoding the text. */
3929 if (length
<= MAX_ALLOCA
)
3930 decoded
= (char *) alloca (length
);
3932 decoded
= (char *) xmalloc (length
);
3934 /* The decoded result should be unibyte. */
3935 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3937 if (decoded_length
> length
)
3939 else if (decoded_length
>= 0)
3940 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3942 decoded_string
= Qnil
;
3944 if (length
> MAX_ALLOCA
)
3946 if (!STRINGP (decoded_string
))
3947 error ("Invalid base64 data");
3949 return decoded_string
;
3952 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3953 MULTIBYTE is nonzero, the decoded result should be in multibyte
3954 form. If NCHARS_RETRUN is not NULL, store the number of produced
3955 characters in *NCHARS_RETURN. */
3958 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3968 unsigned long value
;
3973 /* Process first byte of a quadruplet. */
3975 READ_QUADRUPLET_BYTE (e
-to
);
3979 value
= base64_char_to_value
[c
] << 18;
3981 /* Process second byte of a quadruplet. */
3983 READ_QUADRUPLET_BYTE (-1);
3987 value
|= base64_char_to_value
[c
] << 12;
3989 c
= (unsigned char) (value
>> 16);
3991 e
+= CHAR_STRING (c
, e
);
3996 /* Process third byte of a quadruplet. */
3998 READ_QUADRUPLET_BYTE (-1);
4002 READ_QUADRUPLET_BYTE (-1);
4011 value
|= base64_char_to_value
[c
] << 6;
4013 c
= (unsigned char) (0xff & value
>> 8);
4015 e
+= CHAR_STRING (c
, e
);
4020 /* Process fourth byte of a quadruplet. */
4022 READ_QUADRUPLET_BYTE (-1);
4029 value
|= base64_char_to_value
[c
];
4031 c
= (unsigned char) (0xff & value
);
4033 e
+= CHAR_STRING (c
, e
);
4042 /***********************************************************************
4044 ***** Hash Tables *****
4046 ***********************************************************************/
4048 /* Implemented by gerd@gnu.org. This hash table implementation was
4049 inspired by CMUCL hash tables. */
4053 1. For small tables, association lists are probably faster than
4054 hash tables because they have lower overhead.
4056 For uses of hash tables where the O(1) behavior of table
4057 operations is not a requirement, it might therefore be a good idea
4058 not to hash. Instead, we could just do a linear search in the
4059 key_and_value vector of the hash table. This could be done
4060 if a `:linear-search t' argument is given to make-hash-table. */
4063 /* The list of all weak hash tables. Don't staticpro this one. */
4065 Lisp_Object Vweak_hash_tables
;
4067 /* Various symbols. */
4069 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4070 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4071 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4073 /* Function prototypes. */
4075 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4076 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4077 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4078 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4079 Lisp_Object
, unsigned));
4080 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4081 Lisp_Object
, unsigned));
4082 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4083 unsigned, Lisp_Object
, unsigned));
4084 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4085 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4086 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4087 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4089 static unsigned sxhash_string
P_ ((unsigned char *, int));
4090 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4091 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4092 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4093 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4097 /***********************************************************************
4099 ***********************************************************************/
4101 /* If OBJ is a Lisp hash table, return a pointer to its struct
4102 Lisp_Hash_Table. Otherwise, signal an error. */
4104 static struct Lisp_Hash_Table
*
4105 check_hash_table (obj
)
4108 CHECK_HASH_TABLE (obj
);
4109 return XHASH_TABLE (obj
);
4113 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4117 next_almost_prime (n
)
4130 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4131 which USED[I] is non-zero. If found at index I in ARGS, set
4132 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4133 -1. This function is used to extract a keyword/argument pair from
4134 a DEFUN parameter list. */
4137 get_key_arg (key
, nargs
, args
, used
)
4145 for (i
= 0; i
< nargs
- 1; ++i
)
4146 if (!used
[i
] && EQ (args
[i
], key
))
4161 /* Return a Lisp vector which has the same contents as VEC but has
4162 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4163 vector that are not copied from VEC are set to INIT. */
4166 larger_vector (vec
, new_size
, init
)
4171 struct Lisp_Vector
*v
;
4174 xassert (VECTORP (vec
));
4175 old_size
= XVECTOR (vec
)->size
;
4176 xassert (new_size
>= old_size
);
4178 v
= allocate_vector (new_size
);
4179 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4180 old_size
* sizeof *v
->contents
);
4181 for (i
= old_size
; i
< new_size
; ++i
)
4182 v
->contents
[i
] = init
;
4183 XSETVECTOR (vec
, v
);
4188 /***********************************************************************
4190 ***********************************************************************/
4192 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4193 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4194 KEY2 are the same. */
4197 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4198 struct Lisp_Hash_Table
*h
;
4199 Lisp_Object key1
, key2
;
4200 unsigned hash1
, hash2
;
4202 return (FLOATP (key1
)
4204 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4208 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4209 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4210 KEY2 are the same. */
4213 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4214 struct Lisp_Hash_Table
*h
;
4215 Lisp_Object key1
, key2
;
4216 unsigned hash1
, hash2
;
4218 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4222 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4223 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4224 if KEY1 and KEY2 are the same. */
4227 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4228 struct Lisp_Hash_Table
*h
;
4229 Lisp_Object key1
, key2
;
4230 unsigned hash1
, hash2
;
4234 Lisp_Object args
[3];
4236 args
[0] = h
->user_cmp_function
;
4239 return !NILP (Ffuncall (3, args
));
4246 /* Value is a hash code for KEY for use in hash table H which uses
4247 `eq' to compare keys. The hash code returned is guaranteed to fit
4248 in a Lisp integer. */
4252 struct Lisp_Hash_Table
*h
;
4255 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4256 xassert ((hash
& ~VALMASK
) == 0);
4261 /* Value is a hash code for KEY for use in hash table H which uses
4262 `eql' to compare keys. The hash code returned is guaranteed to fit
4263 in a Lisp integer. */
4267 struct Lisp_Hash_Table
*h
;
4272 hash
= sxhash (key
, 0);
4274 hash
= XUINT (key
) ^ XGCTYPE (key
);
4275 xassert ((hash
& ~VALMASK
) == 0);
4280 /* Value is a hash code for KEY for use in hash table H which uses
4281 `equal' to compare keys. The hash code returned is guaranteed to fit
4282 in a Lisp integer. */
4285 hashfn_equal (h
, key
)
4286 struct Lisp_Hash_Table
*h
;
4289 unsigned hash
= sxhash (key
, 0);
4290 xassert ((hash
& ~VALMASK
) == 0);
4295 /* Value is a hash code for KEY for use in hash table H which uses as
4296 user-defined function to compare keys. The hash code returned is
4297 guaranteed to fit in a Lisp integer. */
4300 hashfn_user_defined (h
, key
)
4301 struct Lisp_Hash_Table
*h
;
4304 Lisp_Object args
[2], hash
;
4306 args
[0] = h
->user_hash_function
;
4308 hash
= Ffuncall (2, args
);
4309 if (!INTEGERP (hash
))
4311 list2 (build_string ("Invalid hash code returned from \
4312 user-supplied hash function"),
4314 return XUINT (hash
);
4318 /* Create and initialize a new hash table.
4320 TEST specifies the test the hash table will use to compare keys.
4321 It must be either one of the predefined tests `eq', `eql' or
4322 `equal' or a symbol denoting a user-defined test named TEST with
4323 test and hash functions USER_TEST and USER_HASH.
4325 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4327 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4328 new size when it becomes full is computed by adding REHASH_SIZE to
4329 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4330 table's new size is computed by multiplying its old size with
4333 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4334 be resized when the ratio of (number of entries in the table) /
4335 (table size) is >= REHASH_THRESHOLD.
4337 WEAK specifies the weakness of the table. If non-nil, it must be
4338 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4341 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4342 user_test
, user_hash
)
4343 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4344 Lisp_Object user_test
, user_hash
;
4346 struct Lisp_Hash_Table
*h
;
4348 int index_size
, i
, sz
;
4350 /* Preconditions. */
4351 xassert (SYMBOLP (test
));
4352 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4353 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4354 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4355 xassert (FLOATP (rehash_threshold
)
4356 && XFLOATINT (rehash_threshold
) > 0
4357 && XFLOATINT (rehash_threshold
) <= 1.0);
4359 if (XFASTINT (size
) == 0)
4360 size
= make_number (1);
4362 /* Allocate a table and initialize it. */
4363 h
= allocate_hash_table ();
4365 /* Initialize hash table slots. */
4366 sz
= XFASTINT (size
);
4369 if (EQ (test
, Qeql
))
4371 h
->cmpfn
= cmpfn_eql
;
4372 h
->hashfn
= hashfn_eql
;
4374 else if (EQ (test
, Qeq
))
4377 h
->hashfn
= hashfn_eq
;
4379 else if (EQ (test
, Qequal
))
4381 h
->cmpfn
= cmpfn_equal
;
4382 h
->hashfn
= hashfn_equal
;
4386 h
->user_cmp_function
= user_test
;
4387 h
->user_hash_function
= user_hash
;
4388 h
->cmpfn
= cmpfn_user_defined
;
4389 h
->hashfn
= hashfn_user_defined
;
4393 h
->rehash_threshold
= rehash_threshold
;
4394 h
->rehash_size
= rehash_size
;
4395 h
->count
= make_number (0);
4396 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4397 h
->hash
= Fmake_vector (size
, Qnil
);
4398 h
->next
= Fmake_vector (size
, Qnil
);
4399 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4400 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4401 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4403 /* Set up the free list. */
4404 for (i
= 0; i
< sz
- 1; ++i
)
4405 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4406 h
->next_free
= make_number (0);
4408 XSET_HASH_TABLE (table
, h
);
4409 xassert (HASH_TABLE_P (table
));
4410 xassert (XHASH_TABLE (table
) == h
);
4412 /* Maybe add this hash table to the list of all weak hash tables. */
4414 h
->next_weak
= Qnil
;
4417 h
->next_weak
= Vweak_hash_tables
;
4418 Vweak_hash_tables
= table
;
4425 /* Return a copy of hash table H1. Keys and values are not copied,
4426 only the table itself is. */
4429 copy_hash_table (h1
)
4430 struct Lisp_Hash_Table
*h1
;
4433 struct Lisp_Hash_Table
*h2
;
4434 struct Lisp_Vector
*next
;
4436 h2
= allocate_hash_table ();
4437 next
= h2
->vec_next
;
4438 bcopy (h1
, h2
, sizeof *h2
);
4439 h2
->vec_next
= next
;
4440 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4441 h2
->hash
= Fcopy_sequence (h1
->hash
);
4442 h2
->next
= Fcopy_sequence (h1
->next
);
4443 h2
->index
= Fcopy_sequence (h1
->index
);
4444 XSET_HASH_TABLE (table
, h2
);
4446 /* Maybe add this hash table to the list of all weak hash tables. */
4447 if (!NILP (h2
->weak
))
4449 h2
->next_weak
= Vweak_hash_tables
;
4450 Vweak_hash_tables
= table
;
4457 /* Resize hash table H if it's too full. If H cannot be resized
4458 because it's already too large, throw an error. */
4461 maybe_resize_hash_table (h
)
4462 struct Lisp_Hash_Table
*h
;
4464 if (NILP (h
->next_free
))
4466 int old_size
= HASH_TABLE_SIZE (h
);
4467 int i
, new_size
, index_size
;
4469 if (INTEGERP (h
->rehash_size
))
4470 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4472 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4473 new_size
= max (old_size
+ 1, new_size
);
4474 index_size
= next_almost_prime ((int)
4476 / XFLOATINT (h
->rehash_threshold
)));
4477 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4478 error ("Hash table too large to resize");
4480 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4481 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4482 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4483 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4485 /* Update the free list. Do it so that new entries are added at
4486 the end of the free list. This makes some operations like
4488 for (i
= old_size
; i
< new_size
- 1; ++i
)
4489 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4491 if (!NILP (h
->next_free
))
4493 Lisp_Object last
, next
;
4495 last
= h
->next_free
;
4496 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4500 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4503 XSETFASTINT (h
->next_free
, old_size
);
4506 for (i
= 0; i
< old_size
; ++i
)
4507 if (!NILP (HASH_HASH (h
, i
)))
4509 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4510 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4511 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4512 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4518 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4519 the hash code of KEY. Value is the index of the entry in H
4520 matching KEY, or -1 if not found. */
4523 hash_lookup (h
, key
, hash
)
4524 struct Lisp_Hash_Table
*h
;
4529 int start_of_bucket
;
4532 hash_code
= h
->hashfn (h
, key
);
4536 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4537 idx
= HASH_INDEX (h
, start_of_bucket
);
4539 /* We need not gcpro idx since it's either an integer or nil. */
4542 int i
= XFASTINT (idx
);
4543 if (EQ (key
, HASH_KEY (h
, i
))
4545 && h
->cmpfn (h
, key
, hash_code
,
4546 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4548 idx
= HASH_NEXT (h
, i
);
4551 return NILP (idx
) ? -1 : XFASTINT (idx
);
4555 /* Put an entry into hash table H that associates KEY with VALUE.
4556 HASH is a previously computed hash code of KEY.
4557 Value is the index of the entry in H matching KEY. */
4560 hash_put (h
, key
, value
, hash
)
4561 struct Lisp_Hash_Table
*h
;
4562 Lisp_Object key
, value
;
4565 int start_of_bucket
, i
;
4567 xassert ((hash
& ~VALMASK
) == 0);
4569 /* Increment count after resizing because resizing may fail. */
4570 maybe_resize_hash_table (h
);
4571 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4573 /* Store key/value in the key_and_value vector. */
4574 i
= XFASTINT (h
->next_free
);
4575 h
->next_free
= HASH_NEXT (h
, i
);
4576 HASH_KEY (h
, i
) = key
;
4577 HASH_VALUE (h
, i
) = value
;
4579 /* Remember its hash code. */
4580 HASH_HASH (h
, i
) = make_number (hash
);
4582 /* Add new entry to its collision chain. */
4583 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4584 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4585 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4590 /* Remove the entry matching KEY from hash table H, if there is one. */
4593 hash_remove (h
, key
)
4594 struct Lisp_Hash_Table
*h
;
4598 int start_of_bucket
;
4599 Lisp_Object idx
, prev
;
4601 hash_code
= h
->hashfn (h
, key
);
4602 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4603 idx
= HASH_INDEX (h
, start_of_bucket
);
4606 /* We need not gcpro idx, prev since they're either integers or nil. */
4609 int i
= XFASTINT (idx
);
4611 if (EQ (key
, HASH_KEY (h
, i
))
4613 && h
->cmpfn (h
, key
, hash_code
,
4614 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4616 /* Take entry out of collision chain. */
4618 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4620 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4622 /* Clear slots in key_and_value and add the slots to
4624 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4625 HASH_NEXT (h
, i
) = h
->next_free
;
4626 h
->next_free
= make_number (i
);
4627 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4628 xassert (XINT (h
->count
) >= 0);
4634 idx
= HASH_NEXT (h
, i
);
4640 /* Clear hash table H. */
4644 struct Lisp_Hash_Table
*h
;
4646 if (XFASTINT (h
->count
) > 0)
4648 int i
, size
= HASH_TABLE_SIZE (h
);
4650 for (i
= 0; i
< size
; ++i
)
4652 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4653 HASH_KEY (h
, i
) = Qnil
;
4654 HASH_VALUE (h
, i
) = Qnil
;
4655 HASH_HASH (h
, i
) = Qnil
;
4658 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4659 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4661 h
->next_free
= make_number (0);
4662 h
->count
= make_number (0);
4668 /************************************************************************
4670 ************************************************************************/
4672 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4673 entries from the table that don't survive the current GC.
4674 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4675 non-zero if anything was marked. */
4678 sweep_weak_table (h
, remove_entries_p
)
4679 struct Lisp_Hash_Table
*h
;
4680 int remove_entries_p
;
4682 int bucket
, n
, marked
;
4684 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4687 for (bucket
= 0; bucket
< n
; ++bucket
)
4689 Lisp_Object idx
, next
, prev
;
4691 /* Follow collision chain, removing entries that
4692 don't survive this garbage collection. */
4694 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4696 int i
= XFASTINT (idx
);
4697 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4698 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4701 if (EQ (h
->weak
, Qkey
))
4702 remove_p
= !key_known_to_survive_p
;
4703 else if (EQ (h
->weak
, Qvalue
))
4704 remove_p
= !value_known_to_survive_p
;
4705 else if (EQ (h
->weak
, Qkey_or_value
))
4706 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4707 else if (EQ (h
->weak
, Qkey_and_value
))
4708 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4712 next
= HASH_NEXT (h
, i
);
4714 if (remove_entries_p
)
4718 /* Take out of collision chain. */
4720 HASH_INDEX (h
, bucket
) = next
;
4722 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4724 /* Add to free list. */
4725 HASH_NEXT (h
, i
) = h
->next_free
;
4728 /* Clear key, value, and hash. */
4729 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4730 HASH_HASH (h
, i
) = Qnil
;
4732 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4739 /* Make sure key and value survive. */
4740 if (!key_known_to_survive_p
)
4742 mark_object (&HASH_KEY (h
, i
));
4746 if (!value_known_to_survive_p
)
4748 mark_object (&HASH_VALUE (h
, i
));
4759 /* Remove elements from weak hash tables that don't survive the
4760 current garbage collection. Remove weak tables that don't survive
4761 from Vweak_hash_tables. Called from gc_sweep. */
4764 sweep_weak_hash_tables ()
4766 Lisp_Object table
, used
, next
;
4767 struct Lisp_Hash_Table
*h
;
4770 /* Mark all keys and values that are in use. Keep on marking until
4771 there is no more change. This is necessary for cases like
4772 value-weak table A containing an entry X -> Y, where Y is used in a
4773 key-weak table B, Z -> Y. If B comes after A in the list of weak
4774 tables, X -> Y might be removed from A, although when looking at B
4775 one finds that it shouldn't. */
4779 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4781 h
= XHASH_TABLE (table
);
4782 if (h
->size
& ARRAY_MARK_FLAG
)
4783 marked
|= sweep_weak_table (h
, 0);
4788 /* Remove tables and entries that aren't used. */
4789 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4791 h
= XHASH_TABLE (table
);
4792 next
= h
->next_weak
;
4794 if (h
->size
& ARRAY_MARK_FLAG
)
4796 /* TABLE is marked as used. Sweep its contents. */
4797 if (XFASTINT (h
->count
) > 0)
4798 sweep_weak_table (h
, 1);
4800 /* Add table to the list of used weak hash tables. */
4801 h
->next_weak
= used
;
4806 Vweak_hash_tables
= used
;
4811 /***********************************************************************
4812 Hash Code Computation
4813 ***********************************************************************/
4815 /* Maximum depth up to which to dive into Lisp structures. */
4817 #define SXHASH_MAX_DEPTH 3
4819 /* Maximum length up to which to take list and vector elements into
4822 #define SXHASH_MAX_LEN 7
4824 /* Combine two integers X and Y for hashing. */
4826 #define SXHASH_COMBINE(X, Y) \
4827 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4831 /* Return a hash for string PTR which has length LEN. The hash
4832 code returned is guaranteed to fit in a Lisp integer. */
4835 sxhash_string (ptr
, len
)
4839 unsigned char *p
= ptr
;
4840 unsigned char *end
= p
+ len
;
4849 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4852 return hash
& VALMASK
;
4856 /* Return a hash for list LIST. DEPTH is the current depth in the
4857 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4860 sxhash_list (list
, depth
)
4867 if (depth
< SXHASH_MAX_DEPTH
)
4869 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4870 list
= XCDR (list
), ++i
)
4872 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4873 hash
= SXHASH_COMBINE (hash
, hash2
);
4880 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4881 the Lisp structure. */
4884 sxhash_vector (vec
, depth
)
4888 unsigned hash
= XVECTOR (vec
)->size
;
4891 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4892 for (i
= 0; i
< n
; ++i
)
4894 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4895 hash
= SXHASH_COMBINE (hash
, hash2
);
4902 /* Return a hash for bool-vector VECTOR. */
4905 sxhash_bool_vector (vec
)
4908 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4911 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4912 for (i
= 0; i
< n
; ++i
)
4913 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4919 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4920 structure. Value is an unsigned integer clipped to VALMASK. */
4929 if (depth
> SXHASH_MAX_DEPTH
)
4932 switch (XTYPE (obj
))
4939 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4940 SCHARS (SYMBOL_NAME (obj
)));
4948 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4951 /* This can be everything from a vector to an overlay. */
4952 case Lisp_Vectorlike
:
4954 /* According to the CL HyperSpec, two arrays are equal only if
4955 they are `eq', except for strings and bit-vectors. In
4956 Emacs, this works differently. We have to compare element
4958 hash
= sxhash_vector (obj
, depth
);
4959 else if (BOOL_VECTOR_P (obj
))
4960 hash
= sxhash_bool_vector (obj
);
4962 /* Others are `equal' if they are `eq', so let's take their
4968 hash
= sxhash_list (obj
, depth
);
4973 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4974 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4975 for (hash
= 0; p
< e
; ++p
)
4976 hash
= SXHASH_COMBINE (hash
, *p
);
4984 return hash
& VALMASK
;
4989 /***********************************************************************
4991 ***********************************************************************/
4994 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4995 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4999 unsigned hash
= sxhash (obj
, 0);;
5000 return make_number (hash
);
5004 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5005 doc
: /* Create and return a new hash table.
5007 Arguments are specified as keyword/argument pairs. The following
5008 arguments are defined:
5010 :test TEST -- TEST must be a symbol that specifies how to compare
5011 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5012 `equal'. User-supplied test and hash functions can be specified via
5013 `define-hash-table-test'.
5015 :size SIZE -- A hint as to how many elements will be put in the table.
5018 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5019 fills up. If REHASH-SIZE is an integer, add that many space. If it
5020 is a float, it must be > 1.0, and the new size is computed by
5021 multiplying the old size with that factor. Default is 1.5.
5023 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5024 Resize the hash table when ratio of the number of entries in the
5025 table. Default is 0.8.
5027 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5028 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5029 returned is a weak table. Key/value pairs are removed from a weak
5030 hash table when there are no non-weak references pointing to their
5031 key, value, one of key or value, or both key and value, depending on
5032 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5035 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5040 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5041 Lisp_Object user_test
, user_hash
;
5045 /* The vector `used' is used to keep track of arguments that
5046 have been consumed. */
5047 used
= (char *) alloca (nargs
* sizeof *used
);
5048 bzero (used
, nargs
* sizeof *used
);
5050 /* See if there's a `:test TEST' among the arguments. */
5051 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5052 test
= i
< 0 ? Qeql
: args
[i
];
5053 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5055 /* See if it is a user-defined test. */
5058 prop
= Fget (test
, Qhash_table_test
);
5059 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5060 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5062 user_test
= XCAR (prop
);
5063 user_hash
= XCAR (XCDR (prop
));
5066 user_test
= user_hash
= Qnil
;
5068 /* See if there's a `:size SIZE' argument. */
5069 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5070 size
= i
< 0 ? Qnil
: args
[i
];
5072 size
= make_number (DEFAULT_HASH_SIZE
);
5073 else if (!INTEGERP (size
) || XINT (size
) < 0)
5075 list2 (build_string ("Invalid hash table size"),
5078 /* Look for `:rehash-size SIZE'. */
5079 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5080 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5081 if (!NUMBERP (rehash_size
)
5082 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5083 || XFLOATINT (rehash_size
) <= 1.0)
5085 list2 (build_string ("Invalid hash table rehash size"),
5088 /* Look for `:rehash-threshold THRESHOLD'. */
5089 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5090 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5091 if (!FLOATP (rehash_threshold
)
5092 || XFLOATINT (rehash_threshold
) <= 0.0
5093 || XFLOATINT (rehash_threshold
) > 1.0)
5095 list2 (build_string ("Invalid hash table rehash threshold"),
5098 /* Look for `:weakness WEAK'. */
5099 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5100 weak
= i
< 0 ? Qnil
: args
[i
];
5102 weak
= Qkey_and_value
;
5105 && !EQ (weak
, Qvalue
)
5106 && !EQ (weak
, Qkey_or_value
)
5107 && !EQ (weak
, Qkey_and_value
))
5108 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5111 /* Now, all args should have been used up, or there's a problem. */
5112 for (i
= 0; i
< nargs
; ++i
)
5115 list2 (build_string ("Invalid argument list"), args
[i
]));
5117 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5118 user_test
, user_hash
);
5122 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5123 doc
: /* Return a copy of hash table TABLE. */)
5127 return copy_hash_table (check_hash_table (table
));
5131 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5132 doc
: /* Return the number of elements in TABLE. */)
5136 return check_hash_table (table
)->count
;
5140 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5141 Shash_table_rehash_size
, 1, 1, 0,
5142 doc
: /* Return the current rehash size of TABLE. */)
5146 return check_hash_table (table
)->rehash_size
;
5150 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5151 Shash_table_rehash_threshold
, 1, 1, 0,
5152 doc
: /* Return the current rehash threshold of TABLE. */)
5156 return check_hash_table (table
)->rehash_threshold
;
5160 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5161 doc
: /* Return the size of TABLE.
5162 The size can be used as an argument to `make-hash-table' to create
5163 a hash table than can hold as many elements of TABLE holds
5164 without need for resizing. */)
5168 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5169 return make_number (HASH_TABLE_SIZE (h
));
5173 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5174 doc
: /* Return the test TABLE uses. */)
5178 return check_hash_table (table
)->test
;
5182 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5184 doc
: /* Return the weakness of TABLE. */)
5188 return check_hash_table (table
)->weak
;
5192 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5193 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5197 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5201 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5202 doc
: /* Clear hash table TABLE. */)
5206 hash_clear (check_hash_table (table
));
5211 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5212 doc
: /* Look up KEY in TABLE and return its associated value.
5213 If KEY is not found, return DFLT which defaults to nil. */)
5215 Lisp_Object key
, table
, dflt
;
5217 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5218 int i
= hash_lookup (h
, key
, NULL
);
5219 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5223 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5224 doc
: /* Associate KEY with VALUE in hash table TABLE.
5225 If KEY is already present in table, replace its current value with
5228 Lisp_Object key
, value
, table
;
5230 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5234 i
= hash_lookup (h
, key
, &hash
);
5236 HASH_VALUE (h
, i
) = value
;
5238 hash_put (h
, key
, value
, hash
);
5244 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5245 doc
: /* Remove KEY from TABLE. */)
5247 Lisp_Object key
, table
;
5249 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5250 hash_remove (h
, key
);
5255 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5256 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5257 FUNCTION is called with 2 arguments KEY and VALUE. */)
5259 Lisp_Object function
, table
;
5261 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5262 Lisp_Object args
[3];
5265 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5266 if (!NILP (HASH_HASH (h
, i
)))
5269 args
[1] = HASH_KEY (h
, i
);
5270 args
[2] = HASH_VALUE (h
, i
);
5278 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5279 Sdefine_hash_table_test
, 3, 3, 0,
5280 doc
: /* Define a new hash table test with name NAME, a symbol.
5282 In hash tables created with NAME specified as test, use TEST to
5283 compare keys, and HASH for computing hash codes of keys.
5285 TEST must be a function taking two arguments and returning non-nil if
5286 both arguments are the same. HASH must be a function taking one
5287 argument and return an integer that is the hash code of the argument.
5288 Hash code computation should use the whole value range of integers,
5289 including negative integers. */)
5291 Lisp_Object name
, test
, hash
;
5293 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5298 /************************************************************************
5300 ************************************************************************/
5305 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5306 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5308 A message digest is a cryptographic checksum of a document, and the
5309 algorithm to calculate it is defined in RFC 1321.
5311 The two optional arguments START and END are character positions
5312 specifying for which part of OBJECT the message digest should be
5313 computed. If nil or omitted, the digest is computed for the whole
5316 The MD5 message digest is computed from the result of encoding the
5317 text in a coding system, not directly from the internal Emacs form of
5318 the text. The optional fourth argument CODING-SYSTEM specifies which
5319 coding system to encode the text with. It should be the same coding
5320 system that you used or will use when actually writing the text into a
5323 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5324 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5325 system would be chosen by default for writing this text into a file.
5327 If OBJECT is a string, the most preferred coding system (see the
5328 command `prefer-coding-system') is used.
5330 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5331 guesswork fails. Normally, an error is signaled in such case. */)
5332 (object
, start
, end
, coding_system
, noerror
)
5333 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5335 unsigned char digest
[16];
5336 unsigned char value
[33];
5340 int start_char
= 0, end_char
= 0;
5341 int start_byte
= 0, end_byte
= 0;
5343 register struct buffer
*bp
;
5346 if (STRINGP (object
))
5348 if (NILP (coding_system
))
5350 /* Decide the coding-system to encode the data with. */
5352 if (STRING_MULTIBYTE (object
))
5353 /* use default, we can't guess correct value */
5354 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5356 coding_system
= Qraw_text
;
5359 if (NILP (Fcoding_system_p (coding_system
)))
5361 /* Invalid coding system. */
5363 if (!NILP (noerror
))
5364 coding_system
= Qraw_text
;
5367 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5370 if (STRING_MULTIBYTE (object
))
5371 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5373 size
= SCHARS (object
);
5374 size_byte
= SBYTES (object
);
5378 CHECK_NUMBER (start
);
5380 start_char
= XINT (start
);
5385 start_byte
= string_char_to_byte (object
, start_char
);
5391 end_byte
= size_byte
;
5397 end_char
= XINT (end
);
5402 end_byte
= string_char_to_byte (object
, end_char
);
5405 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5406 args_out_of_range_3 (object
, make_number (start_char
),
5407 make_number (end_char
));
5411 CHECK_BUFFER (object
);
5413 bp
= XBUFFER (object
);
5419 CHECK_NUMBER_COERCE_MARKER (start
);
5427 CHECK_NUMBER_COERCE_MARKER (end
);
5432 temp
= b
, b
= e
, e
= temp
;
5434 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5435 args_out_of_range (start
, end
);
5437 if (NILP (coding_system
))
5439 /* Decide the coding-system to encode the data with.
5440 See fileio.c:Fwrite-region */
5442 if (!NILP (Vcoding_system_for_write
))
5443 coding_system
= Vcoding_system_for_write
;
5446 int force_raw_text
= 0;
5448 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5449 if (NILP (coding_system
)
5450 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5452 coding_system
= Qnil
;
5453 if (NILP (current_buffer
->enable_multibyte_characters
))
5457 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5459 /* Check file-coding-system-alist. */
5460 Lisp_Object args
[4], val
;
5462 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5463 args
[3] = Fbuffer_file_name(object
);
5464 val
= Ffind_operation_coding_system (4, args
);
5465 if (CONSP (val
) && !NILP (XCDR (val
)))
5466 coding_system
= XCDR (val
);
5469 if (NILP (coding_system
)
5470 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5472 /* If we still have not decided a coding system, use the
5473 default value of buffer-file-coding-system. */
5474 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5478 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5479 /* Confirm that VAL can surely encode the current region. */
5480 coding_system
= call4 (Vselect_safe_coding_system_function
,
5481 make_number (b
), make_number (e
),
5482 coding_system
, Qnil
);
5485 coding_system
= Qraw_text
;
5488 if (NILP (Fcoding_system_p (coding_system
)))
5490 /* Invalid coding system. */
5492 if (!NILP (noerror
))
5493 coding_system
= Qraw_text
;
5496 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5500 object
= make_buffer_string (b
, e
, 0);
5502 if (STRING_MULTIBYTE (object
))
5503 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5506 md5_buffer (SDATA (object
) + start_byte
,
5507 SBYTES (object
) - (size_byte
- end_byte
),
5510 for (i
= 0; i
< 16; i
++)
5511 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5514 return make_string (value
, 32);
5521 /* Hash table stuff. */
5522 Qhash_table_p
= intern ("hash-table-p");
5523 staticpro (&Qhash_table_p
);
5524 Qeq
= intern ("eq");
5526 Qeql
= intern ("eql");
5528 Qequal
= intern ("equal");
5529 staticpro (&Qequal
);
5530 QCtest
= intern (":test");
5531 staticpro (&QCtest
);
5532 QCsize
= intern (":size");
5533 staticpro (&QCsize
);
5534 QCrehash_size
= intern (":rehash-size");
5535 staticpro (&QCrehash_size
);
5536 QCrehash_threshold
= intern (":rehash-threshold");
5537 staticpro (&QCrehash_threshold
);
5538 QCweakness
= intern (":weakness");
5539 staticpro (&QCweakness
);
5540 Qkey
= intern ("key");
5542 Qvalue
= intern ("value");
5543 staticpro (&Qvalue
);
5544 Qhash_table_test
= intern ("hash-table-test");
5545 staticpro (&Qhash_table_test
);
5546 Qkey_or_value
= intern ("key-or-value");
5547 staticpro (&Qkey_or_value
);
5548 Qkey_and_value
= intern ("key-and-value");
5549 staticpro (&Qkey_and_value
);
5552 defsubr (&Smake_hash_table
);
5553 defsubr (&Scopy_hash_table
);
5554 defsubr (&Shash_table_count
);
5555 defsubr (&Shash_table_rehash_size
);
5556 defsubr (&Shash_table_rehash_threshold
);
5557 defsubr (&Shash_table_size
);
5558 defsubr (&Shash_table_test
);
5559 defsubr (&Shash_table_weakness
);
5560 defsubr (&Shash_table_p
);
5561 defsubr (&Sclrhash
);
5562 defsubr (&Sgethash
);
5563 defsubr (&Sputhash
);
5564 defsubr (&Sremhash
);
5565 defsubr (&Smaphash
);
5566 defsubr (&Sdefine_hash_table_test
);
5568 Qstring_lessp
= intern ("string-lessp");
5569 staticpro (&Qstring_lessp
);
5570 Qprovide
= intern ("provide");
5571 staticpro (&Qprovide
);
5572 Qrequire
= intern ("require");
5573 staticpro (&Qrequire
);
5574 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5575 staticpro (&Qyes_or_no_p_history
);
5576 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5577 staticpro (&Qcursor_in_echo_area
);
5578 Qwidget_type
= intern ("widget-type");
5579 staticpro (&Qwidget_type
);
5581 staticpro (&string_char_byte_cache_string
);
5582 string_char_byte_cache_string
= Qnil
;
5584 require_nesting_list
= Qnil
;
5585 staticpro (&require_nesting_list
);
5587 Fset (Qyes_or_no_p_history
, Qnil
);
5589 DEFVAR_LISP ("features", &Vfeatures
,
5590 doc
: /* A list of symbols which are the features of the executing emacs.
5591 Used by `featurep' and `require', and altered by `provide'. */);
5593 Qsubfeatures
= intern ("subfeatures");
5594 staticpro (&Qsubfeatures
);
5596 #ifdef HAVE_LANGINFO_CODESET
5597 Qcodeset
= intern ("codeset");
5598 staticpro (&Qcodeset
);
5599 Qdays
= intern ("days");
5601 Qmonths
= intern ("months");
5602 staticpro (&Qmonths
);
5603 Qpaper
= intern ("paper");
5604 staticpro (&Qpaper
);
5605 #endif /* HAVE_LANGINFO_CODESET */
5607 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5608 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5609 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5610 invoked by mouse clicks and mouse menu items. */);
5613 defsubr (&Sidentity
);
5616 defsubr (&Ssafe_length
);
5617 defsubr (&Sstring_bytes
);
5618 defsubr (&Sstring_equal
);
5619 defsubr (&Scompare_strings
);
5620 defsubr (&Sstring_lessp
);
5623 defsubr (&Svconcat
);
5624 defsubr (&Scopy_sequence
);
5625 defsubr (&Sstring_make_multibyte
);
5626 defsubr (&Sstring_make_unibyte
);
5627 defsubr (&Sstring_as_multibyte
);
5628 defsubr (&Sstring_as_unibyte
);
5629 defsubr (&Sstring_to_multibyte
);
5630 defsubr (&Scopy_alist
);
5631 defsubr (&Ssubstring
);
5632 defsubr (&Ssubstring_no_properties
);
5644 defsubr (&Snreverse
);
5645 defsubr (&Sreverse
);
5647 defsubr (&Splist_get
);
5649 defsubr (&Splist_put
);
5651 defsubr (&Slax_plist_get
);
5652 defsubr (&Slax_plist_put
);
5654 defsubr (&Sfillarray
);
5655 defsubr (&Schar_table_subtype
);
5656 defsubr (&Schar_table_parent
);
5657 defsubr (&Sset_char_table_parent
);
5658 defsubr (&Schar_table_extra_slot
);
5659 defsubr (&Sset_char_table_extra_slot
);
5660 defsubr (&Schar_table_range
);
5661 defsubr (&Sset_char_table_range
);
5662 defsubr (&Sset_char_table_default
);
5663 defsubr (&Soptimize_char_table
);
5664 defsubr (&Smap_char_table
);
5668 defsubr (&Smapconcat
);
5669 defsubr (&Sy_or_n_p
);
5670 defsubr (&Syes_or_no_p
);
5671 defsubr (&Sload_average
);
5672 defsubr (&Sfeaturep
);
5673 defsubr (&Srequire
);
5674 defsubr (&Sprovide
);
5675 defsubr (&Splist_member
);
5676 defsubr (&Swidget_put
);
5677 defsubr (&Swidget_get
);
5678 defsubr (&Swidget_apply
);
5679 defsubr (&Sbase64_encode_region
);
5680 defsubr (&Sbase64_decode_region
);
5681 defsubr (&Sbase64_encode_string
);
5682 defsubr (&Sbase64_decode_string
);
5684 defsubr (&Slanginfo
);
5691 Vweak_hash_tables
= Qnil
;