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
);
2701 elt
= XCHAR_TABLE (subtable
)->defalt
;
2703 elt
= Faref (table
, make_number (i
));
2704 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2705 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2706 c
= MAKE_CHAR (charset
, c1
, c2
);
2708 (*c_function
) (arg
, make_number (c
), elt
);
2710 call2 (function
, make_number (c
), elt
);
2715 static void void_call2
P_ ((Lisp_Object a
, Lisp_Object b
, Lisp_Object c
));
2717 void_call2 (a
, b
, c
)
2718 Lisp_Object a
, b
, c
;
2723 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2725 doc
: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
2726 FUNCTION is called with two arguments--a key and a value.
2727 The key is always a possible IDX argument to `aref'. */)
2728 (function
, char_table
)
2729 Lisp_Object function
, char_table
;
2731 /* The depth of char table is at most 3. */
2732 Lisp_Object indices
[3];
2734 CHECK_CHAR_TABLE (char_table
);
2736 /* When Lisp_Object is represented as a union, `call2' cannot directly
2737 be passed to map_char_table because it returns a Lisp_Object rather
2738 than returning nothing.
2739 Casting leads to crashes on some architectures. -stef */
2740 map_char_table (void_call2
, Qnil
, char_table
, char_table
, function
, 0, indices
);
2744 /* Return a value for character C in char-table TABLE. Store the
2745 actual index for that value in *IDX. Ignore the default value of
2749 char_table_ref_and_index (table
, c
, idx
)
2753 int charset
, c1
, c2
;
2756 if (SINGLE_BYTE_CHAR_P (c
))
2759 return XCHAR_TABLE (table
)->contents
[c
];
2761 SPLIT_CHAR (c
, charset
, c1
, c2
);
2762 elt
= XCHAR_TABLE (table
)->contents
[charset
+ 128];
2763 *idx
= MAKE_CHAR (charset
, 0, 0);
2764 if (!SUB_CHAR_TABLE_P (elt
))
2766 if (c1
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c1
]))
2767 return XCHAR_TABLE (elt
)->defalt
;
2768 elt
= XCHAR_TABLE (elt
)->contents
[c1
];
2769 *idx
= MAKE_CHAR (charset
, c1
, 0);
2770 if (!SUB_CHAR_TABLE_P (elt
))
2772 if (c2
< 32 || NILP (XCHAR_TABLE (elt
)->contents
[c2
]))
2773 return XCHAR_TABLE (elt
)->defalt
;
2775 return XCHAR_TABLE (elt
)->contents
[c2
];
2785 Lisp_Object args
[2];
2788 return Fnconc (2, args
);
2790 return Fnconc (2, &s1
);
2791 #endif /* NO_ARG_ARRAY */
2794 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2795 doc
: /* Concatenate any number of lists by altering them.
2796 Only the last argument is not altered, and need not be a list.
2797 usage: (nconc &rest LISTS) */)
2802 register int argnum
;
2803 register Lisp_Object tail
, tem
, val
;
2807 for (argnum
= 0; argnum
< nargs
; argnum
++)
2810 if (NILP (tem
)) continue;
2815 if (argnum
+ 1 == nargs
) break;
2818 tem
= wrong_type_argument (Qlistp
, tem
);
2827 tem
= args
[argnum
+ 1];
2828 Fsetcdr (tail
, tem
);
2830 args
[argnum
+ 1] = tail
;
2836 /* This is the guts of all mapping functions.
2837 Apply FN to each element of SEQ, one by one,
2838 storing the results into elements of VALS, a C vector of Lisp_Objects.
2839 LENI is the length of VALS, which should also be the length of SEQ. */
2842 mapcar1 (leni
, vals
, fn
, seq
)
2845 Lisp_Object fn
, seq
;
2847 register Lisp_Object tail
;
2850 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2854 /* Don't let vals contain any garbage when GC happens. */
2855 for (i
= 0; i
< leni
; i
++)
2858 GCPRO3 (dummy
, fn
, seq
);
2860 gcpro1
.nvars
= leni
;
2864 /* We need not explicitly protect `tail' because it is used only on lists, and
2865 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2869 for (i
= 0; i
< leni
; i
++)
2871 dummy
= XVECTOR (seq
)->contents
[i
];
2872 dummy
= call1 (fn
, dummy
);
2877 else if (BOOL_VECTOR_P (seq
))
2879 for (i
= 0; i
< leni
; i
++)
2882 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2883 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2888 dummy
= call1 (fn
, dummy
);
2893 else if (STRINGP (seq
))
2897 for (i
= 0, i_byte
= 0; i
< leni
;)
2902 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2903 XSETFASTINT (dummy
, c
);
2904 dummy
= call1 (fn
, dummy
);
2906 vals
[i_before
] = dummy
;
2909 else /* Must be a list, since Flength did not get an error */
2912 for (i
= 0; i
< leni
; i
++)
2914 dummy
= call1 (fn
, Fcar (tail
));
2924 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2925 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2926 In between each pair of results, stick in SEPARATOR. Thus, " " as
2927 SEPARATOR results in spaces between the values returned by FUNCTION.
2928 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2929 (function
, sequence
, separator
)
2930 Lisp_Object function
, sequence
, separator
;
2935 register Lisp_Object
*args
;
2937 struct gcpro gcpro1
;
2939 len
= Flength (sequence
);
2941 nargs
= leni
+ leni
- 1;
2942 if (nargs
< 0) return build_string ("");
2944 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2947 mapcar1 (leni
, args
, function
, sequence
);
2950 for (i
= leni
- 1; i
>= 0; i
--)
2951 args
[i
+ i
] = args
[i
];
2953 for (i
= 1; i
< nargs
; i
+= 2)
2954 args
[i
] = separator
;
2956 return Fconcat (nargs
, args
);
2959 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2960 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2961 The result is a list just as long as SEQUENCE.
2962 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2963 (function
, sequence
)
2964 Lisp_Object function
, sequence
;
2966 register Lisp_Object len
;
2968 register Lisp_Object
*args
;
2970 len
= Flength (sequence
);
2971 leni
= XFASTINT (len
);
2972 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2974 mapcar1 (leni
, args
, function
, sequence
);
2976 return Flist (leni
, args
);
2979 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2980 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2981 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2982 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2983 (function
, sequence
)
2984 Lisp_Object function
, sequence
;
2988 leni
= XFASTINT (Flength (sequence
));
2989 mapcar1 (leni
, 0, function
, sequence
);
2994 /* Anything that calls this function must protect from GC! */
2996 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2997 doc
: /* Ask user a "y or n" question. Return t if answer is "y".
2998 Takes one argument, which is the string to display to ask the question.
2999 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
3000 No confirmation of the answer is requested; a single character is enough.
3001 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
3002 the bindings in `query-replace-map'; see the documentation of that variable
3003 for more information. In this case, the useful bindings are `act', `skip',
3004 `recenter', and `quit'.\)
3006 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3007 is nil and `use-dialog-box' is non-nil. */)
3011 register Lisp_Object obj
, key
, def
, map
;
3012 register int answer
;
3013 Lisp_Object xprompt
;
3014 Lisp_Object args
[2];
3015 struct gcpro gcpro1
, gcpro2
;
3016 int count
= SPECPDL_INDEX ();
3018 specbind (Qcursor_in_echo_area
, Qt
);
3020 map
= Fsymbol_value (intern ("query-replace-map"));
3022 CHECK_STRING (prompt
);
3024 GCPRO2 (prompt
, xprompt
);
3026 #ifdef HAVE_X_WINDOWS
3027 if (display_hourglass_p
)
3028 cancel_hourglass ();
3035 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3039 Lisp_Object pane
, menu
;
3040 redisplay_preserve_echo_area (3);
3041 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3042 Fcons (Fcons (build_string ("No"), Qnil
),
3044 menu
= Fcons (prompt
, pane
);
3045 obj
= Fx_popup_dialog (Qt
, menu
);
3046 answer
= !NILP (obj
);
3049 #endif /* HAVE_MENUS */
3050 cursor_in_echo_area
= 1;
3051 choose_minibuf_frame ();
3054 Lisp_Object pargs
[3];
3056 /* Colorize prompt according to `minibuffer-prompt' face. */
3057 pargs
[0] = build_string ("%s(y or n) ");
3058 pargs
[1] = intern ("face");
3059 pargs
[2] = intern ("minibuffer-prompt");
3060 args
[0] = Fpropertize (3, pargs
);
3065 if (minibuffer_auto_raise
)
3067 Lisp_Object mini_frame
;
3069 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
3071 Fraise_frame (mini_frame
);
3074 obj
= read_filtered_event (1, 0, 0, 0);
3075 cursor_in_echo_area
= 0;
3076 /* If we need to quit, quit with cursor_in_echo_area = 0. */
3079 key
= Fmake_vector (make_number (1), obj
);
3080 def
= Flookup_key (map
, key
, Qt
);
3082 if (EQ (def
, intern ("skip")))
3087 else if (EQ (def
, intern ("act")))
3092 else if (EQ (def
, intern ("recenter")))
3098 else if (EQ (def
, intern ("quit")))
3100 /* We want to exit this command for exit-prefix,
3101 and this is the only way to do it. */
3102 else if (EQ (def
, intern ("exit-prefix")))
3107 /* If we don't clear this, then the next call to read_char will
3108 return quit_char again, and we'll enter an infinite loop. */
3113 if (EQ (xprompt
, prompt
))
3115 args
[0] = build_string ("Please answer y or n. ");
3117 xprompt
= Fconcat (2, args
);
3122 if (! noninteractive
)
3124 cursor_in_echo_area
= -1;
3125 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
3129 unbind_to (count
, Qnil
);
3130 return answer
? Qt
: Qnil
;
3133 /* This is how C code calls `yes-or-no-p' and allows the user
3136 Anything that calls this function must protect from GC! */
3139 do_yes_or_no_p (prompt
)
3142 return call1 (intern ("yes-or-no-p"), prompt
);
3145 /* Anything that calls this function must protect from GC! */
3147 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
3148 doc
: /* Ask user a yes-or-no question. Return t if answer is yes.
3149 Takes one argument, which is the string to display to ask the question.
3150 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
3151 The user must confirm the answer with RET,
3152 and can edit it until it has been confirmed.
3154 Under a windowing system a dialog box will be used if `last-nonmenu-event'
3155 is nil, and `use-dialog-box' is non-nil. */)
3159 register Lisp_Object ans
;
3160 Lisp_Object args
[2];
3161 struct gcpro gcpro1
;
3163 CHECK_STRING (prompt
);
3166 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3170 Lisp_Object pane
, menu
, obj
;
3171 redisplay_preserve_echo_area (4);
3172 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
3173 Fcons (Fcons (build_string ("No"), Qnil
),
3176 menu
= Fcons (prompt
, pane
);
3177 obj
= Fx_popup_dialog (Qt
, menu
);
3181 #endif /* HAVE_MENUS */
3184 args
[1] = build_string ("(yes or no) ");
3185 prompt
= Fconcat (2, args
);
3191 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
3192 Qyes_or_no_p_history
, Qnil
,
3194 if (SCHARS (ans
) == 3 && !strcmp (SDATA (ans
), "yes"))
3199 if (SCHARS (ans
) == 2 && !strcmp (SDATA (ans
), "no"))
3207 message ("Please answer yes or no.");
3208 Fsleep_for (make_number (2), Qnil
);
3212 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
3213 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
3215 Each of the three load averages is multiplied by 100, then converted
3218 When USE-FLOATS is non-nil, floats will be used instead of integers.
3219 These floats are not multiplied by 100.
3221 If the 5-minute or 15-minute load averages are not available, return a
3222 shortened list, containing only those averages which are available. */)
3224 Lisp_Object use_floats
;
3227 int loads
= getloadavg (load_ave
, 3);
3228 Lisp_Object ret
= Qnil
;
3231 error ("load-average not implemented for this operating system");
3235 Lisp_Object load
= (NILP (use_floats
) ?
3236 make_number ((int) (100.0 * load_ave
[loads
]))
3237 : make_float (load_ave
[loads
]));
3238 ret
= Fcons (load
, ret
);
3244 Lisp_Object Vfeatures
, Qsubfeatures
;
3245 extern Lisp_Object Vafter_load_alist
;
3247 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
3248 doc
: /* Returns t if FEATURE is present in this Emacs.
3250 Use this to conditionalize execution of lisp code based on the
3251 presence or absence of emacs or environment extensions.
3252 Use `provide' to declare that a feature is available. This function
3253 looks at the value of the variable `features'. The optional argument
3254 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
3255 (feature
, subfeature
)
3256 Lisp_Object feature
, subfeature
;
3258 register Lisp_Object tem
;
3259 CHECK_SYMBOL (feature
);
3260 tem
= Fmemq (feature
, Vfeatures
);
3261 if (!NILP (tem
) && !NILP (subfeature
))
3262 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
3263 return (NILP (tem
)) ? Qnil
: Qt
;
3266 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
3267 doc
: /* Announce that FEATURE is a feature of the current Emacs.
3268 The optional argument SUBFEATURES should be a list of symbols listing
3269 particular subfeatures supported in this version of FEATURE. */)
3270 (feature
, subfeatures
)
3271 Lisp_Object feature
, subfeatures
;
3273 register Lisp_Object tem
;
3274 CHECK_SYMBOL (feature
);
3275 CHECK_LIST (subfeatures
);
3276 if (!NILP (Vautoload_queue
))
3277 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
3278 tem
= Fmemq (feature
, Vfeatures
);
3280 Vfeatures
= Fcons (feature
, Vfeatures
);
3281 if (!NILP (subfeatures
))
3282 Fput (feature
, Qsubfeatures
, subfeatures
);
3283 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
3285 /* Run any load-hooks for this file. */
3286 tem
= Fassq (feature
, Vafter_load_alist
);
3288 Fprogn (XCDR (tem
));
3293 /* `require' and its subroutines. */
3295 /* List of features currently being require'd, innermost first. */
3297 Lisp_Object require_nesting_list
;
3300 require_unwind (old_value
)
3301 Lisp_Object old_value
;
3303 return require_nesting_list
= old_value
;
3306 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
3307 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
3308 If FEATURE is not a member of the list `features', then the feature
3309 is not loaded; so load the file FILENAME.
3310 If FILENAME is omitted, the printname of FEATURE is used as the file name,
3311 and `load' will try to load this name appended with the suffix `.elc',
3312 `.el' or the unmodified name, in that order.
3313 If the optional third argument NOERROR is non-nil,
3314 then return nil if the file is not found instead of signaling an error.
3315 Normally the return value is FEATURE.
3316 The normal messages at start and end of loading FILENAME are suppressed. */)
3317 (feature
, filename
, noerror
)
3318 Lisp_Object feature
, filename
, noerror
;
3320 register Lisp_Object tem
;
3321 struct gcpro gcpro1
, gcpro2
;
3323 CHECK_SYMBOL (feature
);
3325 tem
= Fmemq (feature
, Vfeatures
);
3329 int count
= SPECPDL_INDEX ();
3332 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
3334 /* This is to make sure that loadup.el gives a clear picture
3335 of what files are preloaded and when. */
3336 if (! NILP (Vpurify_flag
))
3337 error ("(require %s) while preparing to dump",
3338 SDATA (SYMBOL_NAME (feature
)));
3340 /* A certain amount of recursive `require' is legitimate,
3341 but if we require the same feature recursively 3 times,
3343 tem
= require_nesting_list
;
3344 while (! NILP (tem
))
3346 if (! NILP (Fequal (feature
, XCAR (tem
))))
3351 error ("Recursive `require' for feature `%s'",
3352 SDATA (SYMBOL_NAME (feature
)));
3354 /* Update the list for any nested `require's that occur. */
3355 record_unwind_protect (require_unwind
, require_nesting_list
);
3356 require_nesting_list
= Fcons (feature
, require_nesting_list
);
3358 /* Value saved here is to be restored into Vautoload_queue */
3359 record_unwind_protect (un_autoload
, Vautoload_queue
);
3360 Vautoload_queue
= Qt
;
3362 /* Load the file. */
3363 GCPRO2 (feature
, filename
);
3364 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3365 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3368 /* If load failed entirely, return nil. */
3370 return unbind_to (count
, Qnil
);
3372 tem
= Fmemq (feature
, Vfeatures
);
3374 error ("Required feature `%s' was not provided",
3375 SDATA (SYMBOL_NAME (feature
)));
3377 /* Once loading finishes, don't undo it. */
3378 Vautoload_queue
= Qt
;
3379 feature
= unbind_to (count
, feature
);
3385 /* Primitives for work of the "widget" library.
3386 In an ideal world, this section would not have been necessary.
3387 However, lisp function calls being as slow as they are, it turns
3388 out that some functions in the widget library (wid-edit.el) are the
3389 bottleneck of Widget operation. Here is their translation to C,
3390 for the sole reason of efficiency. */
3392 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3393 doc
: /* Return non-nil if PLIST has the property PROP.
3394 PLIST is a property list, which is a list of the form
3395 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
3396 Unlike `plist-get', this allows you to distinguish between a missing
3397 property and a property with the value nil.
3398 The value is actually the tail of PLIST whose car is PROP. */)
3400 Lisp_Object plist
, prop
;
3402 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
3405 plist
= XCDR (plist
);
3406 plist
= CDR (plist
);
3411 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3412 doc
: /* In WIDGET, set PROPERTY to VALUE.
3413 The value can later be retrieved with `widget-get'. */)
3414 (widget
, property
, value
)
3415 Lisp_Object widget
, property
, value
;
3417 CHECK_CONS (widget
);
3418 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3422 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3423 doc
: /* In WIDGET, get the value of PROPERTY.
3424 The value could either be specified when the widget was created, or
3425 later with `widget-put'. */)
3427 Lisp_Object widget
, property
;
3435 CHECK_CONS (widget
);
3436 tmp
= Fplist_member (XCDR (widget
), property
);
3442 tmp
= XCAR (widget
);
3445 widget
= Fget (tmp
, Qwidget_type
);
3449 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3450 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3451 ARGS are passed as extra arguments to the function.
3452 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3457 /* This function can GC. */
3458 Lisp_Object newargs
[3];
3459 struct gcpro gcpro1
, gcpro2
;
3462 newargs
[0] = Fwidget_get (args
[0], args
[1]);
3463 newargs
[1] = args
[0];
3464 newargs
[2] = Flist (nargs
- 2, args
+ 2);
3465 GCPRO2 (newargs
[0], newargs
[2]);
3466 result
= Fapply (3, newargs
);
3471 #ifdef HAVE_LANGINFO_CODESET
3472 #include <langinfo.h>
3475 DEFUN ("langinfo", Flanginfo
, Slanginfo
, 1, 1, 0,
3476 doc
: /* Access locale data ITEM, if available.
3478 ITEM may be one of the following:
3479 `codeset', returning the character set as a string (locale item CODESET);
3480 `days', returning a 7-element vector of day names (locale items DAY_n);
3481 `months', returning a 12-element vector of month names (locale items MON_n);
3482 `paper', returning a list (WIDTH, HEIGHT) for the default paper size,
3483 where the width and height are in mm (locale items PAPER_WIDTH,
3486 If the system can't provide such information through a call to
3487 nl_langinfo(3), return nil.
3489 See also Info node `(libc)Locales'.
3491 The data read from the system are decoded using `locale-coding-system'. */)
3496 #ifdef HAVE_LANGINFO_CODESET
3498 if (EQ (item
, Qcodeset
))
3500 str
= nl_langinfo (CODESET
);
3501 return build_string (str
);
3504 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3506 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3507 int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3509 synchronize_system_time_locale ();
3510 for (i
= 0; i
< 7; i
++)
3512 str
= nl_langinfo (days
[i
]);
3513 val
= make_unibyte_string (str
, strlen (str
));
3514 /* Fixme: Is this coding system necessarily right, even if
3515 it is consistent with CODESET? If not, what to do? */
3516 Faset (v
, make_number (i
),
3517 code_convert_string_norecord (val
, Vlocale_coding_system
,
3524 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3526 struct Lisp_Vector
*p
= allocate_vector (12);
3527 int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3528 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3530 synchronize_system_time_locale ();
3531 for (i
= 0; i
< 12; i
++)
3533 str
= nl_langinfo (months
[i
]);
3534 val
= make_unibyte_string (str
, strlen (str
));
3536 code_convert_string_norecord (val
, Vlocale_coding_system
, 0);
3538 XSETVECTOR (val
, p
);
3542 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3543 but is in the locale files. This could be used by ps-print. */
3545 else if (EQ (item
, Qpaper
))
3547 return list2 (make_number (nl_langinfo (PAPER_WIDTH
)),
3548 make_number (nl_langinfo (PAPER_HEIGHT
)));
3550 #endif /* PAPER_WIDTH */
3551 #endif /* HAVE_LANGINFO_CODESET*/
3555 /* base64 encode/decode functions (RFC 2045).
3556 Based on code from GNU recode. */
3558 #define MIME_LINE_LENGTH 76
3560 #define IS_ASCII(Character) \
3562 #define IS_BASE64(Character) \
3563 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3564 #define IS_BASE64_IGNORABLE(Character) \
3565 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3566 || (Character) == '\f' || (Character) == '\r')
3568 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3569 character or return retval if there are no characters left to
3571 #define READ_QUADRUPLET_BYTE(retval) \
3576 if (nchars_return) \
3577 *nchars_return = nchars; \
3582 while (IS_BASE64_IGNORABLE (c))
3584 /* Don't use alloca for regions larger than this, lest we overflow
3586 #define MAX_ALLOCA 16*1024
3588 /* Table of characters coding the 64 values. */
3589 static char base64_value_to_char
[64] =
3591 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3592 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3593 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3594 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3595 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3596 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3597 '8', '9', '+', '/' /* 60-63 */
3600 /* Table of base64 values for first 128 characters. */
3601 static short base64_char_to_value
[128] =
3603 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3604 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3605 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3606 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3607 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3608 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3609 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3610 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3611 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3612 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3613 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3614 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3615 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3618 /* The following diagram shows the logical steps by which three octets
3619 get transformed into four base64 characters.
3621 .--------. .--------. .--------.
3622 |aaaaaabb| |bbbbcccc| |ccdddddd|
3623 `--------' `--------' `--------'
3625 .--------+--------+--------+--------.
3626 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3627 `--------+--------+--------+--------'
3629 .--------+--------+--------+--------.
3630 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3631 `--------+--------+--------+--------'
3633 The octets are divided into 6 bit chunks, which are then encoded into
3634 base64 characters. */
3637 static int base64_encode_1
P_ ((const char *, char *, int, int, int));
3638 static int base64_decode_1
P_ ((const char *, char *, int, int, int *));
3640 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3642 doc
: /* Base64-encode the region between BEG and END.
3643 Return the length of the encoded text.
3644 Optional third argument NO-LINE-BREAK means do not break long lines
3645 into shorter lines. */)
3646 (beg
, end
, no_line_break
)
3647 Lisp_Object beg
, end
, no_line_break
;
3650 int allength
, length
;
3651 int ibeg
, iend
, encoded_length
;
3654 validate_region (&beg
, &end
);
3656 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3657 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3658 move_gap_both (XFASTINT (beg
), ibeg
);
3660 /* We need to allocate enough room for encoding the text.
3661 We need 33 1/3% more space, plus a newline every 76
3662 characters, and then we round up. */
3663 length
= iend
- ibeg
;
3664 allength
= length
+ length
/3 + 1;
3665 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3667 if (allength
<= MAX_ALLOCA
)
3668 encoded
= (char *) alloca (allength
);
3670 encoded
= (char *) xmalloc (allength
);
3671 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
3672 NILP (no_line_break
),
3673 !NILP (current_buffer
->enable_multibyte_characters
));
3674 if (encoded_length
> allength
)
3677 if (encoded_length
< 0)
3679 /* The encoding wasn't possible. */
3680 if (length
> MAX_ALLOCA
)
3682 error ("Multibyte character in data for base64 encoding");
3685 /* Now we have encoded the region, so we insert the new contents
3686 and delete the old. (Insert first in order to preserve markers.) */
3687 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3688 insert (encoded
, encoded_length
);
3689 if (allength
> MAX_ALLOCA
)
3691 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
3693 /* If point was outside of the region, restore it exactly; else just
3694 move to the beginning of the region. */
3695 if (old_pos
>= XFASTINT (end
))
3696 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3697 else if (old_pos
> XFASTINT (beg
))
3698 old_pos
= XFASTINT (beg
);
3701 /* We return the length of the encoded text. */
3702 return make_number (encoded_length
);
3705 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3707 doc
: /* Base64-encode STRING and return the result.
3708 Optional second argument NO-LINE-BREAK means do not break long lines
3709 into shorter lines. */)
3710 (string
, no_line_break
)
3711 Lisp_Object string
, no_line_break
;
3713 int allength
, length
, encoded_length
;
3715 Lisp_Object encoded_string
;
3717 CHECK_STRING (string
);
3719 /* We need to allocate enough room for encoding the text.
3720 We need 33 1/3% more space, plus a newline every 76
3721 characters, and then we round up. */
3722 length
= SBYTES (string
);
3723 allength
= length
+ length
/3 + 1;
3724 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3726 /* We need to allocate enough room for decoding the text. */
3727 if (allength
<= MAX_ALLOCA
)
3728 encoded
= (char *) alloca (allength
);
3730 encoded
= (char *) xmalloc (allength
);
3732 encoded_length
= base64_encode_1 (SDATA (string
),
3733 encoded
, length
, NILP (no_line_break
),
3734 STRING_MULTIBYTE (string
));
3735 if (encoded_length
> allength
)
3738 if (encoded_length
< 0)
3740 /* The encoding wasn't possible. */
3741 if (length
> MAX_ALLOCA
)
3743 error ("Multibyte character in data for base64 encoding");
3746 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3747 if (allength
> MAX_ALLOCA
)
3750 return encoded_string
;
3754 base64_encode_1 (from
, to
, length
, line_break
, multibyte
)
3761 int counter
= 0, i
= 0;
3771 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3779 /* Wrap line every 76 characters. */
3783 if (counter
< MIME_LINE_LENGTH
/ 4)
3792 /* Process first byte of a triplet. */
3794 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3795 value
= (0x03 & c
) << 4;
3797 /* Process second byte of a triplet. */
3801 *e
++ = base64_value_to_char
[value
];
3809 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3817 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3818 value
= (0x0f & c
) << 2;
3820 /* Process third byte of a triplet. */
3824 *e
++ = base64_value_to_char
[value
];
3831 c
= STRING_CHAR_AND_LENGTH (from
+ i
, length
- i
, bytes
);
3839 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3840 *e
++ = base64_value_to_char
[0x3f & c
];
3847 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3849 doc
: /* Base64-decode the region between BEG and END.
3850 Return the length of the decoded text.
3851 If the region can't be decoded, signal an error and don't modify the buffer. */)
3853 Lisp_Object beg
, end
;
3855 int ibeg
, iend
, length
, allength
;
3860 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
3862 validate_region (&beg
, &end
);
3864 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3865 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3867 length
= iend
- ibeg
;
3869 /* We need to allocate enough room for decoding the text. If we are
3870 working on a multibyte buffer, each decoded code may occupy at
3872 allength
= multibyte
? length
* 2 : length
;
3873 if (allength
<= MAX_ALLOCA
)
3874 decoded
= (char *) alloca (allength
);
3876 decoded
= (char *) xmalloc (allength
);
3878 move_gap_both (XFASTINT (beg
), ibeg
);
3879 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
,
3880 multibyte
, &inserted_chars
);
3881 if (decoded_length
> allength
)
3884 if (decoded_length
< 0)
3886 /* The decoding wasn't possible. */
3887 if (allength
> MAX_ALLOCA
)
3889 error ("Invalid base64 data");
3892 /* Now we have decoded the region, so we insert the new contents
3893 and delete the old. (Insert first in order to preserve markers.) */
3894 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3895 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3896 if (allength
> MAX_ALLOCA
)
3898 /* Delete the original text. */
3899 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3900 iend
+ decoded_length
, 1);
3902 /* If point was outside of the region, restore it exactly; else just
3903 move to the beginning of the region. */
3904 if (old_pos
>= XFASTINT (end
))
3905 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3906 else if (old_pos
> XFASTINT (beg
))
3907 old_pos
= XFASTINT (beg
);
3908 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3910 return make_number (inserted_chars
);
3913 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3915 doc
: /* Base64-decode STRING and return the result. */)
3920 int length
, decoded_length
;
3921 Lisp_Object decoded_string
;
3923 CHECK_STRING (string
);
3925 length
= SBYTES (string
);
3926 /* We need to allocate enough room for decoding the text. */
3927 if (length
<= MAX_ALLOCA
)
3928 decoded
= (char *) alloca (length
);
3930 decoded
= (char *) xmalloc (length
);
3932 /* The decoded result should be unibyte. */
3933 decoded_length
= base64_decode_1 (SDATA (string
), decoded
, length
,
3935 if (decoded_length
> length
)
3937 else if (decoded_length
>= 0)
3938 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3940 decoded_string
= Qnil
;
3942 if (length
> MAX_ALLOCA
)
3944 if (!STRINGP (decoded_string
))
3945 error ("Invalid base64 data");
3947 return decoded_string
;
3950 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
3951 MULTIBYTE is nonzero, the decoded result should be in multibyte
3952 form. If NCHARS_RETRUN is not NULL, store the number of produced
3953 characters in *NCHARS_RETURN. */
3956 base64_decode_1 (from
, to
, length
, multibyte
, nchars_return
)
3966 unsigned long value
;
3971 /* Process first byte of a quadruplet. */
3973 READ_QUADRUPLET_BYTE (e
-to
);
3977 value
= base64_char_to_value
[c
] << 18;
3979 /* Process second byte of a quadruplet. */
3981 READ_QUADRUPLET_BYTE (-1);
3985 value
|= base64_char_to_value
[c
] << 12;
3987 c
= (unsigned char) (value
>> 16);
3989 e
+= CHAR_STRING (c
, e
);
3994 /* Process third byte of a quadruplet. */
3996 READ_QUADRUPLET_BYTE (-1);
4000 READ_QUADRUPLET_BYTE (-1);
4009 value
|= base64_char_to_value
[c
] << 6;
4011 c
= (unsigned char) (0xff & value
>> 8);
4013 e
+= CHAR_STRING (c
, e
);
4018 /* Process fourth byte of a quadruplet. */
4020 READ_QUADRUPLET_BYTE (-1);
4027 value
|= base64_char_to_value
[c
];
4029 c
= (unsigned char) (0xff & value
);
4031 e
+= CHAR_STRING (c
, e
);
4040 /***********************************************************************
4042 ***** Hash Tables *****
4044 ***********************************************************************/
4046 /* Implemented by gerd@gnu.org. This hash table implementation was
4047 inspired by CMUCL hash tables. */
4051 1. For small tables, association lists are probably faster than
4052 hash tables because they have lower overhead.
4054 For uses of hash tables where the O(1) behavior of table
4055 operations is not a requirement, it might therefore be a good idea
4056 not to hash. Instead, we could just do a linear search in the
4057 key_and_value vector of the hash table. This could be done
4058 if a `:linear-search t' argument is given to make-hash-table. */
4061 /* The list of all weak hash tables. Don't staticpro this one. */
4063 Lisp_Object Vweak_hash_tables
;
4065 /* Various symbols. */
4067 Lisp_Object Qhash_table_p
, Qeq
, Qeql
, Qequal
, Qkey
, Qvalue
;
4068 Lisp_Object QCtest
, QCsize
, QCrehash_size
, QCrehash_threshold
, QCweakness
;
4069 Lisp_Object Qhash_table_test
, Qkey_or_value
, Qkey_and_value
;
4071 /* Function prototypes. */
4073 static struct Lisp_Hash_Table
*check_hash_table
P_ ((Lisp_Object
));
4074 static int get_key_arg
P_ ((Lisp_Object
, int, Lisp_Object
*, char *));
4075 static void maybe_resize_hash_table
P_ ((struct Lisp_Hash_Table
*));
4076 static int cmpfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4077 Lisp_Object
, unsigned));
4078 static int cmpfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
, unsigned,
4079 Lisp_Object
, unsigned));
4080 static int cmpfn_user_defined
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
,
4081 unsigned, Lisp_Object
, unsigned));
4082 static unsigned hashfn_eq
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4083 static unsigned hashfn_eql
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4084 static unsigned hashfn_equal
P_ ((struct Lisp_Hash_Table
*, Lisp_Object
));
4085 static unsigned hashfn_user_defined
P_ ((struct Lisp_Hash_Table
*,
4087 static unsigned sxhash_string
P_ ((unsigned char *, int));
4088 static unsigned sxhash_list
P_ ((Lisp_Object
, int));
4089 static unsigned sxhash_vector
P_ ((Lisp_Object
, int));
4090 static unsigned sxhash_bool_vector
P_ ((Lisp_Object
));
4091 static int sweep_weak_table
P_ ((struct Lisp_Hash_Table
*, int));
4095 /***********************************************************************
4097 ***********************************************************************/
4099 /* If OBJ is a Lisp hash table, return a pointer to its struct
4100 Lisp_Hash_Table. Otherwise, signal an error. */
4102 static struct Lisp_Hash_Table
*
4103 check_hash_table (obj
)
4106 CHECK_HASH_TABLE (obj
);
4107 return XHASH_TABLE (obj
);
4111 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
4115 next_almost_prime (n
)
4128 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
4129 which USED[I] is non-zero. If found at index I in ARGS, set
4130 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
4131 -1. This function is used to extract a keyword/argument pair from
4132 a DEFUN parameter list. */
4135 get_key_arg (key
, nargs
, args
, used
)
4143 for (i
= 0; i
< nargs
- 1; ++i
)
4144 if (!used
[i
] && EQ (args
[i
], key
))
4159 /* Return a Lisp vector which has the same contents as VEC but has
4160 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
4161 vector that are not copied from VEC are set to INIT. */
4164 larger_vector (vec
, new_size
, init
)
4169 struct Lisp_Vector
*v
;
4172 xassert (VECTORP (vec
));
4173 old_size
= XVECTOR (vec
)->size
;
4174 xassert (new_size
>= old_size
);
4176 v
= allocate_vector (new_size
);
4177 bcopy (XVECTOR (vec
)->contents
, v
->contents
,
4178 old_size
* sizeof *v
->contents
);
4179 for (i
= old_size
; i
< new_size
; ++i
)
4180 v
->contents
[i
] = init
;
4181 XSETVECTOR (vec
, v
);
4186 /***********************************************************************
4188 ***********************************************************************/
4190 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4191 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
4192 KEY2 are the same. */
4195 cmpfn_eql (h
, key1
, hash1
, key2
, hash2
)
4196 struct Lisp_Hash_Table
*h
;
4197 Lisp_Object key1
, key2
;
4198 unsigned hash1
, hash2
;
4200 return (FLOATP (key1
)
4202 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
4206 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
4207 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
4208 KEY2 are the same. */
4211 cmpfn_equal (h
, key1
, hash1
, key2
, hash2
)
4212 struct Lisp_Hash_Table
*h
;
4213 Lisp_Object key1
, key2
;
4214 unsigned hash1
, hash2
;
4216 return hash1
== hash2
&& !NILP (Fequal (key1
, key2
));
4220 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
4221 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
4222 if KEY1 and KEY2 are the same. */
4225 cmpfn_user_defined (h
, key1
, hash1
, key2
, hash2
)
4226 struct Lisp_Hash_Table
*h
;
4227 Lisp_Object key1
, key2
;
4228 unsigned hash1
, hash2
;
4232 Lisp_Object args
[3];
4234 args
[0] = h
->user_cmp_function
;
4237 return !NILP (Ffuncall (3, args
));
4244 /* Value is a hash code for KEY for use in hash table H which uses
4245 `eq' to compare keys. The hash code returned is guaranteed to fit
4246 in a Lisp integer. */
4250 struct Lisp_Hash_Table
*h
;
4253 unsigned hash
= XUINT (key
) ^ XGCTYPE (key
);
4254 xassert ((hash
& ~VALMASK
) == 0);
4259 /* Value is a hash code for KEY for use in hash table H which uses
4260 `eql' to compare keys. The hash code returned is guaranteed to fit
4261 in a Lisp integer. */
4265 struct Lisp_Hash_Table
*h
;
4270 hash
= sxhash (key
, 0);
4272 hash
= XUINT (key
) ^ XGCTYPE (key
);
4273 xassert ((hash
& ~VALMASK
) == 0);
4278 /* Value is a hash code for KEY for use in hash table H which uses
4279 `equal' to compare keys. The hash code returned is guaranteed to fit
4280 in a Lisp integer. */
4283 hashfn_equal (h
, key
)
4284 struct Lisp_Hash_Table
*h
;
4287 unsigned hash
= sxhash (key
, 0);
4288 xassert ((hash
& ~VALMASK
) == 0);
4293 /* Value is a hash code for KEY for use in hash table H which uses as
4294 user-defined function to compare keys. The hash code returned is
4295 guaranteed to fit in a Lisp integer. */
4298 hashfn_user_defined (h
, key
)
4299 struct Lisp_Hash_Table
*h
;
4302 Lisp_Object args
[2], hash
;
4304 args
[0] = h
->user_hash_function
;
4306 hash
= Ffuncall (2, args
);
4307 if (!INTEGERP (hash
))
4309 list2 (build_string ("Invalid hash code returned from \
4310 user-supplied hash function"),
4312 return XUINT (hash
);
4316 /* Create and initialize a new hash table.
4318 TEST specifies the test the hash table will use to compare keys.
4319 It must be either one of the predefined tests `eq', `eql' or
4320 `equal' or a symbol denoting a user-defined test named TEST with
4321 test and hash functions USER_TEST and USER_HASH.
4323 Give the table initial capacity SIZE, SIZE >= 0, an integer.
4325 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
4326 new size when it becomes full is computed by adding REHASH_SIZE to
4327 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
4328 table's new size is computed by multiplying its old size with
4331 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4332 be resized when the ratio of (number of entries in the table) /
4333 (table size) is >= REHASH_THRESHOLD.
4335 WEAK specifies the weakness of the table. If non-nil, it must be
4336 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
4339 make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
4340 user_test
, user_hash
)
4341 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4342 Lisp_Object user_test
, user_hash
;
4344 struct Lisp_Hash_Table
*h
;
4346 int index_size
, i
, sz
;
4348 /* Preconditions. */
4349 xassert (SYMBOLP (test
));
4350 xassert (INTEGERP (size
) && XINT (size
) >= 0);
4351 xassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
4352 || (FLOATP (rehash_size
) && XFLOATINT (rehash_size
) > 1.0));
4353 xassert (FLOATP (rehash_threshold
)
4354 && XFLOATINT (rehash_threshold
) > 0
4355 && XFLOATINT (rehash_threshold
) <= 1.0);
4357 if (XFASTINT (size
) == 0)
4358 size
= make_number (1);
4360 /* Allocate a table and initialize it. */
4361 h
= allocate_hash_table ();
4363 /* Initialize hash table slots. */
4364 sz
= XFASTINT (size
);
4367 if (EQ (test
, Qeql
))
4369 h
->cmpfn
= cmpfn_eql
;
4370 h
->hashfn
= hashfn_eql
;
4372 else if (EQ (test
, Qeq
))
4375 h
->hashfn
= hashfn_eq
;
4377 else if (EQ (test
, Qequal
))
4379 h
->cmpfn
= cmpfn_equal
;
4380 h
->hashfn
= hashfn_equal
;
4384 h
->user_cmp_function
= user_test
;
4385 h
->user_hash_function
= user_hash
;
4386 h
->cmpfn
= cmpfn_user_defined
;
4387 h
->hashfn
= hashfn_user_defined
;
4391 h
->rehash_threshold
= rehash_threshold
;
4392 h
->rehash_size
= rehash_size
;
4393 h
->count
= make_number (0);
4394 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
4395 h
->hash
= Fmake_vector (size
, Qnil
);
4396 h
->next
= Fmake_vector (size
, Qnil
);
4397 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
4398 index_size
= next_almost_prime ((int) (sz
/ XFLOATINT (rehash_threshold
)));
4399 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4401 /* Set up the free list. */
4402 for (i
= 0; i
< sz
- 1; ++i
)
4403 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4404 h
->next_free
= make_number (0);
4406 XSET_HASH_TABLE (table
, h
);
4407 xassert (HASH_TABLE_P (table
));
4408 xassert (XHASH_TABLE (table
) == h
);
4410 /* Maybe add this hash table to the list of all weak hash tables. */
4412 h
->next_weak
= Qnil
;
4415 h
->next_weak
= Vweak_hash_tables
;
4416 Vweak_hash_tables
= table
;
4423 /* Return a copy of hash table H1. Keys and values are not copied,
4424 only the table itself is. */
4427 copy_hash_table (h1
)
4428 struct Lisp_Hash_Table
*h1
;
4431 struct Lisp_Hash_Table
*h2
;
4432 struct Lisp_Vector
*next
;
4434 h2
= allocate_hash_table ();
4435 next
= h2
->vec_next
;
4436 bcopy (h1
, h2
, sizeof *h2
);
4437 h2
->vec_next
= next
;
4438 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4439 h2
->hash
= Fcopy_sequence (h1
->hash
);
4440 h2
->next
= Fcopy_sequence (h1
->next
);
4441 h2
->index
= Fcopy_sequence (h1
->index
);
4442 XSET_HASH_TABLE (table
, h2
);
4444 /* Maybe add this hash table to the list of all weak hash tables. */
4445 if (!NILP (h2
->weak
))
4447 h2
->next_weak
= Vweak_hash_tables
;
4448 Vweak_hash_tables
= table
;
4455 /* Resize hash table H if it's too full. If H cannot be resized
4456 because it's already too large, throw an error. */
4459 maybe_resize_hash_table (h
)
4460 struct Lisp_Hash_Table
*h
;
4462 if (NILP (h
->next_free
))
4464 int old_size
= HASH_TABLE_SIZE (h
);
4465 int i
, new_size
, index_size
;
4467 if (INTEGERP (h
->rehash_size
))
4468 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
4470 new_size
= old_size
* XFLOATINT (h
->rehash_size
);
4471 new_size
= max (old_size
+ 1, new_size
);
4472 index_size
= next_almost_prime ((int)
4474 / XFLOATINT (h
->rehash_threshold
)));
4475 if (max (index_size
, 2 * new_size
) & ~VALMASK
)
4476 error ("Hash table too large to resize");
4478 h
->key_and_value
= larger_vector (h
->key_and_value
, 2 * new_size
, Qnil
);
4479 h
->next
= larger_vector (h
->next
, new_size
, Qnil
);
4480 h
->hash
= larger_vector (h
->hash
, new_size
, Qnil
);
4481 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
4483 /* Update the free list. Do it so that new entries are added at
4484 the end of the free list. This makes some operations like
4486 for (i
= old_size
; i
< new_size
- 1; ++i
)
4487 HASH_NEXT (h
, i
) = make_number (i
+ 1);
4489 if (!NILP (h
->next_free
))
4491 Lisp_Object last
, next
;
4493 last
= h
->next_free
;
4494 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
4498 HASH_NEXT (h
, XFASTINT (last
)) = make_number (old_size
);
4501 XSETFASTINT (h
->next_free
, old_size
);
4504 for (i
= 0; i
< old_size
; ++i
)
4505 if (!NILP (HASH_HASH (h
, i
)))
4507 unsigned hash_code
= XUINT (HASH_HASH (h
, i
));
4508 int start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4509 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4510 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4516 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4517 the hash code of KEY. Value is the index of the entry in H
4518 matching KEY, or -1 if not found. */
4521 hash_lookup (h
, key
, hash
)
4522 struct Lisp_Hash_Table
*h
;
4527 int start_of_bucket
;
4530 hash_code
= h
->hashfn (h
, key
);
4534 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4535 idx
= HASH_INDEX (h
, start_of_bucket
);
4537 /* We need not gcpro idx since it's either an integer or nil. */
4540 int i
= XFASTINT (idx
);
4541 if (EQ (key
, HASH_KEY (h
, i
))
4543 && h
->cmpfn (h
, key
, hash_code
,
4544 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4546 idx
= HASH_NEXT (h
, i
);
4549 return NILP (idx
) ? -1 : XFASTINT (idx
);
4553 /* Put an entry into hash table H that associates KEY with VALUE.
4554 HASH is a previously computed hash code of KEY.
4555 Value is the index of the entry in H matching KEY. */
4558 hash_put (h
, key
, value
, hash
)
4559 struct Lisp_Hash_Table
*h
;
4560 Lisp_Object key
, value
;
4563 int start_of_bucket
, i
;
4565 xassert ((hash
& ~VALMASK
) == 0);
4567 /* Increment count after resizing because resizing may fail. */
4568 maybe_resize_hash_table (h
);
4569 h
->count
= make_number (XFASTINT (h
->count
) + 1);
4571 /* Store key/value in the key_and_value vector. */
4572 i
= XFASTINT (h
->next_free
);
4573 h
->next_free
= HASH_NEXT (h
, i
);
4574 HASH_KEY (h
, i
) = key
;
4575 HASH_VALUE (h
, i
) = value
;
4577 /* Remember its hash code. */
4578 HASH_HASH (h
, i
) = make_number (hash
);
4580 /* Add new entry to its collision chain. */
4581 start_of_bucket
= hash
% XVECTOR (h
->index
)->size
;
4582 HASH_NEXT (h
, i
) = HASH_INDEX (h
, start_of_bucket
);
4583 HASH_INDEX (h
, start_of_bucket
) = make_number (i
);
4588 /* Remove the entry matching KEY from hash table H, if there is one. */
4591 hash_remove (h
, key
)
4592 struct Lisp_Hash_Table
*h
;
4596 int start_of_bucket
;
4597 Lisp_Object idx
, prev
;
4599 hash_code
= h
->hashfn (h
, key
);
4600 start_of_bucket
= hash_code
% XVECTOR (h
->index
)->size
;
4601 idx
= HASH_INDEX (h
, start_of_bucket
);
4604 /* We need not gcpro idx, prev since they're either integers or nil. */
4607 int i
= XFASTINT (idx
);
4609 if (EQ (key
, HASH_KEY (h
, i
))
4611 && h
->cmpfn (h
, key
, hash_code
,
4612 HASH_KEY (h
, i
), XUINT (HASH_HASH (h
, i
)))))
4614 /* Take entry out of collision chain. */
4616 HASH_INDEX (h
, start_of_bucket
) = HASH_NEXT (h
, i
);
4618 HASH_NEXT (h
, XFASTINT (prev
)) = HASH_NEXT (h
, i
);
4620 /* Clear slots in key_and_value and add the slots to
4622 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = HASH_HASH (h
, i
) = Qnil
;
4623 HASH_NEXT (h
, i
) = h
->next_free
;
4624 h
->next_free
= make_number (i
);
4625 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4626 xassert (XINT (h
->count
) >= 0);
4632 idx
= HASH_NEXT (h
, i
);
4638 /* Clear hash table H. */
4642 struct Lisp_Hash_Table
*h
;
4644 if (XFASTINT (h
->count
) > 0)
4646 int i
, size
= HASH_TABLE_SIZE (h
);
4648 for (i
= 0; i
< size
; ++i
)
4650 HASH_NEXT (h
, i
) = i
< size
- 1 ? make_number (i
+ 1) : Qnil
;
4651 HASH_KEY (h
, i
) = Qnil
;
4652 HASH_VALUE (h
, i
) = Qnil
;
4653 HASH_HASH (h
, i
) = Qnil
;
4656 for (i
= 0; i
< XVECTOR (h
->index
)->size
; ++i
)
4657 XVECTOR (h
->index
)->contents
[i
] = Qnil
;
4659 h
->next_free
= make_number (0);
4660 h
->count
= make_number (0);
4666 /************************************************************************
4668 ************************************************************************/
4670 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
4671 entries from the table that don't survive the current GC.
4672 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
4673 non-zero if anything was marked. */
4676 sweep_weak_table (h
, remove_entries_p
)
4677 struct Lisp_Hash_Table
*h
;
4678 int remove_entries_p
;
4680 int bucket
, n
, marked
;
4682 n
= XVECTOR (h
->index
)->size
& ~ARRAY_MARK_FLAG
;
4685 for (bucket
= 0; bucket
< n
; ++bucket
)
4687 Lisp_Object idx
, next
, prev
;
4689 /* Follow collision chain, removing entries that
4690 don't survive this garbage collection. */
4692 for (idx
= HASH_INDEX (h
, bucket
); !GC_NILP (idx
); idx
= next
)
4694 int i
= XFASTINT (idx
);
4695 int key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4696 int value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4699 if (EQ (h
->weak
, Qkey
))
4700 remove_p
= !key_known_to_survive_p
;
4701 else if (EQ (h
->weak
, Qvalue
))
4702 remove_p
= !value_known_to_survive_p
;
4703 else if (EQ (h
->weak
, Qkey_or_value
))
4704 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4705 else if (EQ (h
->weak
, Qkey_and_value
))
4706 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4710 next
= HASH_NEXT (h
, i
);
4712 if (remove_entries_p
)
4716 /* Take out of collision chain. */
4718 HASH_INDEX (h
, bucket
) = next
;
4720 HASH_NEXT (h
, XFASTINT (prev
)) = next
;
4722 /* Add to free list. */
4723 HASH_NEXT (h
, i
) = h
->next_free
;
4726 /* Clear key, value, and hash. */
4727 HASH_KEY (h
, i
) = HASH_VALUE (h
, i
) = Qnil
;
4728 HASH_HASH (h
, i
) = Qnil
;
4730 h
->count
= make_number (XFASTINT (h
->count
) - 1);
4737 /* Make sure key and value survive. */
4738 if (!key_known_to_survive_p
)
4740 mark_object (&HASH_KEY (h
, i
));
4744 if (!value_known_to_survive_p
)
4746 mark_object (&HASH_VALUE (h
, i
));
4757 /* Remove elements from weak hash tables that don't survive the
4758 current garbage collection. Remove weak tables that don't survive
4759 from Vweak_hash_tables. Called from gc_sweep. */
4762 sweep_weak_hash_tables ()
4764 Lisp_Object table
, used
, next
;
4765 struct Lisp_Hash_Table
*h
;
4768 /* Mark all keys and values that are in use. Keep on marking until
4769 there is no more change. This is necessary for cases like
4770 value-weak table A containing an entry X -> Y, where Y is used in a
4771 key-weak table B, Z -> Y. If B comes after A in the list of weak
4772 tables, X -> Y might be removed from A, although when looking at B
4773 one finds that it shouldn't. */
4777 for (table
= Vweak_hash_tables
; !GC_NILP (table
); table
= h
->next_weak
)
4779 h
= XHASH_TABLE (table
);
4780 if (h
->size
& ARRAY_MARK_FLAG
)
4781 marked
|= sweep_weak_table (h
, 0);
4786 /* Remove tables and entries that aren't used. */
4787 for (table
= Vweak_hash_tables
, used
= Qnil
; !GC_NILP (table
); table
= next
)
4789 h
= XHASH_TABLE (table
);
4790 next
= h
->next_weak
;
4792 if (h
->size
& ARRAY_MARK_FLAG
)
4794 /* TABLE is marked as used. Sweep its contents. */
4795 if (XFASTINT (h
->count
) > 0)
4796 sweep_weak_table (h
, 1);
4798 /* Add table to the list of used weak hash tables. */
4799 h
->next_weak
= used
;
4804 Vweak_hash_tables
= used
;
4809 /***********************************************************************
4810 Hash Code Computation
4811 ***********************************************************************/
4813 /* Maximum depth up to which to dive into Lisp structures. */
4815 #define SXHASH_MAX_DEPTH 3
4817 /* Maximum length up to which to take list and vector elements into
4820 #define SXHASH_MAX_LEN 7
4822 /* Combine two integers X and Y for hashing. */
4824 #define SXHASH_COMBINE(X, Y) \
4825 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
4829 /* Return a hash for string PTR which has length LEN. The hash
4830 code returned is guaranteed to fit in a Lisp integer. */
4833 sxhash_string (ptr
, len
)
4837 unsigned char *p
= ptr
;
4838 unsigned char *end
= p
+ len
;
4847 hash
= ((hash
<< 3) + (hash
>> 28) + c
);
4850 return hash
& VALMASK
;
4854 /* Return a hash for list LIST. DEPTH is the current depth in the
4855 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4858 sxhash_list (list
, depth
)
4865 if (depth
< SXHASH_MAX_DEPTH
)
4867 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4868 list
= XCDR (list
), ++i
)
4870 unsigned hash2
= sxhash (XCAR (list
), depth
+ 1);
4871 hash
= SXHASH_COMBINE (hash
, hash2
);
4878 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4879 the Lisp structure. */
4882 sxhash_vector (vec
, depth
)
4886 unsigned hash
= XVECTOR (vec
)->size
;
4889 n
= min (SXHASH_MAX_LEN
, XVECTOR (vec
)->size
);
4890 for (i
= 0; i
< n
; ++i
)
4892 unsigned hash2
= sxhash (XVECTOR (vec
)->contents
[i
], depth
+ 1);
4893 hash
= SXHASH_COMBINE (hash
, hash2
);
4900 /* Return a hash for bool-vector VECTOR. */
4903 sxhash_bool_vector (vec
)
4906 unsigned hash
= XBOOL_VECTOR (vec
)->size
;
4909 n
= min (SXHASH_MAX_LEN
, XBOOL_VECTOR (vec
)->vector_size
);
4910 for (i
= 0; i
< n
; ++i
)
4911 hash
= SXHASH_COMBINE (hash
, XBOOL_VECTOR (vec
)->data
[i
]);
4917 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4918 structure. Value is an unsigned integer clipped to VALMASK. */
4927 if (depth
> SXHASH_MAX_DEPTH
)
4930 switch (XTYPE (obj
))
4937 hash
= sxhash_string (SDATA (SYMBOL_NAME (obj
)),
4938 SCHARS (SYMBOL_NAME (obj
)));
4946 hash
= sxhash_string (SDATA (obj
), SCHARS (obj
));
4949 /* This can be everything from a vector to an overlay. */
4950 case Lisp_Vectorlike
:
4952 /* According to the CL HyperSpec, two arrays are equal only if
4953 they are `eq', except for strings and bit-vectors. In
4954 Emacs, this works differently. We have to compare element
4956 hash
= sxhash_vector (obj
, depth
);
4957 else if (BOOL_VECTOR_P (obj
))
4958 hash
= sxhash_bool_vector (obj
);
4960 /* Others are `equal' if they are `eq', so let's take their
4966 hash
= sxhash_list (obj
, depth
);
4971 unsigned char *p
= (unsigned char *) &XFLOAT_DATA (obj
);
4972 unsigned char *e
= p
+ sizeof XFLOAT_DATA (obj
);
4973 for (hash
= 0; p
< e
; ++p
)
4974 hash
= SXHASH_COMBINE (hash
, *p
);
4982 return hash
& VALMASK
;
4987 /***********************************************************************
4989 ***********************************************************************/
4992 DEFUN ("sxhash", Fsxhash
, Ssxhash
, 1, 1, 0,
4993 doc
: /* Compute a hash code for OBJ and return it as integer. */)
4997 unsigned hash
= sxhash (obj
, 0);;
4998 return make_number (hash
);
5002 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
5003 doc
: /* Create and return a new hash table.
5005 Arguments are specified as keyword/argument pairs. The following
5006 arguments are defined:
5008 :test TEST -- TEST must be a symbol that specifies how to compare
5009 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
5010 `equal'. User-supplied test and hash functions can be specified via
5011 `define-hash-table-test'.
5013 :size SIZE -- A hint as to how many elements will be put in the table.
5016 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
5017 fills up. If REHASH-SIZE is an integer, add that many space. If it
5018 is a float, it must be > 1.0, and the new size is computed by
5019 multiplying the old size with that factor. Default is 1.5.
5021 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
5022 Resize the hash table when ratio of the number of entries in the
5023 table. Default is 0.8.
5025 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
5026 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
5027 returned is a weak table. Key/value pairs are removed from a weak
5028 hash table when there are no non-weak references pointing to their
5029 key, value, one of key or value, or both key and value, depending on
5030 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
5033 usage: (make-hash-table &rest KEYWORD-ARGS) */)
5038 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
5039 Lisp_Object user_test
, user_hash
;
5043 /* The vector `used' is used to keep track of arguments that
5044 have been consumed. */
5045 used
= (char *) alloca (nargs
* sizeof *used
);
5046 bzero (used
, nargs
* sizeof *used
);
5048 /* See if there's a `:test TEST' among the arguments. */
5049 i
= get_key_arg (QCtest
, nargs
, args
, used
);
5050 test
= i
< 0 ? Qeql
: args
[i
];
5051 if (!EQ (test
, Qeq
) && !EQ (test
, Qeql
) && !EQ (test
, Qequal
))
5053 /* See if it is a user-defined test. */
5056 prop
= Fget (test
, Qhash_table_test
);
5057 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
5058 Fsignal (Qerror
, list2 (build_string ("Invalid hash table test"),
5060 user_test
= XCAR (prop
);
5061 user_hash
= XCAR (XCDR (prop
));
5064 user_test
= user_hash
= Qnil
;
5066 /* See if there's a `:size SIZE' argument. */
5067 i
= get_key_arg (QCsize
, nargs
, args
, used
);
5068 size
= i
< 0 ? Qnil
: args
[i
];
5070 size
= make_number (DEFAULT_HASH_SIZE
);
5071 else if (!INTEGERP (size
) || XINT (size
) < 0)
5073 list2 (build_string ("Invalid hash table size"),
5076 /* Look for `:rehash-size SIZE'. */
5077 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
5078 rehash_size
= i
< 0 ? make_float (DEFAULT_REHASH_SIZE
) : args
[i
];
5079 if (!NUMBERP (rehash_size
)
5080 || (INTEGERP (rehash_size
) && XINT (rehash_size
) <= 0)
5081 || XFLOATINT (rehash_size
) <= 1.0)
5083 list2 (build_string ("Invalid hash table rehash size"),
5086 /* Look for `:rehash-threshold THRESHOLD'. */
5087 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
5088 rehash_threshold
= i
< 0 ? make_float (DEFAULT_REHASH_THRESHOLD
) : args
[i
];
5089 if (!FLOATP (rehash_threshold
)
5090 || XFLOATINT (rehash_threshold
) <= 0.0
5091 || XFLOATINT (rehash_threshold
) > 1.0)
5093 list2 (build_string ("Invalid hash table rehash threshold"),
5096 /* Look for `:weakness WEAK'. */
5097 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
5098 weak
= i
< 0 ? Qnil
: args
[i
];
5100 weak
= Qkey_and_value
;
5103 && !EQ (weak
, Qvalue
)
5104 && !EQ (weak
, Qkey_or_value
)
5105 && !EQ (weak
, Qkey_and_value
))
5106 Fsignal (Qerror
, list2 (build_string ("Invalid hash table weakness"),
5109 /* Now, all args should have been used up, or there's a problem. */
5110 for (i
= 0; i
< nargs
; ++i
)
5113 list2 (build_string ("Invalid argument list"), args
[i
]));
5115 return make_hash_table (test
, size
, rehash_size
, rehash_threshold
, weak
,
5116 user_test
, user_hash
);
5120 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
5121 doc
: /* Return a copy of hash table TABLE. */)
5125 return copy_hash_table (check_hash_table (table
));
5129 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
5130 doc
: /* Return the number of elements in TABLE. */)
5134 return check_hash_table (table
)->count
;
5138 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
5139 Shash_table_rehash_size
, 1, 1, 0,
5140 doc
: /* Return the current rehash size of TABLE. */)
5144 return check_hash_table (table
)->rehash_size
;
5148 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
5149 Shash_table_rehash_threshold
, 1, 1, 0,
5150 doc
: /* Return the current rehash threshold of TABLE. */)
5154 return check_hash_table (table
)->rehash_threshold
;
5158 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
5159 doc
: /* Return the size of TABLE.
5160 The size can be used as an argument to `make-hash-table' to create
5161 a hash table than can hold as many elements of TABLE holds
5162 without need for resizing. */)
5166 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5167 return make_number (HASH_TABLE_SIZE (h
));
5171 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
5172 doc
: /* Return the test TABLE uses. */)
5176 return check_hash_table (table
)->test
;
5180 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
5182 doc
: /* Return the weakness of TABLE. */)
5186 return check_hash_table (table
)->weak
;
5190 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
5191 doc
: /* Return t if OBJ is a Lisp hash table object. */)
5195 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
5199 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
5200 doc
: /* Clear hash table TABLE. */)
5204 hash_clear (check_hash_table (table
));
5209 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
5210 doc
: /* Look up KEY in TABLE and return its associated value.
5211 If KEY is not found, return DFLT which defaults to nil. */)
5213 Lisp_Object key
, table
, dflt
;
5215 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5216 int i
= hash_lookup (h
, key
, NULL
);
5217 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
5221 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
5222 doc
: /* Associate KEY with VALUE in hash table TABLE.
5223 If KEY is already present in table, replace its current value with
5226 Lisp_Object key
, value
, table
;
5228 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5232 i
= hash_lookup (h
, key
, &hash
);
5234 HASH_VALUE (h
, i
) = value
;
5236 hash_put (h
, key
, value
, hash
);
5242 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5243 doc
: /* Remove KEY from TABLE. */)
5245 Lisp_Object key
, table
;
5247 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5248 hash_remove (h
, key
);
5253 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5254 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5255 FUNCTION is called with 2 arguments KEY and VALUE. */)
5257 Lisp_Object function
, table
;
5259 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5260 Lisp_Object args
[3];
5263 for (i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5264 if (!NILP (HASH_HASH (h
, i
)))
5267 args
[1] = HASH_KEY (h
, i
);
5268 args
[2] = HASH_VALUE (h
, i
);
5276 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5277 Sdefine_hash_table_test
, 3, 3, 0,
5278 doc
: /* Define a new hash table test with name NAME, a symbol.
5280 In hash tables created with NAME specified as test, use TEST to
5281 compare keys, and HASH for computing hash codes of keys.
5283 TEST must be a function taking two arguments and returning non-nil if
5284 both arguments are the same. HASH must be a function taking one
5285 argument and return an integer that is the hash code of the argument.
5286 Hash code computation should use the whole value range of integers,
5287 including negative integers. */)
5289 Lisp_Object name
, test
, hash
;
5291 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5296 /************************************************************************
5298 ************************************************************************/
5303 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5304 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5306 A message digest is a cryptographic checksum of a document, and the
5307 algorithm to calculate it is defined in RFC 1321.
5309 The two optional arguments START and END are character positions
5310 specifying for which part of OBJECT the message digest should be
5311 computed. If nil or omitted, the digest is computed for the whole
5314 The MD5 message digest is computed from the result of encoding the
5315 text in a coding system, not directly from the internal Emacs form of
5316 the text. The optional fourth argument CODING-SYSTEM specifies which
5317 coding system to encode the text with. It should be the same coding
5318 system that you used or will use when actually writing the text into a
5321 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5322 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5323 system would be chosen by default for writing this text into a file.
5325 If OBJECT is a string, the most preferred coding system (see the
5326 command `prefer-coding-system') is used.
5328 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5329 guesswork fails. Normally, an error is signaled in such case. */)
5330 (object
, start
, end
, coding_system
, noerror
)
5331 Lisp_Object object
, start
, end
, coding_system
, noerror
;
5333 unsigned char digest
[16];
5334 unsigned char value
[33];
5338 int start_char
= 0, end_char
= 0;
5339 int start_byte
= 0, end_byte
= 0;
5341 register struct buffer
*bp
;
5344 if (STRINGP (object
))
5346 if (NILP (coding_system
))
5348 /* Decide the coding-system to encode the data with. */
5350 if (STRING_MULTIBYTE (object
))
5351 /* use default, we can't guess correct value */
5352 coding_system
= SYMBOL_VALUE (XCAR (Vcoding_category_list
));
5354 coding_system
= Qraw_text
;
5357 if (NILP (Fcoding_system_p (coding_system
)))
5359 /* Invalid coding system. */
5361 if (!NILP (noerror
))
5362 coding_system
= Qraw_text
;
5365 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5368 if (STRING_MULTIBYTE (object
))
5369 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5371 size
= SCHARS (object
);
5372 size_byte
= SBYTES (object
);
5376 CHECK_NUMBER (start
);
5378 start_char
= XINT (start
);
5383 start_byte
= string_char_to_byte (object
, start_char
);
5389 end_byte
= size_byte
;
5395 end_char
= XINT (end
);
5400 end_byte
= string_char_to_byte (object
, end_char
);
5403 if (!(0 <= start_char
&& start_char
<= end_char
&& end_char
<= size
))
5404 args_out_of_range_3 (object
, make_number (start_char
),
5405 make_number (end_char
));
5409 CHECK_BUFFER (object
);
5411 bp
= XBUFFER (object
);
5417 CHECK_NUMBER_COERCE_MARKER (start
);
5425 CHECK_NUMBER_COERCE_MARKER (end
);
5430 temp
= b
, b
= e
, e
= temp
;
5432 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
5433 args_out_of_range (start
, end
);
5435 if (NILP (coding_system
))
5437 /* Decide the coding-system to encode the data with.
5438 See fileio.c:Fwrite-region */
5440 if (!NILP (Vcoding_system_for_write
))
5441 coding_system
= Vcoding_system_for_write
;
5444 int force_raw_text
= 0;
5446 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5447 if (NILP (coding_system
)
5448 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5450 coding_system
= Qnil
;
5451 if (NILP (current_buffer
->enable_multibyte_characters
))
5455 if (NILP (coding_system
) && !NILP (Fbuffer_file_name(object
)))
5457 /* Check file-coding-system-alist. */
5458 Lisp_Object args
[4], val
;
5460 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
5461 args
[3] = Fbuffer_file_name(object
);
5462 val
= Ffind_operation_coding_system (4, args
);
5463 if (CONSP (val
) && !NILP (XCDR (val
)))
5464 coding_system
= XCDR (val
);
5467 if (NILP (coding_system
)
5468 && !NILP (XBUFFER (object
)->buffer_file_coding_system
))
5470 /* If we still have not decided a coding system, use the
5471 default value of buffer-file-coding-system. */
5472 coding_system
= XBUFFER (object
)->buffer_file_coding_system
;
5476 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5477 /* Confirm that VAL can surely encode the current region. */
5478 coding_system
= call4 (Vselect_safe_coding_system_function
,
5479 make_number (b
), make_number (e
),
5480 coding_system
, Qnil
);
5483 coding_system
= Qraw_text
;
5486 if (NILP (Fcoding_system_p (coding_system
)))
5488 /* Invalid coding system. */
5490 if (!NILP (noerror
))
5491 coding_system
= Qraw_text
;
5494 Fsignal (Qcoding_system_error
, Fcons (coding_system
, Qnil
));
5498 object
= make_buffer_string (b
, e
, 0);
5500 if (STRING_MULTIBYTE (object
))
5501 object
= code_convert_string1 (object
, coding_system
, Qnil
, 1);
5504 md5_buffer (SDATA (object
) + start_byte
,
5505 SBYTES (object
) - (size_byte
- end_byte
),
5508 for (i
= 0; i
< 16; i
++)
5509 sprintf (&value
[2 * i
], "%02x", digest
[i
]);
5512 return make_string (value
, 32);
5519 /* Hash table stuff. */
5520 Qhash_table_p
= intern ("hash-table-p");
5521 staticpro (&Qhash_table_p
);
5522 Qeq
= intern ("eq");
5524 Qeql
= intern ("eql");
5526 Qequal
= intern ("equal");
5527 staticpro (&Qequal
);
5528 QCtest
= intern (":test");
5529 staticpro (&QCtest
);
5530 QCsize
= intern (":size");
5531 staticpro (&QCsize
);
5532 QCrehash_size
= intern (":rehash-size");
5533 staticpro (&QCrehash_size
);
5534 QCrehash_threshold
= intern (":rehash-threshold");
5535 staticpro (&QCrehash_threshold
);
5536 QCweakness
= intern (":weakness");
5537 staticpro (&QCweakness
);
5538 Qkey
= intern ("key");
5540 Qvalue
= intern ("value");
5541 staticpro (&Qvalue
);
5542 Qhash_table_test
= intern ("hash-table-test");
5543 staticpro (&Qhash_table_test
);
5544 Qkey_or_value
= intern ("key-or-value");
5545 staticpro (&Qkey_or_value
);
5546 Qkey_and_value
= intern ("key-and-value");
5547 staticpro (&Qkey_and_value
);
5550 defsubr (&Smake_hash_table
);
5551 defsubr (&Scopy_hash_table
);
5552 defsubr (&Shash_table_count
);
5553 defsubr (&Shash_table_rehash_size
);
5554 defsubr (&Shash_table_rehash_threshold
);
5555 defsubr (&Shash_table_size
);
5556 defsubr (&Shash_table_test
);
5557 defsubr (&Shash_table_weakness
);
5558 defsubr (&Shash_table_p
);
5559 defsubr (&Sclrhash
);
5560 defsubr (&Sgethash
);
5561 defsubr (&Sputhash
);
5562 defsubr (&Sremhash
);
5563 defsubr (&Smaphash
);
5564 defsubr (&Sdefine_hash_table_test
);
5566 Qstring_lessp
= intern ("string-lessp");
5567 staticpro (&Qstring_lessp
);
5568 Qprovide
= intern ("provide");
5569 staticpro (&Qprovide
);
5570 Qrequire
= intern ("require");
5571 staticpro (&Qrequire
);
5572 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
5573 staticpro (&Qyes_or_no_p_history
);
5574 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
5575 staticpro (&Qcursor_in_echo_area
);
5576 Qwidget_type
= intern ("widget-type");
5577 staticpro (&Qwidget_type
);
5579 staticpro (&string_char_byte_cache_string
);
5580 string_char_byte_cache_string
= Qnil
;
5582 require_nesting_list
= Qnil
;
5583 staticpro (&require_nesting_list
);
5585 Fset (Qyes_or_no_p_history
, Qnil
);
5587 DEFVAR_LISP ("features", &Vfeatures
,
5588 doc
: /* A list of symbols which are the features of the executing emacs.
5589 Used by `featurep' and `require', and altered by `provide'. */);
5591 Qsubfeatures
= intern ("subfeatures");
5592 staticpro (&Qsubfeatures
);
5594 #ifdef HAVE_LANGINFO_CODESET
5595 Qcodeset
= intern ("codeset");
5596 staticpro (&Qcodeset
);
5597 Qdays
= intern ("days");
5599 Qmonths
= intern ("months");
5600 staticpro (&Qmonths
);
5601 Qpaper
= intern ("paper");
5602 staticpro (&Qpaper
);
5603 #endif /* HAVE_LANGINFO_CODESET */
5605 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
5606 doc
: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5607 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5608 invoked by mouse clicks and mouse menu items. */);
5611 defsubr (&Sidentity
);
5614 defsubr (&Ssafe_length
);
5615 defsubr (&Sstring_bytes
);
5616 defsubr (&Sstring_equal
);
5617 defsubr (&Scompare_strings
);
5618 defsubr (&Sstring_lessp
);
5621 defsubr (&Svconcat
);
5622 defsubr (&Scopy_sequence
);
5623 defsubr (&Sstring_make_multibyte
);
5624 defsubr (&Sstring_make_unibyte
);
5625 defsubr (&Sstring_as_multibyte
);
5626 defsubr (&Sstring_as_unibyte
);
5627 defsubr (&Sstring_to_multibyte
);
5628 defsubr (&Scopy_alist
);
5629 defsubr (&Ssubstring
);
5630 defsubr (&Ssubstring_no_properties
);
5642 defsubr (&Snreverse
);
5643 defsubr (&Sreverse
);
5645 defsubr (&Splist_get
);
5647 defsubr (&Splist_put
);
5649 defsubr (&Slax_plist_get
);
5650 defsubr (&Slax_plist_put
);
5652 defsubr (&Sfillarray
);
5653 defsubr (&Schar_table_subtype
);
5654 defsubr (&Schar_table_parent
);
5655 defsubr (&Sset_char_table_parent
);
5656 defsubr (&Schar_table_extra_slot
);
5657 defsubr (&Sset_char_table_extra_slot
);
5658 defsubr (&Schar_table_range
);
5659 defsubr (&Sset_char_table_range
);
5660 defsubr (&Sset_char_table_default
);
5661 defsubr (&Soptimize_char_table
);
5662 defsubr (&Smap_char_table
);
5666 defsubr (&Smapconcat
);
5667 defsubr (&Sy_or_n_p
);
5668 defsubr (&Syes_or_no_p
);
5669 defsubr (&Sload_average
);
5670 defsubr (&Sfeaturep
);
5671 defsubr (&Srequire
);
5672 defsubr (&Sprovide
);
5673 defsubr (&Splist_member
);
5674 defsubr (&Swidget_put
);
5675 defsubr (&Swidget_get
);
5676 defsubr (&Swidget_apply
);
5677 defsubr (&Sbase64_encode_region
);
5678 defsubr (&Sbase64_decode_region
);
5679 defsubr (&Sbase64_encode_string
);
5680 defsubr (&Sbase64_decode_string
);
5682 defsubr (&Slanginfo
);
5689 Vweak_hash_tables
= Qnil
;