/* Random utility Lisp functions.
- Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 1999 Free Software Foundation, Inc.
+ Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 98, 99, 2000, 2001
+ Free Software Foundation, Inc.
This file is part of GNU Emacs.
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */
-
#include <config.h>
#ifdef HAVE_UNISTD_H
#include "buffer.h"
#include "keyboard.h"
+#include "keymap.h"
#include "intervals.h"
#include "frame.h"
#include "window.h"
+#include "blockinput.h"
#if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
#include "xterm.h"
#endif
#define NULL (void *)0
#endif
-#ifndef min
-#define min(a, b) ((a) < (b) ? (a) : (b))
-#define max(a, b) ((a) > (b) ? (a) : (b))
-#endif
-
/* Nonzero enables use of dialog boxes for questions
asked by mouse commands. */
int use_dialog_box;
#endif
\f
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
- "Return the argument unchanged.")
- (arg)
+ doc: /* Return the argument unchanged. */)
+ (arg)
Lisp_Object arg;
{
return arg;
}
DEFUN ("random", Frandom, Srandom, 0, 1, 0,
- "Return a pseudo-random number.\n\
-All integers representable in Lisp are equally likely.\n\
- On most systems, this is 28 bits' worth.\n\
-With positive integer argument N, return random number in interval [0,N).\n\
-With argument t, set the random number seed from the current time and pid.")
- (n)
+ doc: /* Return a pseudo-random number.
+All integers representable in Lisp are equally likely.
+ On most systems, this is 28 bits' worth.
+With positive integer argument N, return random number in interval [0,N).
+With argument t, set the random number seed from the current time and pid. */)
+ (n)
Lisp_Object n;
{
EMACS_INT val;
/* Random data-structure functions */
DEFUN ("length", Flength, Slength, 1, 1, 0,
- "Return the length of vector, list or string SEQUENCE.\n\
-A byte-code function object is also allowed.\n\
-If the string contains multibyte characters, this is not the necessarily\n\
-the number of bytes in the string; it is the number of characters.\n\
-To get the number of bytes, use `string-bytes'")
- (sequence)
+ doc: /* Return the length of vector, list or string SEQUENCE.
+A byte-code function object is also allowed.
+If the string contains multibyte characters, this is not the necessarily
+the number of bytes in the string; it is the number of characters.
+To get the number of bytes, use `string-bytes'. */)
+ (sequence)
register Lisp_Object sequence;
{
- register Lisp_Object tail, val;
+ register Lisp_Object val;
register int i;
retry:
else if (VECTORP (sequence))
XSETFASTINT (val, XVECTOR (sequence)->size);
else if (CHAR_TABLE_P (sequence))
- XSETFASTINT (val, (MIN_CHAR_COMPOSITION
- + (CHAR_FIELD2_MASK | CHAR_FIELD3_MASK)
- - 1));
+ XSETFASTINT (val, MAX_CHAR);
else if (BOOL_VECTOR_P (sequence))
XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
else if (COMPILEDP (sequence))
since it must terminate. */
DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
- "Return the length of a list, but avoid error or infinite loop.\n\
-This function never gets an error. If LIST is not really a list,\n\
-it returns 0. If LIST is circular, it returns a finite value\n\
-which is at least the number of distinct elements.")
- (list)
+ doc: /* Return the length of a list, but avoid error or infinite loop.
+This function never gets an error. If LIST is not really a list,
+it returns 0. If LIST is circular, it returns a finite value
+which is at least the number of distinct elements. */)
+ (list)
Lisp_Object list;
{
Lisp_Object tail, halftail, length;
return length;
}
-DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
- "Return the number of bytes in STRING.\n\
-If STRING is a multibyte string, this is greater than the length of STRING.")
- (string)
+DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
+ doc: /* Return the number of bytes in STRING.
+If STRING is a multibyte string, this is greater than the length of STRING. */)
+ (string)
Lisp_Object string;
{
- CHECK_STRING (string, 1);
+ CHECK_STRING (string);
return make_number (STRING_BYTES (XSTRING (string)));
}
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
- "Return t if two strings have identical contents.\n\
-Case is significant, but text properties are ignored.\n\
-Symbols are also allowed; their print names are used instead.")
- (s1, s2)
+ doc: /* Return t if two strings have identical contents.
+Case is significant, but text properties are ignored.
+Symbols are also allowed; their print names are used instead. */)
+ (s1, s2)
register Lisp_Object s1, s2;
{
if (SYMBOLP (s1))
- XSETSTRING (s1, XSYMBOL (s1)->name);
+ s1 = SYMBOL_NAME (s1);
if (SYMBOLP (s2))
- XSETSTRING (s2, XSYMBOL (s2)->name);
- CHECK_STRING (s1, 0);
- CHECK_STRING (s2, 1);
+ s2 = SYMBOL_NAME (s2);
+ CHECK_STRING (s1);
+ CHECK_STRING (s2);
if (XSTRING (s1)->size != XSTRING (s2)->size
|| STRING_BYTES (XSTRING (s1)) != STRING_BYTES (XSTRING (s2))
DEFUN ("compare-strings", Fcompare_strings,
Scompare_strings, 6, 7, 0,
- "Compare the contents of two strings, converting to multibyte if needed.\n\
-In string STR1, skip the first START1 characters and stop at END1.\n\
-In string STR2, skip the first START2 characters and stop at END2.\n\
-END1 and END2 default to the full lengths of the respective strings.\n\
-\n\
-Case is significant in this comparison if IGNORE-CASE is nil.\n\
-Unibyte strings are converted to multibyte for comparison.\n\
-\n\
-The value is t if the strings (or specified portions) match.\n\
-If string STR1 is less, the value is a negative number N;\n\
- - 1 - N is the number of characters that match at the beginning.\n\
-If string STR1 is greater, the value is a positive number N;\n\
- N - 1 is the number of characters that match at the beginning.")
- (str1, start1, end1, str2, start2, end2, ignore_case)
+doc: /* Compare the contents of two strings, converting to multibyte if needed.
+In string STR1, skip the first START1 characters and stop at END1.
+In string STR2, skip the first START2 characters and stop at END2.
+END1 and END2 default to the full lengths of the respective strings.
+
+Case is significant in this comparison if IGNORE-CASE is nil.
+Unibyte strings are converted to multibyte for comparison.
+
+The value is t if the strings (or specified portions) match.
+If string STR1 is less, the value is a negative number N;
+ - 1 - N is the number of characters that match at the beginning.
+If string STR1 is greater, the value is a positive number N;
+ N - 1 is the number of characters that match at the beginning. */)
+ (str1, start1, end1, str2, start2, end2, ignore_case)
Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case;
{
register int end1_char, end2_char;
register int i1, i1_byte, i2, i2_byte;
- CHECK_STRING (str1, 0);
- CHECK_STRING (str2, 1);
+ CHECK_STRING (str1);
+ CHECK_STRING (str2);
if (NILP (start1))
start1 = make_number (0);
if (NILP (start2))
start2 = make_number (0);
- CHECK_NATNUM (start1, 2);
- CHECK_NATNUM (start2, 3);
+ CHECK_NATNUM (start1);
+ CHECK_NATNUM (start2);
if (! NILP (end1))
- CHECK_NATNUM (end1, 4);
+ CHECK_NATNUM (end1);
if (! NILP (end2))
- CHECK_NATNUM (end2, 4);
+ CHECK_NATNUM (end2);
i1 = XINT (start1);
i2 = XINT (start2);
int c1, c2;
if (STRING_MULTIBYTE (str1))
- FETCH_STRING_CHAR_ADVANCE (c1, str1, i1, i1_byte);
+ FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
else
{
c1 = XSTRING (str1)->data[i1++];
}
if (STRING_MULTIBYTE (str2))
- FETCH_STRING_CHAR_ADVANCE (c2, str2, i2, i2_byte);
+ FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
else
{
c2 = XSTRING (str2)->data[i2++];
past the character that we are comparing;
hence we don't add or subtract 1 here. */
if (c1 < c2)
- return make_number (- i1);
+ return make_number (- i1 + XINT (start1));
else
- return make_number (i1);
+ return make_number (i1 - XINT (start1));
}
if (i1 < end1_char)
}
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
- "Return t if first arg string is less than second in lexicographic order.\n\
-Case is significant.\n\
-Symbols are also allowed; their print names are used instead.")
- (s1, s2)
+ doc: /* Return t if first arg string is less than second in lexicographic order.
+Case is significant.
+Symbols are also allowed; their print names are used instead. */)
+ (s1, s2)
register Lisp_Object s1, s2;
{
register int end;
register int i1, i1_byte, i2, i2_byte;
if (SYMBOLP (s1))
- XSETSTRING (s1, XSYMBOL (s1)->name);
+ s1 = SYMBOL_NAME (s1);
if (SYMBOLP (s2))
- XSETSTRING (s2, XSYMBOL (s2)->name);
- CHECK_STRING (s1, 0);
- CHECK_STRING (s2, 1);
+ s2 = SYMBOL_NAME (s2);
+ CHECK_STRING (s1);
+ CHECK_STRING (s2);
i1 = i1_byte = i2 = i2_byte = 0;
characters, not just the bytes. */
int c1, c2;
- if (STRING_MULTIBYTE (s1))
- FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
- else
- c1 = XSTRING (s1)->data[i1++];
-
- if (STRING_MULTIBYTE (s2))
- FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
- else
- c2 = XSTRING (s2)->data[i2++];
+ FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
+ FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
if (c1 != c2)
return c1 < c2 ? Qt : Qnil;
}
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
- "Concatenate all the arguments and make the result a list.\n\
-The result is a list whose elements are the elements of all the arguments.\n\
-Each argument may be a list, vector or string.\n\
-The last argument is not copied, just used as the tail of the new list.")
- (nargs, args)
+ doc: /* Concatenate all the arguments and make the result a list.
+The result is a list whose elements are the elements of all the arguments.
+Each argument may be a list, vector or string.
+The last argument is not copied, just used as the tail of the new list.
+usage: (append &rest SEQUENCES) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
- "Concatenate all the arguments and make the result a string.\n\
-The result is a string whose elements are the elements of all the arguments.\n\
-Each argument may be a string or a list or vector of characters (integers).\n\
-\n\
-Do not use individual integers as arguments!\n\
-The behavior of `concat' in that case will be changed later!\n\
-If your program passes an integer as an argument to `concat',\n\
-you should change it right away not to do so.")
- (nargs, args)
+ doc: /* Concatenate all the arguments and make the result a string.
+The result is a string whose elements are the elements of all the arguments.
+Each argument may be a string or a list or vector of characters (integers).
+usage: (concat &rest SEQUENCES) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
}
DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
- "Concatenate all the arguments and make the result a vector.\n\
-The result is a vector whose elements are the elements of all the arguments.\n\
-Each argument may be a list, vector or string.")
- (nargs, args)
+ doc: /* Concatenate all the arguments and make the result a vector.
+The result is a vector whose elements are the elements of all the arguments.
+Each argument may be a list, vector or string.
+usage: (vconcat &rest SEQUENCES) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
- "Return a copy of a list, vector or string.\n\
-The elements of a list or vector are not copied; they are shared\n\
-with the original.")
- (arg)
+ doc: /* Return a copy of a list, vector or string.
+The elements of a list or vector are not copied; they are shared
+with the original. */)
+ (arg)
Lisp_Object arg;
{
if (NILP (arg)) return arg;
register Lisp_Object tail;
register Lisp_Object this;
int toindex;
- int toindex_byte;
+ int toindex_byte = 0;
register int result_len;
register int result_len_byte;
register int argnum;
string can't be decided until we finish the whole concatination.
So, we record strings that have text properties to be copied
here, and copy the text properties after the concatination. */
- struct textprop_rec *textprops;
+ struct textprop_rec *textprops = NULL;
/* Number of elments in textprops. */
int num_textprops = 0;
+ tail = Qnil;
+
/* In append, the last arg isn't treated like the others */
if (last_special && nargs > 0)
{
if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
|| COMPILEDP (this) || BOOL_VECTOR_P (this)))
{
- if (INTEGERP (this))
- args[argnum] = Fnumber_to_string (this);
- else
args[argnum] = wrong_type_argument (Qsequencep, this);
}
}
wrong_type_argument (Qintegerp, ch);
this_len_byte = CHAR_BYTES (XINT (ch));
result_len_byte += this_len_byte;
- if (this_len_byte > 1)
+ if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
some_multibyte = 1;
}
else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
wrong_type_argument (Qintegerp, ch);
this_len_byte = CHAR_BYTES (XINT (ch));
result_len_byte += this_len_byte;
- if (this_len_byte > 1)
+ if (!SINGLE_BYTE_CHAR_P (XINT (ch)))
some_multibyte = 1;
}
else if (STRINGP (this))
for (argnum = 0; argnum < nargs; argnum++)
{
Lisp_Object thislen;
- int thisleni;
+ int thisleni = 0;
register unsigned int thisindex = 0;
register unsigned int thisindex_byte = 0;
int c;
if (STRING_MULTIBYTE (this))
{
- FETCH_STRING_CHAR_ADVANCE (c, this,
- thisindex,
- thisindex_byte);
+ FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
+ thisindex,
+ thisindex_byte);
XSETFASTINT (elt, c);
}
else
/* Store this element into the result. */
if (toindex < 0)
{
- XCAR (tail) = elt;
+ XSETCAR (tail, elt);
prev = tail;
tail = XCDR (tail);
}
XVECTOR (val)->contents[toindex++] = elt;
else
{
- CHECK_NUMBER (elt, 0);
+ CHECK_NUMBER (elt);
if (SINGLE_BYTE_CHAR_P (XINT (elt)))
{
- XSTRING (val)->data[toindex_byte++] = XINT (elt);
+ if (some_multibyte)
+ toindex_byte
+ += CHAR_STRING (XINT (elt),
+ XSTRING (val)->data + toindex_byte);
+ else
+ XSTRING (val)->data[toindex_byte++] = XINT (elt);
if (some_multibyte
&& toindex_byte > 0
&& count_combining (XSTRING (val)->data,
we already decided to make a multibyte string. */
{
int c = XINT (elt);
- unsigned char work[4], *str;
- int i = CHAR_STRING (c, work, str);
-
/* P exists as a variable
to avoid a bug on the Masscomp C compiler. */
unsigned char *p = & XSTRING (val)->data[toindex_byte];
- bcopy (str, p, i);
- toindex_byte += i;
+
+ toindex_byte += CHAR_STRING (c, p);
toindex++;
}
}
}
}
if (!NILP (prev))
- XCDR (prev) = last_tail;
+ XSETCDR (prev, last_tail);
if (num_textprops > 0)
{
+ Lisp_Object props;
+ int last_to_end = -1;
+
for (argnum = 0; argnum < num_textprops; argnum++)
{
this = args[textprops[argnum].argnum];
- copy_text_properties (make_number (textprops[argnum].from),
- XSTRING (this)->size, this,
- make_number (textprops[argnum].to), val, Qnil);
+ props = text_property_list (this,
+ make_number (0),
+ make_number (XSTRING (this)->size),
+ Qnil);
+ /* If successive arguments have properites, be sure that the
+ value of `composition' property be the copy. */
+ if (last_to_end == textprops[argnum].to)
+ make_composition_value_copy (props);
+ add_text_properties_from_list (val, props,
+ make_number (textprops[argnum].to));
+ last_to_end = textprops[argnum].to + XSTRING (this)->size;
}
}
return val;
while (best_below < char_index)
{
int c;
- FETCH_STRING_CHAR_ADVANCE (c, string, best_below, best_below_byte);
+ FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
+ best_below, best_below_byte);
}
i = best_below;
i_byte = best_below_byte;
while (best_below_byte < byte_index)
{
int c;
- FETCH_STRING_CHAR_ADVANCE (c, string, best_below, best_below_byte);
+ FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string,
+ best_below, best_below_byte);
}
i = best_below;
i_byte = best_below_byte;
DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
1, 1, 0,
- "Return the multibyte equivalent of STRING.\n\
-The function `unibyte-char-to-multibyte' is used to convert\n\
-each unibyte character to a multibyte character.")
- (string)
+ doc: /* Return the multibyte equivalent of STRING.
+The function `unibyte-char-to-multibyte' is used to convert
+each unibyte character to a multibyte character. */)
+ (string)
Lisp_Object string;
{
- CHECK_STRING (string, 0);
+ CHECK_STRING (string);
return string_make_multibyte (string);
}
DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
1, 1, 0,
- "Return the unibyte equivalent of STRING.\n\
-Multibyte character codes are converted to unibyte\n\
-by using just the low 8 bits.")
- (string)
+ doc: /* Return the unibyte equivalent of STRING.
+Multibyte character codes are converted to unibyte
+by using just the low 8 bits. */)
+ (string)
Lisp_Object string;
{
- CHECK_STRING (string, 0);
+ CHECK_STRING (string);
return string_make_unibyte (string);
}
DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
1, 1, 0,
- "Return a unibyte string with the same individual bytes as STRING.\n\
-If STRING is unibyte, the result is STRING itself.\n\
-Otherwise it is a newly created string, with no text properties.")
- (string)
+ doc: /* Return a unibyte string with the same individual bytes as STRING.
+If STRING is unibyte, the result is STRING itself.
+Otherwise it is a newly created string, with no text properties.
+If STRING is multibyte and contains a character of charset
+`eight-bit-control' or `eight-bit-graphic', it is converted to the
+corresponding single byte. */)
+ (string)
Lisp_Object string;
{
- CHECK_STRING (string, 0);
+ CHECK_STRING (string);
if (STRING_MULTIBYTE (string))
{
- string = Fcopy_sequence (string);
- XSTRING (string)->size = STRING_BYTES (XSTRING (string));
- XSTRING (string)->intervals = NULL_INTERVAL;
- SET_STRING_BYTES (XSTRING (string), -1);
+ int bytes = STRING_BYTES (XSTRING (string));
+ unsigned char *str = (unsigned char *) xmalloc (bytes);
+
+ bcopy (XSTRING (string)->data, str, bytes);
+ bytes = str_as_unibyte (str, bytes);
+ string = make_unibyte_string (str, bytes);
+ xfree (str);
}
return string;
}
DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
1, 1, 0,
- "Return a multibyte string with the same individual bytes as STRING.\n\
-If STRING is multibyte, the result is STRING itself.\n\
-Otherwise it is a newly created string, with no text properties.")
- (string)
+ doc: /* Return a multibyte string with the same individual bytes as STRING.
+If STRING is multibyte, the result is STRING itself.
+Otherwise it is a newly created string, with no text properties.
+If STRING is unibyte and contains an individual 8-bit byte (i.e. not
+part of a multibyte form), it is converted to the corresponding
+multibyte character of charset `eight-bit-control' or `eight-bit-graphic'. */)
+ (string)
Lisp_Object string;
{
- CHECK_STRING (string, 0);
+ CHECK_STRING (string);
if (! STRING_MULTIBYTE (string))
{
- int nbytes = STRING_BYTES (XSTRING (string));
- int newlen = multibyte_chars_in_text (XSTRING (string)->data, nbytes);
-
- string = Fcopy_sequence (string);
- XSTRING (string)->size = newlen;
- XSTRING (string)->size_byte = nbytes;
+ Lisp_Object new_string;
+ int nchars, nbytes;
+
+ parse_str_as_multibyte (XSTRING (string)->data,
+ STRING_BYTES (XSTRING (string)),
+ &nchars, &nbytes);
+ new_string = make_uninit_multibyte_string (nchars, nbytes);
+ bcopy (XSTRING (string)->data, XSTRING (new_string)->data,
+ STRING_BYTES (XSTRING (string)));
+ if (nbytes != STRING_BYTES (XSTRING (string)))
+ str_as_multibyte (XSTRING (new_string)->data, nbytes,
+ STRING_BYTES (XSTRING (string)), NULL);
+ string = new_string;
XSTRING (string)->intervals = NULL_INTERVAL;
}
return string;
}
\f
DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
- "Return a copy of ALIST.\n\
-This is an alist which represents the same mapping from objects to objects,\n\
-but does not share the alist structure with ALIST.\n\
-The objects mapped (cars and cdrs of elements of the alist)\n\
-are shared, however.\n\
-Elements of ALIST that are not conses are also shared.")
- (alist)
+ doc: /* Return a copy of ALIST.
+This is an alist which represents the same mapping from objects to objects,
+but does not share the alist structure with ALIST.
+The objects mapped (cars and cdrs of elements of the alist)
+are shared, however.
+Elements of ALIST that are not conses are also shared. */)
+ (alist)
Lisp_Object alist;
{
register Lisp_Object tem;
- CHECK_LIST (alist, 0);
+ CHECK_LIST (alist);
if (NILP (alist))
return alist;
alist = concat (1, &alist, Lisp_Cons, 0);
car = XCAR (tem);
if (CONSP (car))
- XCAR (tem) = Fcons (XCAR (car), XCDR (car));
+ XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
}
return alist;
}
DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
- "Return a substring of STRING, starting at index FROM and ending before TO.\n\
-TO may be nil or omitted; then the substring runs to the end of STRING.\n\
-If FROM or TO is negative, it counts from the end.\n\
-\n\
-This function allows vectors as well as strings.")
- (string, from, to)
+ doc: /* Return a substring of STRING, starting at index FROM and ending before TO.
+TO may be nil or omitted; then the substring runs to the end of STRING.
+If FROM or TO is negative, it counts from the end.
+
+This function allows vectors as well as strings. */)
+ (string, from, to)
Lisp_Object string;
register Lisp_Object from, to;
{
Lisp_Object res;
int size;
- int size_byte;
+ int size_byte = 0;
int from_char, to_char;
- int from_byte, to_byte;
+ int from_byte = 0, to_byte = 0;
if (! (STRINGP (string) || VECTORP (string)))
wrong_type_argument (Qarrayp, string);
- CHECK_NUMBER (from, 1);
+ CHECK_NUMBER (from);
if (STRINGP (string))
{
}
else
{
- CHECK_NUMBER (to, 2);
+ CHECK_NUMBER (to);
to_char = XINT (to);
if (to_char < 0)
return res;
}
+
+DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
+ doc: /* Return a substring of STRING, without text properties.
+It starts at index FROM and ending before TO.
+TO may be nil or omitted; then the substring runs to the end of STRING.
+If FROM is nil or omitted, the substring starts at the beginning of STRING.
+If FROM or TO is negative, it counts from the end.
+
+With one argument, just copy STRING without its properties. */)
+ (string, from, to)
+ Lisp_Object string;
+ register Lisp_Object from, to;
+{
+ int size, size_byte;
+ int from_char, to_char;
+ int from_byte, to_byte;
+
+ CHECK_STRING (string);
+
+ size = XSTRING (string)->size;
+ size_byte = STRING_BYTES (XSTRING (string));
+
+ if (NILP (from))
+ from_char = from_byte = 0;
+ else
+ {
+ CHECK_NUMBER (from);
+ from_char = XINT (from);
+ if (from_char < 0)
+ from_char += size;
+
+ from_byte = string_char_to_byte (string, from_char);
+ }
+
+ if (NILP (to))
+ {
+ to_char = size;
+ to_byte = size_byte;
+ }
+ else
+ {
+ CHECK_NUMBER (to);
+
+ to_char = XINT (to);
+ if (to_char < 0)
+ to_char += size;
+
+ to_byte = string_char_to_byte (string, to_char);
+ }
+
+ if (!(0 <= from_char && from_char <= to_char && to_char <= size))
+ args_out_of_range_3 (string, make_number (from_char),
+ make_number (to_char));
+
+ return make_specified_string (XSTRING (string)->data + from_byte,
+ to_char - from_char, to_byte - from_byte,
+ STRING_MULTIBYTE (string));
+}
+
/* Extract a substring of STRING, giving start and end positions
both in characters and in bytes. */
}
\f
DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
- "Take cdr N times on LIST, returns the result.")
- (n, list)
+ doc: /* Take cdr N times on LIST, returns the result. */)
+ (n, list)
Lisp_Object n;
register Lisp_Object list;
{
register int i, num;
- CHECK_NUMBER (n, 0);
+ CHECK_NUMBER (n);
num = XINT (n);
for (i = 0; i < num && !NILP (list); i++)
{
QUIT;
- list = Fcdr (list);
+ if (! CONSP (list))
+ wrong_type_argument (Qlistp, list);
+ list = XCDR (list);
}
return list;
}
DEFUN ("nth", Fnth, Snth, 2, 2, 0,
- "Return the Nth element of LIST.\n\
-N counts from zero. If LIST is not that long, nil is returned.")
- (n, list)
+ doc: /* Return the Nth element of LIST.
+N counts from zero. If LIST is not that long, nil is returned. */)
+ (n, list)
Lisp_Object n, list;
{
return Fcar (Fnthcdr (n, list));
}
DEFUN ("elt", Felt, Selt, 2, 2, 0,
- "Return element of SEQUENCE at index N.")
- (sequence, n)
+ doc: /* Return element of SEQUENCE at index N. */)
+ (sequence, n)
register Lisp_Object sequence, n;
{
- CHECK_NUMBER (n, 0);
+ CHECK_NUMBER (n);
while (1)
{
if (CONSP (sequence) || NILP (sequence))
}
DEFUN ("member", Fmember, Smember, 2, 2, 0,
- "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
-The value is actually the tail of LIST whose car is ELT.")
- (elt, list)
+doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
+The value is actually the tail of LIST whose car is ELT. */)
+ (elt, list)
register Lisp_Object elt;
Lisp_Object list;
{
for (tail = list; !NILP (tail); tail = XCDR (tail))
{
register Lisp_Object tem;
- tem = Fcar (tail);
+ if (! CONSP (tail))
+ wrong_type_argument (Qlistp, list);
+ tem = XCAR (tail);
if (! NILP (Fequal (elt, tem)))
return tail;
QUIT;
}
DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
- "Return non-nil if ELT is an element of LIST.\n\
-Comparison done with EQ. The value is actually the tail of LIST\n\
-whose car is ELT.")
- (elt, list)
+ doc: /* Return non-nil if ELT is an element of LIST.
+Comparison done with EQ. The value is actually the tail of LIST
+whose car is ELT. */)
+ (elt, list)
Lisp_Object elt, list;
{
while (1)
{
if (!CONSP (list) || EQ (XCAR (list), elt))
break;
-
+
list = XCDR (list);
if (!CONSP (list) || EQ (XCAR (list), elt))
break;
}
DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
- "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
-The value is actually the element of LIST whose car is KEY.\n\
-Elements of LIST that are not conses are ignored.")
- (key, list)
+ doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
+The value is actually the element of LIST whose car is KEY.
+Elements of LIST that are not conses are ignored. */)
+ (key, list)
Lisp_Object key, list;
{
Lisp_Object result;
|| (CONSP (XCAR (list))
&& EQ (XCAR (XCAR (list)), key)))
break;
-
+
list = XCDR (list);
if (!CONSP (list)
|| (CONSP (XCAR (list))
&& EQ (XCAR (XCAR (list)), key)))
break;
-
+
list = XCDR (list);
if (!CONSP (list)
|| (CONSP (XCAR (list))
&& EQ (XCAR (XCAR (list)), key)))
break;
-
+
list = XCDR (list);
QUIT;
}
}
DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
- "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
-The value is actually the element of LIST whose car equals KEY.")
- (key, list)
+ doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
+The value is actually the element of LIST whose car equals KEY. */)
+ (key, list)
Lisp_Object key, list;
{
Lisp_Object result, car;
&& (car = XCAR (XCAR (list)),
EQ (car, key) || !NILP (Fequal (car, key)))))
break;
-
+
list = XCDR (list);
if (!CONSP (list)
|| (CONSP (XCAR (list))
&& (car = XCAR (XCAR (list)),
EQ (car, key) || !NILP (Fequal (car, key)))))
break;
-
+
list = XCDR (list);
if (!CONSP (list)
|| (CONSP (XCAR (list))
&& (car = XCAR (XCAR (list)),
EQ (car, key) || !NILP (Fequal (car, key)))))
break;
-
+
list = XCDR (list);
QUIT;
}
}
DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
- "Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
-The value is actually the element of LIST whose cdr is KEY.")
- (key, list)
+ doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
+The value is actually the element of LIST whose cdr is KEY. */)
+ (key, list)
register Lisp_Object key;
Lisp_Object list;
{
|| (CONSP (XCAR (list))
&& EQ (XCDR (XCAR (list)), key)))
break;
-
+
list = XCDR (list);
if (!CONSP (list)
|| (CONSP (XCAR (list))
&& EQ (XCDR (XCAR (list)), key)))
break;
-
+
list = XCDR (list);
if (!CONSP (list)
|| (CONSP (XCAR (list))
&& EQ (XCDR (XCAR (list)), key)))
break;
-
+
list = XCDR (list);
QUIT;
}
}
DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
- "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
-The value is actually the element of LIST whose cdr equals KEY.")
- (key, list)
+ doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
+The value is actually the element of LIST whose cdr equals KEY. */)
+ (key, list)
Lisp_Object key, list;
{
Lisp_Object result, cdr;
&& (cdr = XCDR (XCAR (list)),
EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
break;
-
+
list = XCDR (list);
if (!CONSP (list)
|| (CONSP (XCAR (list))
&& (cdr = XCDR (XCAR (list)),
EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
break;
-
+
list = XCDR (list);
if (!CONSP (list)
|| (CONSP (XCAR (list))
&& (cdr = XCDR (XCAR (list)),
EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
break;
-
+
list = XCDR (list);
QUIT;
}
}
\f
DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
- "Delete by side effect any occurrences of ELT as a member of LIST.\n\
-The modified LIST is returned. Comparison is done with `eq'.\n\
-If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
-therefore, write `(setq foo (delq element foo))'\n\
-to be sure of changing the value of `foo'.")
- (elt, list)
+ doc: /* Delete by side effect any occurrences of ELT as a member of LIST.
+The modified LIST is returned. Comparison is done with `eq'.
+If the first member of LIST is ELT, there is no way to remove it by side effect;
+therefore, write `(setq foo (delq element foo))'
+to be sure of changing the value of `foo'. */)
+ (elt, list)
register Lisp_Object elt;
Lisp_Object list;
{
prev = Qnil;
while (!NILP (tail))
{
- tem = Fcar (tail);
+ if (! CONSP (tail))
+ wrong_type_argument (Qlistp, list);
+ tem = XCAR (tail);
if (EQ (elt, tem))
{
if (NILP (prev))
}
DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
- "Delete by side effect any occurrences of ELT as a member of LIST.\n\
-The modified LIST is returned. Comparison is done with `equal'.\n\
-If the first member of LIST is ELT, deleting it is not a side effect;\n\
-it is simply using a different list.\n\
-Therefore, write `(setq foo (delete element foo))'\n\
-to be sure of changing the value of `foo'.")
- (elt, list)
- register Lisp_Object elt;
- Lisp_Object list;
+ doc: /* Delete by side effect any occurrences of ELT as a member of SEQ.
+SEQ must be a list, a vector, or a string.
+The modified SEQ is returned. Comparison is done with `equal'.
+If SEQ is not a list, or the first member of SEQ is ELT, deleting it
+is not a side effect; it is simply using a different sequence.
+Therefore, write `(setq foo (delete element foo))'
+to be sure of changing the value of `foo'. */)
+ (elt, seq)
+ Lisp_Object elt, seq;
{
- register Lisp_Object tail, prev;
- register Lisp_Object tem;
+ if (VECTORP (seq))
+ {
+ EMACS_INT i, n;
- tail = list;
- prev = Qnil;
- while (!NILP (tail))
+ for (i = n = 0; i < ASIZE (seq); ++i)
+ if (NILP (Fequal (AREF (seq, i), elt)))
+ ++n;
+
+ if (n != ASIZE (seq))
+ {
+ struct Lisp_Vector *p = allocate_vector (n);
+
+ for (i = n = 0; i < ASIZE (seq); ++i)
+ if (NILP (Fequal (AREF (seq, i), elt)))
+ p->contents[n++] = AREF (seq, i);
+
+ XSETVECTOR (seq, p);
+ }
+ }
+ else if (STRINGP (seq))
{
- tem = Fcar (tail);
- if (! NILP (Fequal (elt, tem)))
+ EMACS_INT i, ibyte, nchars, nbytes, cbytes;
+ int c;
+
+ for (i = nchars = nbytes = ibyte = 0;
+ i < XSTRING (seq)->size;
+ ++i, ibyte += cbytes)
{
- if (NILP (prev))
- list = XCDR (tail);
+ if (STRING_MULTIBYTE (seq))
+ {
+ c = STRING_CHAR (&XSTRING (seq)->data[ibyte],
+ STRING_BYTES (XSTRING (seq)) - ibyte);
+ cbytes = CHAR_BYTES (c);
+ }
else
- Fsetcdr (prev, XCDR (tail));
+ {
+ c = XSTRING (seq)->data[i];
+ cbytes = 1;
+ }
+
+ if (!INTEGERP (elt) || c != XINT (elt))
+ {
+ ++nchars;
+ nbytes += cbytes;
+ }
+ }
+
+ if (nchars != XSTRING (seq)->size)
+ {
+ Lisp_Object tem;
+
+ tem = make_uninit_multibyte_string (nchars, nbytes);
+ if (!STRING_MULTIBYTE (seq))
+ SET_STRING_BYTES (XSTRING (tem), -1);
+
+ for (i = nchars = nbytes = ibyte = 0;
+ i < XSTRING (seq)->size;
+ ++i, ibyte += cbytes)
+ {
+ if (STRING_MULTIBYTE (seq))
+ {
+ c = STRING_CHAR (&XSTRING (seq)->data[ibyte],
+ STRING_BYTES (XSTRING (seq)) - ibyte);
+ cbytes = CHAR_BYTES (c);
+ }
+ else
+ {
+ c = XSTRING (seq)->data[i];
+ cbytes = 1;
+ }
+
+ if (!INTEGERP (elt) || c != XINT (elt))
+ {
+ unsigned char *from = &XSTRING (seq)->data[ibyte];
+ unsigned char *to = &XSTRING (tem)->data[nbytes];
+ EMACS_INT n;
+
+ ++nchars;
+ nbytes += cbytes;
+
+ for (n = cbytes; n--; )
+ *to++ = *from++;
+ }
+ }
+
+ seq = tem;
}
- else
- prev = tail;
- tail = XCDR (tail);
- QUIT;
}
- return list;
+ else
+ {
+ Lisp_Object tail, prev;
+
+ for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail))
+ {
+ if (!CONSP (tail))
+ wrong_type_argument (Qlistp, seq);
+
+ if (!NILP (Fequal (elt, XCAR (tail))))
+ {
+ if (NILP (prev))
+ seq = XCDR (tail);
+ else
+ Fsetcdr (prev, XCDR (tail));
+ }
+ else
+ prev = tail;
+ QUIT;
+ }
+ }
+
+ return seq;
}
DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
- "Reverse LIST by modifying cdr pointers.\n\
-Returns the beginning of the reversed list.")
- (list)
+ doc: /* Reverse LIST by modifying cdr pointers.
+Returns the beginning of the reversed list. */)
+ (list)
Lisp_Object list;
{
register Lisp_Object prev, tail, next;
while (!NILP (tail))
{
QUIT;
- next = Fcdr (tail);
+ if (! CONSP (tail))
+ wrong_type_argument (Qlistp, list);
+ next = XCDR (tail);
Fsetcdr (tail, prev);
prev = tail;
tail = next;
}
DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
- "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
-See also the function `nreverse', which is used more often.")
- (list)
+ doc: /* Reverse LIST, copying. Returns the beginning of the reversed list.
+See also the function `nreverse', which is used more often. */)
+ (list)
Lisp_Object list;
{
Lisp_Object new;
Lisp_Object merge ();
DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
- "Sort LIST, stably, comparing elements using PREDICATE.\n\
-Returns the sorted list. LIST is modified by side effects.\n\
-PREDICATE is called with two elements of LIST, and should return T\n\
-if the first element is \"less\" than the second.")
- (list, predicate)
+ doc: /* Sort LIST, stably, comparing elements using PREDICATE.
+Returns the sorted list. LIST is modified by side effects.
+PREDICATE is called with two elements of LIST, and should return t
+if the first element is "less" than the second. */)
+ (list, predicate)
Lisp_Object list, predicate;
{
Lisp_Object front, back;
tail = tem;
}
}
-\f
+\f
DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
- "Extract a value from a property list.\n\
-PLIST is a property list, which is a list of the form\n\
-\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
-corresponding to the given PROP, or nil if PROP is not\n\
-one of the properties on the list.")
- (plist, prop)
+ doc: /* Extract a value from a property list.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
+corresponding to the given PROP, or nil if PROP is not
+one of the properties on the list. */)
+ (plist, prop)
Lisp_Object plist;
- register Lisp_Object prop;
+ Lisp_Object prop;
{
- register Lisp_Object tail;
- for (tail = plist; !NILP (tail); tail = Fcdr (XCDR (tail)))
+ Lisp_Object tail;
+
+ for (tail = plist;
+ CONSP (tail) && CONSP (XCDR (tail));
+ tail = XCDR (XCDR (tail)))
{
- register Lisp_Object tem;
- tem = Fcar (tail);
- if (EQ (prop, tem))
- return Fcar (XCDR (tail));
+ if (EQ (prop, XCAR (tail)))
+ return XCAR (XCDR (tail));
+
+ /* This function can be called asynchronously
+ (setup_coding_system). Don't QUIT in that case. */
+ if (!interrupt_input_blocked)
+ QUIT;
}
+
+ if (!NILP (tail))
+ wrong_type_argument (Qlistp, prop);
+
return Qnil;
}
DEFUN ("get", Fget, Sget, 2, 2, 0,
- "Return the value of SYMBOL's PROPNAME property.\n\
-This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
- (symbol, propname)
+ doc: /* Return the value of SYMBOL's PROPNAME property.
+This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
+ (symbol, propname)
Lisp_Object symbol, propname;
{
- CHECK_SYMBOL (symbol, 0);
+ CHECK_SYMBOL (symbol);
return Fplist_get (XSYMBOL (symbol)->plist, propname);
}
DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
- "Change value in PLIST of PROP to VAL.\n\
-PLIST is a property list, which is a list of the form\n\
-\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
-If PROP is already a property on the list, its value is set to VAL,\n\
-otherwise the new PROP VAL pair is added. The new plist is returned;\n\
-use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
-The PLIST is modified by side effects.")
- (plist, prop, val)
+ doc: /* Change value in PLIST of PROP to VAL.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
+If PROP is already a property on the list, its value is set to VAL,
+otherwise the new PROP VAL pair is added. The new plist is returned;
+use `(setq x (plist-put x prop val))' to be sure to use the new value.
+The PLIST is modified by side effects. */)
+ (plist, prop, val)
Lisp_Object plist;
register Lisp_Object prop;
Lisp_Object val;
Fsetcar (XCDR (tail), val);
return plist;
}
+
prev = tail;
+ QUIT;
}
newcell = Fcons (prop, Fcons (val, Qnil));
if (NILP (prev))
}
DEFUN ("put", Fput, Sput, 3, 3, 0,
- "Store SYMBOL's PROPNAME property with value VALUE.\n\
-It can be retrieved with `(get SYMBOL PROPNAME)'.")
- (symbol, propname, value)
+ doc: /* Store SYMBOL's PROPNAME property with value VALUE.
+It can be retrieved with `(get SYMBOL PROPNAME)'. */)
+ (symbol, propname, value)
Lisp_Object symbol, propname, value;
{
- CHECK_SYMBOL (symbol, 0);
+ CHECK_SYMBOL (symbol);
XSYMBOL (symbol)->plist
= Fplist_put (XSYMBOL (symbol)->plist, propname, value);
return value;
}
+\f
+DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0,
+ doc: /* Extract a value from a property list, comparing with `equal'.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
+corresponding to the given PROP, or nil if PROP is not
+one of the properties on the list. */)
+ (plist, prop)
+ Lisp_Object plist;
+ Lisp_Object prop;
+{
+ Lisp_Object tail;
+
+ for (tail = plist;
+ CONSP (tail) && CONSP (XCDR (tail));
+ tail = XCDR (XCDR (tail)))
+ {
+ if (! NILP (Fequal (prop, XCAR (tail))))
+ return XCAR (XCDR (tail));
+
+ QUIT;
+ }
+
+ if (!NILP (tail))
+ wrong_type_argument (Qlistp, prop);
+
+ return Qnil;
+}
+DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0,
+ doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
+If PROP is already a property on the list, its value is set to VAL,
+otherwise the new PROP VAL pair is added. The new plist is returned;
+use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
+The PLIST is modified by side effects. */)
+ (plist, prop, val)
+ Lisp_Object plist;
+ register Lisp_Object prop;
+ Lisp_Object val;
+{
+ register Lisp_Object tail, prev;
+ Lisp_Object newcell;
+ prev = Qnil;
+ for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
+ tail = XCDR (XCDR (tail)))
+ {
+ if (! NILP (Fequal (prop, XCAR (tail))))
+ {
+ Fsetcar (XCDR (tail), val);
+ return plist;
+ }
+
+ prev = tail;
+ QUIT;
+ }
+ newcell = Fcons (prop, Fcons (val, Qnil));
+ if (NILP (prev))
+ return newcell;
+ else
+ Fsetcdr (XCDR (prev), newcell);
+ return plist;
+}
+\f
DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
- "Return t if two Lisp objects have similar structure and contents.\n\
-They must have the same data type.\n\
-Conses are compared by comparing the cars and the cdrs.\n\
-Vectors and strings are compared element by element.\n\
-Numbers are compared by value, but integers cannot equal floats.\n\
- (Use `=' if you want integers and floats to be able to be equal.)\n\
-Symbols must match exactly.")
- (o1, o2)
+ doc: /* Return t if two Lisp objects have similar structure and contents.
+They must have the same data type.
+Conses are compared by comparing the cars and the cdrs.
+Vectors and strings are compared element by element.
+Numbers are compared by value, but integers cannot equal floats.
+ (Use `=' if you want integers and floats to be able to be equal.)
+Symbols must match exactly. */)
+ (o1, o2)
register Lisp_Object o1, o2;
{
return internal_equal (o1, o2, 0) ? Qt : Qnil;
switch (XTYPE (o1))
{
-#ifdef LISP_FLOAT_TYPE
case Lisp_Float:
return (extract_float (o1) == extract_float (o2));
-#endif
case Lisp_Cons:
if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1))
STRING_BYTES (XSTRING (o1))))
return 0;
return 1;
+
+ case Lisp_Int:
+ case Lisp_Symbol:
+ case Lisp_Type_Limit:
+ break;
}
+
return 0;
}
\f
extern Lisp_Object Fmake_char_internal ();
DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
- "Store each element of ARRAY with ITEM.\n\
-ARRAY is a vector, string, char-table, or bool-vector.")
- (array, item)
+ doc: /* Store each element of ARRAY with ITEM.
+ARRAY is a vector, string, char-table, or bool-vector. */)
+ (array, item)
Lisp_Object array, item;
{
register int size, index, charval;
else if (STRINGP (array))
{
register unsigned char *p = XSTRING (array)->data;
- CHECK_NUMBER (item, 1);
+ CHECK_NUMBER (item);
charval = XINT (item);
size = XSTRING (array)->size;
if (STRING_MULTIBYTE (array))
{
- unsigned char workbuf[4], *str;
- int len = CHAR_STRING (charval, workbuf, str);
+ unsigned char str[MAX_MULTIBYTE_LENGTH];
+ int len = CHAR_STRING (charval, str);
int size_byte = STRING_BYTES (XSTRING (array));
unsigned char *p1 = p, *endp = p + size_byte;
int i;
\f
DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
1, 1, 0,
- "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
- (char_table)
+ doc: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
+ (char_table)
Lisp_Object char_table;
{
- CHECK_CHAR_TABLE (char_table, 0);
+ CHECK_CHAR_TABLE (char_table);
return XCHAR_TABLE (char_table)->purpose;
}
DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
1, 1, 0,
- "Return the parent char-table of CHAR-TABLE.\n\
-The value is either nil or another char-table.\n\
-If CHAR-TABLE holds nil for a given character,\n\
-then the actual applicable value is inherited from the parent char-table\n\
-\(or from its parents, if necessary).")
- (char_table)
+ doc: /* Return the parent char-table of CHAR-TABLE.
+The value is either nil or another char-table.
+If CHAR-TABLE holds nil for a given character,
+then the actual applicable value is inherited from the parent char-table
+\(or from its parents, if necessary). */)
+ (char_table)
Lisp_Object char_table;
{
- CHECK_CHAR_TABLE (char_table, 0);
+ CHECK_CHAR_TABLE (char_table);
return XCHAR_TABLE (char_table)->parent;
}
DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
2, 2, 0,
- "Set the parent char-table of CHAR-TABLE to PARENT.\n\
-PARENT must be either nil or another char-table.")
- (char_table, parent)
+ doc: /* Set the parent char-table of CHAR-TABLE to PARENT.
+PARENT must be either nil or another char-table. */)
+ (char_table, parent)
Lisp_Object char_table, parent;
{
Lisp_Object temp;
- CHECK_CHAR_TABLE (char_table, 0);
+ CHECK_CHAR_TABLE (char_table);
if (!NILP (parent))
{
- CHECK_CHAR_TABLE (parent, 0);
+ CHECK_CHAR_TABLE (parent);
for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
if (EQ (temp, char_table))
DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
2, 2, 0,
- "Return the value of CHAR-TABLE's extra-slot number N.")
- (char_table, n)
+ doc: /* Return the value of CHAR-TABLE's extra-slot number N. */)
+ (char_table, n)
Lisp_Object char_table, n;
{
- CHECK_CHAR_TABLE (char_table, 1);
- CHECK_NUMBER (n, 2);
+ CHECK_CHAR_TABLE (char_table);
+ CHECK_NUMBER (n);
if (XINT (n) < 0
|| XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
args_out_of_range (char_table, n);
DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
Sset_char_table_extra_slot,
3, 3, 0,
- "Set CHAR-TABLE's extra-slot number N to VALUE.")
- (char_table, n, value)
+ doc: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
+ (char_table, n, value)
Lisp_Object char_table, n, value;
{
- CHECK_CHAR_TABLE (char_table, 1);
- CHECK_NUMBER (n, 2);
+ CHECK_CHAR_TABLE (char_table);
+ CHECK_NUMBER (n);
if (XINT (n) < 0
|| XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
args_out_of_range (char_table, n);
\f
DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
2, 2, 0,
- "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
-RANGE should be nil (for the default value)\n\
-a vector which identifies a character set or a row of a character set,\n\
-a character set name, or a character code.")
- (char_table, range)
+ doc: /* Return the value in CHAR-TABLE for a range of characters RANGE.
+RANGE should be nil (for the default value)
+a vector which identifies a character set or a row of a character set,
+a character set name, or a character code. */)
+ (char_table, range)
Lisp_Object char_table, range;
{
- CHECK_CHAR_TABLE (char_table, 0);
+ CHECK_CHAR_TABLE (char_table);
if (EQ (range, Qnil))
return XCHAR_TABLE (char_table)->defalt;
Lisp_Object charset_info;
charset_info = Fget (range, Qcharset);
- CHECK_VECTOR (charset_info, 0);
+ CHECK_VECTOR (charset_info);
return Faref (char_table,
make_number (XINT (XVECTOR (charset_info)->contents[0])
}
else
error ("Invalid RANGE argument to `char-table-range'");
+ return Qt;
}
DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
3, 3, 0,
- "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
-RANGE should be t (for all characters), nil (for the default value)\n\
-a vector which identifies a character set or a row of a character set,\n\
-a coding system, or a character code.")
- (char_table, range, value)
+ doc: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
+RANGE should be t (for all characters), nil (for the default value)
+a vector which identifies a character set or a row of a character set,
+a coding system, or a character code. */)
+ (char_table, range, value)
Lisp_Object char_table, range, value;
{
int i;
- CHECK_CHAR_TABLE (char_table, 0);
+ CHECK_CHAR_TABLE (char_table);
if (EQ (range, Qt))
for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
Lisp_Object charset_info;
charset_info = Fget (range, Qcharset);
- CHECK_VECTOR (charset_info, 0);
+ CHECK_VECTOR (charset_info);
return Faset (char_table,
make_number (XINT (XVECTOR (charset_info)->contents[0])
DEFUN ("set-char-table-default", Fset_char_table_default,
Sset_char_table_default, 3, 3, 0,
- "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
-The generic character specifies the group of characters.\n\
-See also the documentation of make-char.")
- (char_table, ch, value)
+ doc: /* Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.
+The generic character specifies the group of characters.
+See also the documentation of make-char. */)
+ (char_table, ch, value)
Lisp_Object char_table, ch, value;
{
int c, charset, code1, code2;
Lisp_Object temp;
- CHECK_CHAR_TABLE (char_table, 0);
- CHECK_NUMBER (ch, 1);
+ CHECK_CHAR_TABLE (char_table);
+ CHECK_NUMBER (ch);
c = XINT (ch);
SPLIT_CHAR (c, charset, code1, code2);
/* Even if C is not a generic char, we had better behave as if a
generic char is specified. */
- if (charset == CHARSET_COMPOSITION || CHARSET_DIMENSION (charset) == 1)
+ if (!CHARSET_DEFINED_P (charset) || CHARSET_DIMENSION (charset) == 1)
code1 = 0;
temp = XCHAR_TABLE (char_table)->contents[charset + 128];
if (!code1)
XCHAR_TABLE (char_table)->contents[charset + 128] = value;
return value;
}
- char_table = temp;
- if (! SUB_CHAR_TABLE_P (char_table))
+ if (SUB_CHAR_TABLE_P (temp))
+ char_table = temp;
+ else
char_table = (XCHAR_TABLE (char_table)->contents[charset + 128]
- = make_sub_char_table (temp));
+ = make_sub_char_table (temp));
temp = XCHAR_TABLE (char_table)->contents[code1];
if (SUB_CHAR_TABLE_P (temp))
XCHAR_TABLE (temp)->defalt = value;
return ch;
return XINT (value);
}
+
+static void
+optimize_sub_char_table (table, chars)
+ Lisp_Object *table;
+ int chars;
+{
+ Lisp_Object elt;
+ int from, to;
+
+ if (chars == 94)
+ from = 33, to = 127;
+ else
+ from = 32, to = 128;
+
+ if (!SUB_CHAR_TABLE_P (*table))
+ return;
+ elt = XCHAR_TABLE (*table)->contents[from++];
+ for (; from < to; from++)
+ if (NILP (Fequal (elt, XCHAR_TABLE (*table)->contents[from])))
+ return;
+ *table = elt;
+}
+
+DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table,
+ 1, 1, 0, doc: /* Optimize char table TABLE. */)
+ (table)
+ Lisp_Object table;
+{
+ Lisp_Object elt;
+ int dim;
+ int i, j;
+
+ CHECK_CHAR_TABLE (table);
+
+ for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
+ {
+ elt = XCHAR_TABLE (table)->contents[i];
+ if (!SUB_CHAR_TABLE_P (elt))
+ continue;
+ dim = CHARSET_DIMENSION (i - 128);
+ if (dim == 2)
+ for (j = 32; j < SUB_CHAR_TABLE_ORDINARY_SLOTS; j++)
+ optimize_sub_char_table (XCHAR_TABLE (elt)->contents + j, dim);
+ optimize_sub_char_table (XCHAR_TABLE (table)->contents + i, dim);
+ }
+ return Qnil;
+}
+
\f
/* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
character or group of characters that share a value.
}
else
{
+ int charset = XFASTINT (indices[0]) - 128;
+
i = 32;
to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
+ if (CHARSET_CHARS (charset) == 94)
+ i++, to--;
}
for (; i < to; i++)
{
- Lisp_Object elt = XCHAR_TABLE (subtable)->contents[i];
+ Lisp_Object elt;
+ int charset;
+ elt = XCHAR_TABLE (subtable)->contents[i];
XSETFASTINT (indices[depth], i);
+ charset = XFASTINT (indices[0]) - 128;
+ if (depth == 0
+ && (!CHARSET_DEFINED_P (charset)
+ || charset == CHARSET_8_BIT_CONTROL
+ || charset == CHARSET_8_BIT_GRAPHIC))
+ continue;
if (SUB_CHAR_TABLE_P (elt))
{
}
else
{
- int charset = XFASTINT (indices[0]) - 128, c1, c2, c;
+ int c1, c2, c;
- if (CHARSET_DEFINED_P (charset))
- {
- c1 = depth >= 1 ? XFASTINT (indices[1]) : 0;
- c2 = depth >= 2 ? XFASTINT (indices[2]) : 0;
- c = MAKE_NON_ASCII_CHAR (charset, c1, c2);
- if (c_function)
- (*c_function) (arg, make_number (c), elt);
- else
- call2 (function, make_number (c), elt);
- }
+ if (NILP (elt))
+ elt = XCHAR_TABLE (subtable)->defalt;
+ c1 = depth >= 1 ? XFASTINT (indices[1]) : 0;
+ c2 = depth >= 2 ? XFASTINT (indices[2]) : 0;
+ c = MAKE_CHAR (charset, c1, c2);
+ if (c_function)
+ (*c_function) (arg, make_number (c), elt);
+ else
+ call2 (function, make_number (c), elt);
}
}
}
DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
- 2, 2, 0,
- "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
-FUNCTION is called with two arguments--a key and a value.\n\
-The key is always a possible IDX argument to `aref'.")
- (function, char_table)
+ 2, 2, 0,
+ doc: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
+FUNCTION is called with two arguments--a key and a value.
+The key is always a possible IDX argument to `aref'. */)
+ (function, char_table)
Lisp_Object function, char_table;
{
/* The depth of char table is at most 3. */
Lisp_Object indices[3];
- CHECK_CHAR_TABLE (char_table, 1);
+ CHECK_CHAR_TABLE (char_table);
map_char_table (NULL, function, char_table, char_table, 0, indices);
return Qnil;
}
+
+/* Return a value for character C in char-table TABLE. Store the
+ actual index for that value in *IDX. Ignore the default value of
+ TABLE. */
+
+Lisp_Object
+char_table_ref_and_index (table, c, idx)
+ Lisp_Object table;
+ int c, *idx;
+{
+ int charset, c1, c2;
+ Lisp_Object elt;
+
+ if (SINGLE_BYTE_CHAR_P (c))
+ {
+ *idx = c;
+ return XCHAR_TABLE (table)->contents[c];
+ }
+ SPLIT_CHAR (c, charset, c1, c2);
+ elt = XCHAR_TABLE (table)->contents[charset + 128];
+ *idx = MAKE_CHAR (charset, 0, 0);
+ if (!SUB_CHAR_TABLE_P (elt))
+ return elt;
+ if (c1 < 32 || NILP (XCHAR_TABLE (elt)->contents[c1]))
+ return XCHAR_TABLE (elt)->defalt;
+ elt = XCHAR_TABLE (elt)->contents[c1];
+ *idx = MAKE_CHAR (charset, c1, 0);
+ if (!SUB_CHAR_TABLE_P (elt))
+ return elt;
+ if (c2 < 32 || NILP (XCHAR_TABLE (elt)->contents[c2]))
+ return XCHAR_TABLE (elt)->defalt;
+ *idx = c;
+ return XCHAR_TABLE (elt)->contents[c2];
+}
+
\f
/* ARGSUSED */
Lisp_Object
}
DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
- "Concatenate any number of lists by altering them.\n\
-Only the last argument is not altered, and need not be a list.")
- (nargs, args)
+ doc: /* Concatenate any number of lists by altering them.
+Only the last argument is not altered, and need not be a list.
+usage: (nconc &rest LISTS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
register int argnum;
register Lisp_Object tail, tem, val;
- val = Qnil;
+ val = tail = Qnil;
for (argnum = 0; argnum < nargs; argnum++)
{
register int i;
struct gcpro gcpro1, gcpro2, gcpro3;
- /* Don't let vals contain any garbage when GC happens. */
- for (i = 0; i < leni; i++)
- vals[i] = Qnil;
+ if (vals)
+ {
+ /* Don't let vals contain any garbage when GC happens. */
+ for (i = 0; i < leni; i++)
+ vals[i] = Qnil;
- GCPRO3 (dummy, fn, seq);
- gcpro1.var = vals;
- gcpro1.nvars = leni;
+ GCPRO3 (dummy, fn, seq);
+ gcpro1.var = vals;
+ gcpro1.nvars = leni;
+ }
+ else
+ GCPRO2 (fn, seq);
/* We need not explicitly protect `tail' because it is used only on lists, and
1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
for (i = 0; i < leni; i++)
{
dummy = XVECTOR (seq)->contents[i];
- vals[i] = call1 (fn, dummy);
+ dummy = call1 (fn, dummy);
+ if (vals)
+ vals[i] = dummy;
}
}
else if (BOOL_VECTOR_P (seq))
else
dummy = Qnil;
- vals[i] = call1 (fn, dummy);
+ dummy = call1 (fn, dummy);
+ if (vals)
+ vals[i] = dummy;
}
}
- else if (STRINGP (seq) && ! STRING_MULTIBYTE (seq))
+ else if (STRINGP (seq))
{
- /* Single-byte string. */
- for (i = 0; i < leni; i++)
- {
- XSETFASTINT (dummy, XSTRING (seq)->data[i]);
- vals[i] = call1 (fn, dummy);
- }
- }
- else if (STRINGP (seq))
- {
- /* Multi-byte string. */
int i_byte;
for (i = 0, i_byte = 0; i < leni;)
FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
XSETFASTINT (dummy, c);
- vals[i_before] = call1 (fn, dummy);
+ dummy = call1 (fn, dummy);
+ if (vals)
+ vals[i_before] = dummy;
}
}
else /* Must be a list, since Flength did not get an error */
tail = seq;
for (i = 0; i < leni; i++)
{
- vals[i] = call1 (fn, Fcar (tail));
+ dummy = call1 (fn, Fcar (tail));
+ if (vals)
+ vals[i] = dummy;
tail = XCDR (tail);
}
}
}
DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
- "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
-In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
-SEPARATOR results in spaces between the values returned by FUNCTION.\n\
-SEQUENCE may be a list, a vector, a bool-vector, or a string.")
- (function, sequence, separator)
+ doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
+In between each pair of results, stick in SEPARATOR. Thus, " " as
+SEPARATOR results in spaces between the values returned by FUNCTION.
+SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
+ (function, sequence, separator)
Lisp_Object function, sequence, separator;
{
Lisp_Object len;
}
DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
- "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
-The result is a list just as long as SEQUENCE.\n\
-SEQUENCE may be a list, a vector, a bool-vector, or a string.")
- (function, sequence)
+ doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
+The result is a list just as long as SEQUENCE.
+SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
+ (function, sequence)
Lisp_Object function, sequence;
{
register Lisp_Object len;
return Flist (leni, args);
}
+
+DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
+ doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
+Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
+SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
+ (function, sequence)
+ Lisp_Object function, sequence;
+{
+ register int leni;
+
+ leni = XFASTINT (Flength (sequence));
+ mapcar1 (leni, 0, function, sequence);
+
+ return sequence;
+}
\f
/* Anything that calls this function must protect from GC! */
DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
- "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
-Takes one argument, which is the string to display to ask the question.\n\
-It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
-No confirmation of the answer is requested; a single character is enough.\n\
-Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses\n\
-the bindings in query-replace-map; see the documentation of that variable\n\
-for more information. In this case, the useful bindings are `act', `skip',\n\
-`recenter', and `quit'.\)\n\
-\n\
-Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
-is nil.")
- (prompt)
+ doc: /* Ask user a "y or n" question. Return t if answer is "y".
+Takes one argument, which is the string to display to ask the question.
+It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
+No confirmation of the answer is requested; a single character is enough.
+Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
+the bindings in `query-replace-map'; see the documentation of that variable
+for more information. In this case, the useful bindings are `act', `skip',
+`recenter', and `quit'.\)
+
+Under a windowing system a dialog box will be used if `last-nonmenu-event'
+is nil and `use-dialog-box' is non-nil. */)
+ (prompt)
Lisp_Object prompt;
{
register Lisp_Object obj, key, def, map;
map = Fsymbol_value (intern ("query-replace-map"));
- CHECK_STRING (prompt, 0);
+ CHECK_STRING (prompt);
xprompt = prompt;
GCPRO2 (prompt, xprompt);
+#ifdef HAVE_X_WINDOWS
+ if (display_hourglass_p)
+ cancel_hourglass ();
+#endif
+
while (1)
{
&& have_menus_p ())
{
Lisp_Object pane, menu;
- redisplay_preserve_echo_area ();
+ redisplay_preserve_echo_area (3);
pane = Fcons (Fcons (build_string ("Yes"), Qt),
Fcons (Fcons (build_string ("No"), Qnil),
Qnil));
#endif /* HAVE_MENUS */
cursor_in_echo_area = 1;
choose_minibuf_frame ();
- message_with_string ("%s(y or n) ", xprompt, 0);
+
+ {
+ Lisp_Object pargs[3];
+
+ /* Colorize prompt according to `minibuffer-prompt' face. */
+ pargs[0] = build_string ("%s(y or n) ");
+ pargs[1] = intern ("face");
+ pargs[2] = intern ("minibuffer-prompt");
+ args[0] = Fpropertize (3, pargs);
+ args[1] = xprompt;
+ Fmessage (2, args);
+ }
if (minibuffer_auto_raise)
{
/* Anything that calls this function must protect from GC! */
DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
- "Ask user a yes-or-no question. Return t if answer is yes.\n\
-Takes one argument, which is the string to display to ask the question.\n\
-It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
-The user must confirm the answer with RET,\n\
-and can edit it until it has been confirmed.\n\
-\n\
-Under a windowing system a dialog box will be used if `last-nonmenu-event'\n\
-is nil.")
- (prompt)
+ doc: /* Ask user a yes-or-no question. Return t if answer is yes.
+Takes one argument, which is the string to display to ask the question.
+It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
+The user must confirm the answer with RET,
+and can edit it until it has been confirmed.
+
+Under a windowing system a dialog box will be used if `last-nonmenu-event'
+is nil, and `use-dialog-box' is non-nil. */)
+ (prompt)
Lisp_Object prompt;
{
register Lisp_Object ans;
Lisp_Object args[2];
struct gcpro gcpro1;
- CHECK_STRING (prompt, 0);
+ CHECK_STRING (prompt);
#ifdef HAVE_MENUS
if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
&& have_menus_p ())
{
Lisp_Object pane, menu, obj;
- redisplay_preserve_echo_area ();
+ redisplay_preserve_echo_area (4);
pane = Fcons (Fcons (build_string ("Yes"), Qt),
Fcons (Fcons (build_string ("No"), Qnil),
Qnil));
}
\f
DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
- "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
-Each of the three load averages is multiplied by 100,\n\
-then converted to integer.\n\
-When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
-These floats are not multiplied by 100.\n\n\
-If the 5-minute or 15-minute load averages are not available, return a\n\
-shortened list, containing only those averages which are available.")
- (use_floats)
+ doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
+
+Each of the three load averages is multiplied by 100, then converted
+to integer.
+
+When USE-FLOATS is non-nil, floats will be used instead of integers.
+These floats are not multiplied by 100.
+
+If the 5-minute or 15-minute load averages are not available, return a
+shortened list, containing only those averages which are available. */)
+ (use_floats)
Lisp_Object use_floats;
{
double load_ave[3];
return ret;
}
\f
-Lisp_Object Vfeatures;
-
-DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
- "Returns t if FEATURE is present in this Emacs.\n\
-Use this to conditionalize execution of lisp code based on the presence or\n\
-absence of emacs or environment extensions.\n\
-Use `provide' to declare that a feature is available.\n\
-This function looks at the value of the variable `features'.")
- (feature)
- Lisp_Object feature;
+Lisp_Object Vfeatures, Qsubfeatures;
+extern Lisp_Object Vafter_load_alist;
+
+DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
+ doc: /* Returns t if FEATURE is present in this Emacs.
+
+Use this to conditionalize execution of lisp code based on the
+presence or absence of emacs or environment extensions.
+Use `provide' to declare that a feature is available. This function
+looks at the value of the variable `features'. The optional argument
+SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
+ (feature, subfeature)
+ Lisp_Object feature, subfeature;
{
register Lisp_Object tem;
- CHECK_SYMBOL (feature, 0);
+ CHECK_SYMBOL (feature);
tem = Fmemq (feature, Vfeatures);
+ if (!NILP (tem) && !NILP (subfeature))
+ tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
return (NILP (tem)) ? Qnil : Qt;
}
-DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
- "Announce that FEATURE is a feature of the current Emacs.")
- (feature)
- Lisp_Object feature;
+DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
+ doc: /* Announce that FEATURE is a feature of the current Emacs.
+The optional argument SUBFEATURES should be a list of symbols listing
+particular subfeatures supported in this version of FEATURE. */)
+ (feature, subfeatures)
+ Lisp_Object feature, subfeatures;
{
register Lisp_Object tem;
- CHECK_SYMBOL (feature, 0);
+ CHECK_SYMBOL (feature);
+ CHECK_LIST (subfeatures);
if (!NILP (Vautoload_queue))
Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
Vfeatures = Fcons (feature, Vfeatures);
+ if (!NILP (subfeatures))
+ Fput (feature, Qsubfeatures, subfeatures);
LOADHIST_ATTACH (Fcons (Qprovide, feature));
+
+ /* Run any load-hooks for this file. */
+ tem = Fassq (feature, Vafter_load_alist);
+ if (!NILP (tem))
+ Fprogn (Fcdr (tem));
+
return feature;
}
+\f
+/* `require' and its subroutines. */
+
+/* List of features currently being require'd, innermost first. */
+
+Lisp_Object require_nesting_list;
+
+Lisp_Object
+require_unwind (old_value)
+ Lisp_Object old_value;
+{
+ return require_nesting_list = old_value;
+}
DEFUN ("require", Frequire, Srequire, 1, 3, 0,
- "If feature FEATURE is not loaded, load it from FILENAME.\n\
-If FEATURE is not a member of the list `features', then the feature\n\
-is not loaded; so load the file FILENAME.\n\
-If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
-but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
-If the optional third argument NOERROR is non-nil,\n\
-then return nil if the file is not found.\n\
-Normally the return value is FEATURE.")
- (feature, file_name, noerror)
- Lisp_Object feature, file_name, noerror;
+ doc: /* If feature FEATURE is not loaded, load it from FILENAME.
+If FEATURE is not a member of the list `features', then the feature
+is not loaded; so load the file FILENAME.
+If FILENAME is omitted, the printname of FEATURE is used as the file name,
+and `load' will try to load this name appended with the suffix `.elc',
+`.el' or the unmodified name, in that order.
+If the optional third argument NOERROR is non-nil,
+then return nil if the file is not found instead of signaling an error.
+Normally the return value is FEATURE.
+The normal messages at start and end of loading FILENAME are suppressed. */)
+ (feature, filename, noerror)
+ Lisp_Object feature, filename, noerror;
{
register Lisp_Object tem;
- CHECK_SYMBOL (feature, 0);
+ struct gcpro gcpro1, gcpro2;
+
+ CHECK_SYMBOL (feature);
+
tem = Fmemq (feature, Vfeatures);
+
LOADHIST_ATTACH (Fcons (Qrequire, feature));
+
if (NILP (tem))
{
int count = specpdl_ptr - specpdl;
+ int nesting = 0;
+
+ /* This is to make sure that loadup.el gives a clear picture
+ of what files are preloaded and when. */
+ if (! NILP (Vpurify_flag))
+ error ("(require %s) while preparing to dump",
+ XSTRING (SYMBOL_NAME (feature))->data);
+
+ /* A certain amount of recursive `require' is legitimate,
+ but if we require the same feature recursively 3 times,
+ signal an error. */
+ tem = require_nesting_list;
+ while (! NILP (tem))
+ {
+ if (! NILP (Fequal (feature, XCAR (tem))))
+ nesting++;
+ tem = XCDR (tem);
+ }
+ if (nesting > 2)
+ error ("Recursive `require' for feature `%s'",
+ XSTRING (SYMBOL_NAME (feature))->data);
+
+ /* Update the list for any nested `require's that occur. */
+ record_unwind_protect (require_unwind, require_nesting_list);
+ require_nesting_list = Fcons (feature, require_nesting_list);
/* Value saved here is to be restored into Vautoload_queue */
record_unwind_protect (un_autoload, Vautoload_queue);
Vautoload_queue = Qt;
- tem = Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
- noerror, Qt, Qnil, (NILP (file_name) ? Qt : Qnil));
+ /* Load the file. */
+ GCPRO2 (feature, filename);
+ tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename,
+ noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
+ UNGCPRO;
+
/* If load failed entirely, return nil. */
if (NILP (tem))
return unbind_to (count, Qnil);
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
- error ("Required feature %s was not provided",
- XSYMBOL (feature)->name->data);
+ error ("Required feature `%s' was not provided",
+ XSTRING (SYMBOL_NAME (feature))->data);
/* Once loading finishes, don't undo it. */
Vautoload_queue = Qt;
feature = unbind_to (count, feature);
}
+
return feature;
}
\f
bottleneck of Widget operation. Here is their translation to C,
for the sole reason of efficiency. */
-DEFUN ("widget-plist-member", Fwidget_plist_member, Swidget_plist_member, 2, 2, 0,
- "Return non-nil if PLIST has the property PROP.\n\
-PLIST is a property list, which is a list of the form\n\
-\(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
-Unlike `plist-get', this allows you to distinguish between a missing\n\
-property and a property with the value nil.\n\
-The value is actually the tail of PLIST whose car is PROP.")
- (plist, prop)
+DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
+ doc: /* Return non-nil if PLIST has the property PROP.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
+Unlike `plist-get', this allows you to distinguish between a missing
+property and a property with the value nil.
+The value is actually the tail of PLIST whose car is PROP. */)
+ (plist, prop)
Lisp_Object plist, prop;
{
while (CONSP (plist) && !EQ (XCAR (plist), prop))
}
DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
- "In WIDGET, set PROPERTY to VALUE.\n\
-The value can later be retrieved with `widget-get'.")
- (widget, property, value)
+ doc: /* In WIDGET, set PROPERTY to VALUE.
+The value can later be retrieved with `widget-get'. */)
+ (widget, property, value)
Lisp_Object widget, property, value;
{
- CHECK_CONS (widget, 1);
- XCDR (widget) = Fplist_put (XCDR (widget), property, value);
+ CHECK_CONS (widget);
+ XSETCDR (widget, Fplist_put (XCDR (widget), property, value));
return value;
}
DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
- "In WIDGET, get the value of PROPERTY.\n\
-The value could either be specified when the widget was created, or\n\
-later with `widget-put'.")
- (widget, property)
+ doc: /* In WIDGET, get the value of PROPERTY.
+The value could either be specified when the widget was created, or
+later with `widget-put'. */)
+ (widget, property)
Lisp_Object widget, property;
{
Lisp_Object tmp;
{
if (NILP (widget))
return Qnil;
- CHECK_CONS (widget, 1);
- tmp = Fwidget_plist_member (XCDR (widget), property);
+ CHECK_CONS (widget);
+ tmp = Fplist_member (XCDR (widget), property);
if (CONSP (tmp))
{
tmp = XCDR (tmp);
}
DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
- "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
-ARGS are passed as extra arguments to the function.")
- (nargs, args)
+ doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
+ARGS are passed as extra arguments to the function.
+usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
return result;
}
\f
-/* base64 encode/decode functions.
+/* base64 encode/decode functions (RFC 2045).
Based on code from GNU recode. */
#define MIME_LINE_LENGTH 76
/* Used by base64_decode_1 to retrieve a non-base64-ignorable
character or return retval if there are no characters left to
process. */
-#define READ_QUADRUPLET_BYTE(retval) \
- do \
- { \
- if (i == length) \
- return (retval); \
- c = from[i++]; \
- } \
+#define READ_QUADRUPLET_BYTE(retval) \
+ do \
+ { \
+ if (i == length) \
+ { \
+ if (nchars_return) \
+ *nchars_return = nchars; \
+ return (retval); \
+ } \
+ c = from[i++]; \
+ } \
while (IS_BASE64_IGNORABLE (c))
/* Don't use alloca for regions larger than this, lest we overflow
base64 characters. */
-static int base64_encode_1 P_ ((const char *, char *, int, int));
-static int base64_decode_1 P_ ((const char *, char *, int));
+static int base64_encode_1 P_ ((const char *, char *, int, int, int));
+static int base64_decode_1 P_ ((const char *, char *, int, int, int *));
DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
2, 3, "r",
- "Base64-encode the region between BEG and END.\n\
-Return the length of the encoded text.\n\
-Optional third argument NO-LINE-BREAK means do not break long lines\n\
-into shorter lines.")
+ doc: /* Base64-encode the region between BEG and END.
+Return the length of the encoded text.
+Optional third argument NO-LINE-BREAK means do not break long lines
+into shorter lines. */)
(beg, end, no_line_break)
Lisp_Object beg, end, no_line_break;
{
else
encoded = (char *) xmalloc (allength);
encoded_length = base64_encode_1 (BYTE_POS_ADDR (ibeg), encoded, length,
- NILP (no_line_break));
+ NILP (no_line_break),
+ !NILP (current_buffer->enable_multibyte_characters));
if (encoded_length > allength)
abort ();
+ if (encoded_length < 0)
+ {
+ /* The encoding wasn't possible. */
+ if (length > MAX_ALLOCA)
+ xfree (encoded);
+ error ("Multibyte character in data for base64 encoding");
+ }
+
/* Now we have encoded the region, so we insert the new contents
and delete the old. (Insert first in order to preserve markers.) */
SET_PT_BOTH (XFASTINT (beg), ibeg);
DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
1, 2, 0,
- "Base64-encode STRING and return the result.\n\
-Optional second argument NO-LINE-BREAK means do not break long lines\n\
-into shorter lines.")
+ doc: /* Base64-encode STRING and return the result.
+Optional second argument NO-LINE-BREAK means do not break long lines
+into shorter lines. */)
(string, no_line_break)
Lisp_Object string, no_line_break;
{
char *encoded;
Lisp_Object encoded_string;
- CHECK_STRING (string, 1);
+ CHECK_STRING (string);
/* We need to allocate enough room for encoding the text.
We need 33 1/3% more space, plus a newline every 76
encoded = (char *) xmalloc (allength);
encoded_length = base64_encode_1 (XSTRING (string)->data,
- encoded, length, NILP (no_line_break));
+ encoded, length, NILP (no_line_break),
+ STRING_MULTIBYTE (string));
if (encoded_length > allength)
abort ();
+ if (encoded_length < 0)
+ {
+ /* The encoding wasn't possible. */
+ if (length > MAX_ALLOCA)
+ xfree (encoded);
+ error ("Multibyte character in data for base64 encoding");
+ }
+
encoded_string = make_unibyte_string (encoded, encoded_length);
if (allength > MAX_ALLOCA)
xfree (encoded);
}
static int
-base64_encode_1 (from, to, length, line_break)
+base64_encode_1 (from, to, length, line_break, multibyte)
const char *from;
char *to;
int length;
int line_break;
+ int multibyte;
{
int counter = 0, i = 0;
char *e = to;
- unsigned char c;
+ int c;
unsigned int value;
+ int bytes;
while (i < length)
{
- c = from[i++];
+ if (multibyte)
+ {
+ c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
+ if (c >= 256)
+ return -1;
+ i += bytes;
+ }
+ else
+ c = from[i++];
/* Wrap line every 76 characters. */
break;
}
- c = from[i++];
+ if (multibyte)
+ {
+ c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
+ if (c >= 256)
+ return -1;
+ i += bytes;
+ }
+ else
+ c = from[i++];
*e++ = base64_value_to_char[value | (0x0f & c >> 4)];
value = (0x0f & c) << 2;
break;
}
- c = from[i++];
+ if (multibyte)
+ {
+ c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
+ if (c >= 256)
+ return -1;
+ i += bytes;
+ }
+ else
+ c = from[i++];
*e++ = base64_value_to_char[value | (0x03 & c >> 6)];
*e++ = base64_value_to_char[0x3f & c];
DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
- 2, 2, "r",
- "Base64-decode the region between BEG and END.\n\
-Return the length of the decoded text.\n\
-If the region can't be decoded, return nil and don't modify the buffer.")
+ 2, 2, "r",
+ doc: /* Base64-decode the region between BEG and END.
+Return the length of the decoded text.
+If the region can't be decoded, signal an error and don't modify the buffer. */)
(beg, end)
Lisp_Object beg, end;
{
- int ibeg, iend, length;
+ int ibeg, iend, length, allength;
char *decoded;
int old_pos = PT;
int decoded_length;
int inserted_chars;
+ int multibyte = !NILP (current_buffer->enable_multibyte_characters);
validate_region (&beg, &end);
iend = CHAR_TO_BYTE (XFASTINT (end));
length = iend - ibeg;
- /* We need to allocate enough room for decoding the text. */
- if (length <= MAX_ALLOCA)
- decoded = (char *) alloca (length);
+
+ /* We need to allocate enough room for decoding the text. If we are
+ working on a multibyte buffer, each decoded code may occupy at
+ most two bytes. */
+ allength = multibyte ? length * 2 : length;
+ if (allength <= MAX_ALLOCA)
+ decoded = (char *) alloca (allength);
else
- decoded = (char *) xmalloc (length);
+ decoded = (char *) xmalloc (allength);
move_gap_both (XFASTINT (beg), ibeg);
- decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length);
- if (decoded_length > length)
+ decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length,
+ multibyte, &inserted_chars);
+ if (decoded_length > allength)
abort ();
if (decoded_length < 0)
{
/* The decoding wasn't possible. */
- if (length > MAX_ALLOCA)
+ if (allength > MAX_ALLOCA)
xfree (decoded);
- return Qnil;
+ error ("Invalid base64 data");
}
/* Now we have decoded the region, so we insert the new contents
and delete the old. (Insert first in order to preserve markers.) */
- /* We insert two spaces, then insert the decoded text in between
- them, at last, delete those extra two spaces. This is to avoid
- byte combining while inserting. */
TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
- insert_1_both (" ", 2, 2, 0, 1, 0);
- TEMP_SET_PT_BOTH (XFASTINT (beg) + 1, ibeg + 1);
- insert (decoded, decoded_length);
- inserted_chars = PT - (XFASTINT (beg) + 1);
- if (length > MAX_ALLOCA)
+ insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
+ if (allength > MAX_ALLOCA)
xfree (decoded);
- /* At first delete the original text. This never cause byte
- combining. */
- del_range_both (PT + 1, PT_BYTE + 1, XFASTINT (end) + inserted_chars + 2,
- iend + decoded_length + 2, 1);
- /* Next delete the extra spaces. This will cause byte combining
- error. */
- del_range_both (PT, PT_BYTE, PT + 1, PT_BYTE + 1, 0);
- del_range_both (XFASTINT (beg), ibeg, XFASTINT (beg) + 1, ibeg + 1, 0);
- inserted_chars = PT - XFASTINT (beg);
+ /* Delete the original text. */
+ del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
+ iend + decoded_length, 1);
/* If point was outside of the region, restore it exactly; else just
move to the beginning of the region. */
DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
1, 1, 0,
- "Base64-decode STRING and return the result.")
+ doc: /* Base64-decode STRING and return the result. */)
(string)
Lisp_Object string;
{
int length, decoded_length;
Lisp_Object decoded_string;
- CHECK_STRING (string, 1);
+ CHECK_STRING (string);
length = STRING_BYTES (XSTRING (string));
/* We need to allocate enough room for decoding the text. */
else
decoded = (char *) xmalloc (length);
- decoded_length = base64_decode_1 (XSTRING (string)->data, decoded, length);
+ /* The decoded result should be unibyte. */
+ decoded_length = base64_decode_1 (XSTRING (string)->data, decoded, length,
+ 0, NULL);
if (decoded_length > length)
abort ();
-
- if (decoded_length < 0)
- /* The decoding wasn't possible. */
- decoded_string = Qnil;
+ else if (decoded_length >= 0)
+ decoded_string = make_unibyte_string (decoded, decoded_length);
else
- decoded_string = make_string (decoded, decoded_length);
+ decoded_string = Qnil;
if (length > MAX_ALLOCA)
xfree (decoded);
+ if (!STRINGP (decoded_string))
+ error ("Invalid base64 data");
return decoded_string;
}
+/* Base64-decode the data at FROM of LENGHT bytes into TO. If
+ MULTIBYTE is nonzero, the decoded result should be in multibyte
+ form. If NCHARS_RETRUN is not NULL, store the number of produced
+ characters in *NCHARS_RETURN. */
+
static int
-base64_decode_1 (from, to, length)
+base64_decode_1 (from, to, length, multibyte, nchars_return)
const char *from;
char *to;
int length;
+ int multibyte;
+ int *nchars_return;
{
int i = 0;
char *e = to;
unsigned char c;
unsigned long value;
+ int nchars = 0;
while (1)
{
return -1;
value |= base64_char_to_value[c] << 12;
- *e++ = (unsigned char) (value >> 16);
+ c = (unsigned char) (value >> 16);
+ if (multibyte)
+ e += CHAR_STRING (c, e);
+ else
+ *e++ = c;
+ nchars++;
/* Process third byte of a quadruplet. */
-
+
READ_QUADRUPLET_BYTE (-1);
if (c == '=')
{
READ_QUADRUPLET_BYTE (-1);
-
+
if (c != '=')
return -1;
continue;
return -1;
value |= base64_char_to_value[c] << 6;
- *e++ = (unsigned char) (0xff & value >> 8);
+ c = (unsigned char) (0xff & value >> 8);
+ if (multibyte)
+ e += CHAR_STRING (c, e);
+ else
+ *e++ = c;
+ nchars++;
/* Process fourth byte of a quadruplet. */
return -1;
value |= base64_char_to_value[c];
- *e++ = (unsigned char) (0xff & value);
+ c = (unsigned char) (0xff & value);
+ if (multibyte)
+ e += CHAR_STRING (c, e);
+ else
+ *e++ = c;
+ nchars++;
}
}
if a `:linear-search t' argument is given to make-hash-table. */
-/* Return the contents of vector V at index IDX. */
-
-#define AREF(V, IDX) XVECTOR (V)->contents[IDX]
-
/* Value is the key part of entry IDX in hash table H. */
#define HASH_KEY(H, IDX) AREF ((H)->key_and_value, 2 * (IDX))
Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey, Qvalue;
Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
-Lisp_Object Qhash_table_test;
+Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value;
/* Function prototypes. */
static struct Lisp_Hash_Table *check_hash_table P_ ((Lisp_Object));
-static int next_almost_prime P_ ((int));
static int get_key_arg P_ ((Lisp_Object, int, Lisp_Object *, char *));
-static Lisp_Object larger_vector P_ ((Lisp_Object, int, Lisp_Object));
static void maybe_resize_hash_table P_ ((struct Lisp_Hash_Table *));
static int cmpfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
Lisp_Object, unsigned));
static unsigned sxhash_list P_ ((Lisp_Object, int));
static unsigned sxhash_vector P_ ((Lisp_Object, int));
static unsigned sxhash_bool_vector P_ ((Lisp_Object));
+static int sweep_weak_table P_ ((struct Lisp_Hash_Table *, int));
\f
check_hash_table (obj)
Lisp_Object obj;
{
- CHECK_HASH_TABLE (obj, 0);
+ CHECK_HASH_TABLE (obj);
return XHASH_TABLE (obj);
}
/* Value is the next integer I >= N, N >= 0 which is "almost" a prime
number. */
-static int
+int
next_almost_prime (n)
int n;
{
char *used;
{
int i;
-
+
for (i = 0; i < nargs - 1; ++i)
if (!used[i] && EQ (args[i], key))
break;
-
+
if (i >= nargs - 1)
i = -1;
else
used[i++] = 1;
used[i] = 1;
}
-
+
return i;
}
size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
vector that are not copied from VEC are set to INIT. */
-static Lisp_Object
+Lisp_Object
larger_vector (vec, new_size, init)
Lisp_Object vec;
int new_size;
old_size = XVECTOR (vec)->size;
xassert (new_size >= old_size);
- v = allocate_vectorlike (new_size);
- v->size = new_size;
+ v = allocate_vector (new_size);
bcopy (XVECTOR (vec)->contents, v->contents,
old_size * sizeof *v->contents);
for (i = old_size; i < new_size; ++i)
return hash1 == hash2 && !NILP (Fequal (key1, key2));
}
-
+
/* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
HASH2 in hash table H using H->user_cmp_function. Value is non-zero
if KEY1 and KEY2 are the same. */
if (hash1 == hash2)
{
Lisp_Object args[3];
-
+
args[0] = h->user_cmp_function;
args[1] = key1;
args[2] = key2;
struct Lisp_Hash_Table *h;
Lisp_Object key;
{
- /* Lisp strings can change their address. Don't try to compute a
- hash code for a string from its address. */
- if (STRINGP (key))
- return sxhash_string (XSTRING (key)->data, XSTRING (key)->size);
- else
- return XUINT (key) ^ XGCTYPE (key);
+ unsigned hash = XUINT (key) ^ XGCTYPE (key);
+ xassert ((hash & ~VALMASK) == 0);
+ return hash;
}
struct Lisp_Hash_Table *h;
Lisp_Object key;
{
- /* Lisp strings can change their address. Don't try to compute a
- hash code for a string from its address. */
- if (STRINGP (key))
- return sxhash_string (XSTRING (key)->data, XSTRING (key)->size);
- else if (FLOATP (key))
- return sxhash (key, 0);
+ unsigned hash;
+ if (FLOATP (key))
+ hash = sxhash (key, 0);
else
- return XUINT (key) ^ XGCTYPE (key);
+ hash = XUINT (key) ^ XGCTYPE (key);
+ xassert ((hash & ~VALMASK) == 0);
+ return hash;
}
struct Lisp_Hash_Table *h;
Lisp_Object key;
{
- return sxhash (key, 0);
+ unsigned hash = sxhash (key, 0);
+ xassert ((hash & ~VALMASK) == 0);
+ return hash;
}
Lisp_Object key;
{
Lisp_Object args[2], hash;
-
+
args[0] = h->user_hash_function;
args[1] = key;
hash = Ffuncall (2, args);
if (!INTEGERP (hash))
Fsignal (Qerror,
- list2 (build_string ("Illegal hash code returned from \
+ list2 (build_string ("Invalid hash code returned from \
user-supplied hash function"),
hash));
return XUINT (hash);
It must be either one of the predefined tests `eq', `eql' or
`equal' or a symbol denoting a user-defined test named TEST with
test and hash functions USER_TEST and USER_HASH.
-
- Give the table initial capacity SIZE, SIZE > 0, an integer.
+
+ Give the table initial capacity SIZE, SIZE >= 0, an integer.
If REHASH_SIZE is an integer, it must be > 0, and this hash table's
new size when it becomes full is computed by adding REHASH_SIZE to
(table size) is >= REHASH_THRESHOLD.
WEAK specifies the weakness of the table. If non-nil, it must be
- one of the symbols `key', `value' or t. */
+ one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
Lisp_Object
make_hash_table (test, size, rehash_size, rehash_threshold, weak,
Lisp_Object user_test, user_hash;
{
struct Lisp_Hash_Table *h;
- struct Lisp_Vector *v;
Lisp_Object table;
- int index_size, i, len, sz;
+ int index_size, i, sz;
/* Preconditions. */
xassert (SYMBOLP (test));
- xassert (INTEGERP (size) && XINT (size) > 0);
+ xassert (INTEGERP (size) && XINT (size) >= 0);
xassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
|| (FLOATP (rehash_size) && XFLOATINT (rehash_size) > 1.0));
xassert (FLOATP (rehash_threshold)
&& XFLOATINT (rehash_threshold) > 0
&& XFLOATINT (rehash_threshold) <= 1.0);
- /* Allocate a vector, and initialize it. */
- len = VECSIZE (struct Lisp_Hash_Table);
- v = allocate_vectorlike (len);
- v->size = len;
- for (i = 0; i < len; ++i)
- v->contents[i] = Qnil;
+ if (XFASTINT (size) == 0)
+ size = make_number (1);
+
+ /* Allocate a table and initialize it. */
+ h = allocate_hash_table ();
/* Initialize hash table slots. */
sz = XFASTINT (size);
- h = (struct Lisp_Hash_Table *) v;
-
+
h->test = test;
if (EQ (test, Qeql))
{
h->cmpfn = cmpfn_user_defined;
h->hashfn = hashfn_user_defined;
}
-
+
h->weak = weak;
h->rehash_threshold = rehash_threshold;
h->rehash_size = rehash_size;
h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil);
h->hash = Fmake_vector (size, Qnil);
h->next = Fmake_vector (size, Qnil);
- index_size = next_almost_prime (sz / XFLOATINT (rehash_threshold));
+ /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
+ index_size = next_almost_prime ((int) (sz / XFLOATINT (rehash_threshold)));
h->index = Fmake_vector (make_number (index_size), Qnil);
/* Set up the free list. */
{
Lisp_Object table;
struct Lisp_Hash_Table *h2;
- struct Lisp_Vector *v, *next;
- int len;
-
- len = VECSIZE (struct Lisp_Hash_Table);
- v = allocate_vectorlike (len);
- h2 = (struct Lisp_Hash_Table *) v;
+ struct Lisp_Vector *next;
+
+ h2 = allocate_hash_table ();
next = h2->vec_next;
bcopy (h1, h2, sizeof *h2);
h2->vec_next = next;
{
int old_size = HASH_TABLE_SIZE (h);
int i, new_size, index_size;
-
+
if (INTEGERP (h->rehash_size))
new_size = old_size + XFASTINT (h->rehash_size);
else
new_size = old_size * XFLOATINT (h->rehash_size);
- index_size = next_almost_prime (new_size
- / XFLOATINT (h->rehash_threshold));
+ new_size = max (old_size + 1, new_size);
+ index_size = next_almost_prime ((int)
+ (new_size
+ / XFLOATINT (h->rehash_threshold)));
if (max (index_size, 2 * new_size) & ~VALMASK)
error ("Hash table too large to resize");
maphash faster. */
for (i = old_size; i < new_size - 1; ++i)
HASH_NEXT (h, i) = make_number (i + 1);
-
+
if (!NILP (h->next_free))
{
Lisp_Object last, next;
-
+
last = h->next_free;
while (next = HASH_NEXT (h, XFASTINT (last)),
!NILP (next))
last = next;
-
+
HASH_NEXT (h, XFASTINT (last)) = make_number (old_size);
}
else
HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
HASH_INDEX (h, start_of_bucket) = make_number (i);
}
- }
+ }
}
hash_code = h->hashfn (h, key);
if (hash)
*hash = hash_code;
-
+
start_of_bucket = hash_code % XVECTOR (h->index)->size;
idx = HASH_INDEX (h, start_of_bucket);
+ /* We need not gcpro idx since it's either an integer or nil. */
while (!NILP (idx))
{
int i = XFASTINT (idx);
if (EQ (key, HASH_KEY (h, i))
|| (h->cmpfn
&& h->cmpfn (h, key, hash_code,
- HASH_KEY (h, i), HASH_HASH (h, i))))
+ HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
break;
idx = HASH_NEXT (h, i);
}
/* Put an entry into hash table H that associates KEY with VALUE.
- HASH is a previously computed hash code of KEY. */
+ HASH is a previously computed hash code of KEY.
+ Value is the index of the entry in H matching KEY. */
-void
+int
hash_put (h, key, value, hash)
struct Lisp_Hash_Table *h;
Lisp_Object key, value;
/* Increment count after resizing because resizing may fail. */
maybe_resize_hash_table (h);
h->count = make_number (XFASTINT (h->count) + 1);
-
+
/* Store key/value in the key_and_value vector. */
i = XFASTINT (h->next_free);
h->next_free = HASH_NEXT (h, i);
start_of_bucket = hash % XVECTOR (h->index)->size;
HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
HASH_INDEX (h, start_of_bucket) = make_number (i);
+ return i;
}
idx = HASH_INDEX (h, start_of_bucket);
prev = Qnil;
+ /* We need not gcpro idx, prev since they're either integers or nil. */
while (!NILP (idx))
{
int i = XFASTINT (idx);
if (EQ (key, HASH_KEY (h, i))
|| (h->cmpfn
&& h->cmpfn (h, key, hash_code,
- HASH_KEY (h, i), HASH_HASH (h, i))))
+ HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
{
/* Take entry out of collision chain. */
if (NILP (prev))
Weak Hash Tables
************************************************************************/
-/* Remove elements from weak hash tables that don't survive the
- current garbage collection. Remove weak tables that don't survive
- from Vweak_hash_tables. Called from gc_sweep. */
+/* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
+ entries from the table that don't survive the current GC.
+ REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
+ non-zero if anything was marked. */
-void
-sweep_weak_hash_tables ()
+static int
+sweep_weak_table (h, remove_entries_p)
+ struct Lisp_Hash_Table *h;
+ int remove_entries_p;
{
- Lisp_Object table;
- struct Lisp_Hash_Table *h = 0, *prev;
+ int bucket, n, marked;
+
+ n = XVECTOR (h->index)->size & ~ARRAY_MARK_FLAG;
+ marked = 0;
- for (table = Vweak_hash_tables; !GC_NILP (table); table = h->next_weak)
+ for (bucket = 0; bucket < n; ++bucket)
{
- prev = h;
- h = XHASH_TABLE (table);
-
- if (h->size & ARRAY_MARK_FLAG)
+ Lisp_Object idx, next, prev;
+
+ /* Follow collision chain, removing entries that
+ don't survive this garbage collection. */
+ prev = Qnil;
+ for (idx = HASH_INDEX (h, bucket); !GC_NILP (idx); idx = next)
{
- if (XFASTINT (h->count) > 0)
+ int i = XFASTINT (idx);
+ int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
+ int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
+ int remove_p;
+
+ if (EQ (h->weak, Qkey))
+ remove_p = !key_known_to_survive_p;
+ else if (EQ (h->weak, Qvalue))
+ remove_p = !value_known_to_survive_p;
+ else if (EQ (h->weak, Qkey_or_value))
+ remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
+ else if (EQ (h->weak, Qkey_and_value))
+ remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
+ else
+ abort ();
+
+ next = HASH_NEXT (h, i);
+
+ if (remove_entries_p)
{
- int bucket, n;
+ if (remove_p)
+ {
+ /* Take out of collision chain. */
+ if (GC_NILP (prev))
+ HASH_INDEX (h, bucket) = next;
+ else
+ HASH_NEXT (h, XFASTINT (prev)) = next;
+
+ /* Add to free list. */
+ HASH_NEXT (h, i) = h->next_free;
+ h->next_free = idx;
+
+ /* Clear key, value, and hash. */
+ HASH_KEY (h, i) = HASH_VALUE (h, i) = Qnil;
+ HASH_HASH (h, i) = Qnil;
- n = XVECTOR (h->index)->size & ~ARRAY_MARK_FLAG;
- for (bucket = 0; bucket < n; ++bucket)
+ h->count = make_number (XFASTINT (h->count) - 1);
+ }
+ }
+ else
+ {
+ if (!remove_p)
{
- Lisp_Object idx, prev;
+ /* Make sure key and value survive. */
+ if (!key_known_to_survive_p)
+ {
+ mark_object (&HASH_KEY (h, i));
+ marked = 1;
+ }
- /* Follow collision chain, removing entries that
- don't survive this garbage collection. */
- idx = HASH_INDEX (h, bucket);
- prev = Qnil;
- while (!GC_NILP (idx))
+ if (!value_known_to_survive_p)
{
- int remove_p;
- int i = XFASTINT (idx);
- Lisp_Object next;
-
- if (EQ (h->weak, Qkey))
- remove_p = !survives_gc_p (HASH_KEY (h, i));
- else if (EQ (h->weak, Qvalue))
- remove_p = !survives_gc_p (HASH_VALUE (h, i));
- else if (EQ (h->weak, Qt))
- remove_p = (!survives_gc_p (HASH_KEY (h, i))
- || !survives_gc_p (HASH_VALUE (h, i)));
- else
- abort ();
-
- next = HASH_NEXT (h, i);
- if (remove_p)
- {
- /* Take out of collision chain. */
- if (GC_NILP (prev))
- HASH_INDEX (h, i) = next;
- else
- HASH_NEXT (h, XFASTINT (prev)) = next;
-
- /* Add to free list. */
- HASH_NEXT (h, i) = h->next_free;
- h->next_free = idx;
-
- /* Clear key, value, and hash. */
- HASH_KEY (h, i) = HASH_VALUE (h, i) = Qnil;
- HASH_HASH (h, i) = Qnil;
-
- h->count = make_number (XFASTINT (h->count) - 1);
- }
- else
- {
- /* Make sure key and value survive. */
- mark_object (&HASH_KEY (h, i));
- mark_object (&HASH_VALUE (h, i));
- }
-
- idx = next;
+ mark_object (&HASH_VALUE (h, i));
+ marked = 1;
}
}
}
}
- else
+ }
+
+ return marked;
+}
+
+/* Remove elements from weak hash tables that don't survive the
+ current garbage collection. Remove weak tables that don't survive
+ from Vweak_hash_tables. Called from gc_sweep. */
+
+void
+sweep_weak_hash_tables ()
+{
+ Lisp_Object table, used, next;
+ struct Lisp_Hash_Table *h;
+ int marked;
+
+ /* Mark all keys and values that are in use. Keep on marking until
+ there is no more change. This is necessary for cases like
+ value-weak table A containing an entry X -> Y, where Y is used in a
+ key-weak table B, Z -> Y. If B comes after A in the list of weak
+ tables, X -> Y might be removed from A, although when looking at B
+ one finds that it shouldn't. */
+ do
+ {
+ marked = 0;
+ for (table = Vweak_hash_tables; !GC_NILP (table); table = h->next_weak)
{
- /* Table is not marked, and will thus be freed.
- Take it out of the list of weak hash tables. */
- if (prev)
- prev->next_weak = h->next_weak;
- else
- Vweak_hash_tables = h->next_weak;
+ h = XHASH_TABLE (table);
+ if (h->size & ARRAY_MARK_FLAG)
+ marked |= sweep_weak_table (h, 0);
}
}
+ while (marked);
+
+ /* Remove tables and entries that aren't used. */
+ for (table = Vweak_hash_tables, used = Qnil; !GC_NILP (table); table = next)
+ {
+ h = XHASH_TABLE (table);
+ next = h->next_weak;
+
+ if (h->size & ARRAY_MARK_FLAG)
+ {
+ /* TABLE is marked as used. Sweep its contents. */
+ if (XFASTINT (h->count) > 0)
+ sweep_weak_table (h, 1);
+
+ /* Add table to the list of used weak hash tables. */
+ h->next_weak = used;
+ used = table;
+ }
+ }
+
+ Vweak_hash_tables = used;
}
+ (unsigned)(Y))
-/* Return a hash for string PTR which has length LEN. */
+/* Return a hash for string PTR which has length LEN. The hash
+ code returned is guaranteed to fit in a Lisp integer. */
static unsigned
sxhash_string (ptr, len)
c -= 40;
hash = ((hash << 3) + (hash >> 28) + c);
}
-
- return hash & 07777777777;
+
+ return hash & VALMASK;
}
{
unsigned hash = 0;
int i;
-
+
if (depth < SXHASH_MAX_DEPTH)
for (i = 0;
CONSP (list) && i < SXHASH_MAX_LEN;
if (depth > SXHASH_MAX_DEPTH)
return 0;
-
+
switch (XTYPE (obj))
{
case Lisp_Int:
break;
case Lisp_Symbol:
- hash = sxhash_string (XSYMBOL (obj)->name->data,
- XSYMBOL (obj)->name->size);
+ hash = sxhash_string (XSTRING (SYMBOL_NAME (obj))->data,
+ XSTRING (SYMBOL_NAME (obj))->size);
break;
case Lisp_Misc:
DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
- "Compute a hash code for OBJ and return it as integer.")
- (obj)
+ doc: /* Compute a hash code for OBJ and return it as integer. */)
+ (obj)
Lisp_Object obj;
{
unsigned hash = sxhash (obj, 0);;
DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
- "Create and return a new hash table.\n\
-Arguments are specified as keyword/argument pairs. The following\n\
-arguments are defined:\n\
-\n\
-:TEST TEST -- TEST must be a symbol that specifies how to compare keys.\n\
-Default is `eql'. Predefined are the tests `eq', `eql', and `equal'.\n\
-User-supplied test and hash functions can be specified via\n\
-`define-hash-table-test'.\n\
-\n\
-:SIZE SIZE -- A hint as to how many elements will be put in the table.\n\
-Default is 65.\n\
-\n\
-:REHASH-SIZE REHASH-SIZE - Indicates how to expand the table when\n\
-it fills up. If REHASH-SIZE is an integer, add that many space.\n\
-If it is a float, it must be > 1.0, and the new size is computed by\n\
-multiplying the old size with that factor. Default is 1.5.\n\
-\n\
-:REHASH-THRESHOLD THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.\n\
-Resize the hash table when ratio of the number of entries in the table.\n\
-Default is 0.8.\n\
-\n\
-:WEAKNESS WEAK -- WEAK must be one of nil, t, `key', or `value'.\n\
-If WEAK is not nil, the table returned is a weak table. Key/value\n\
-pairs are removed from a weak hash table when their key, value or both\n\
-(WEAK t) are otherwise unreferenced. Default is nil.")
- (nargs, args)
+ doc: /* Create and return a new hash table.
+
+Arguments are specified as keyword/argument pairs. The following
+arguments are defined:
+
+:test TEST -- TEST must be a symbol that specifies how to compare
+keys. Default is `eql'. Predefined are the tests `eq', `eql', and
+`equal'. User-supplied test and hash functions can be specified via
+`define-hash-table-test'.
+
+:size SIZE -- A hint as to how many elements will be put in the table.
+Default is 65.
+
+:rehash-size REHASH-SIZE - Indicates how to expand the table when it
+fills up. If REHASH-SIZE is an integer, add that many space. If it
+is a float, it must be > 1.0, and the new size is computed by
+multiplying the old size with that factor. Default is 1.5.
+
+:rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
+Resize the hash table when ratio of the number of entries in the
+table. Default is 0.8.
+
+:weakness WEAK -- WEAK must be one of nil, t, `key', `value',
+`key-or-value', or `key-and-value'. If WEAK is not nil, the table
+returned is a weak table. Key/value pairs are removed from a weak
+hash table when there are no non-weak references pointing to their
+key, value, one of key or value, or both key and value, depending on
+WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
+is nil.
+
+usage: (make-hash-table &rest KEYWORD-ARGS) */)
+ (nargs, args)
int nargs;
Lisp_Object *args;
{
{
/* See if it is a user-defined test. */
Lisp_Object prop;
-
+
prop = Fget (test, Qhash_table_test);
- if (!CONSP (prop) || XFASTINT (Flength (prop)) < 2)
- Fsignal (Qerror, list2 (build_string ("Illegal hash table test"),
+ if (!CONSP (prop) || !CONSP (XCDR (prop)))
+ Fsignal (Qerror, list2 (build_string ("Invalid hash table test"),
test));
- user_test = Fnth (make_number (0), prop);
- user_hash = Fnth (make_number (1), prop);
+ user_test = XCAR (prop);
+ user_hash = XCAR (XCDR (prop));
}
else
user_test = user_hash = Qnil;
/* See if there's a `:size SIZE' argument. */
i = get_key_arg (QCsize, nargs, args, used);
size = i < 0 ? make_number (DEFAULT_HASH_SIZE) : args[i];
- if (!INTEGERP (size) || XINT (size) <= 0)
+ if (!INTEGERP (size) || XINT (size) < 0)
Fsignal (Qerror,
- list2 (build_string ("Illegal hash table size"),
+ list2 (build_string ("Invalid hash table size"),
size));
/* Look for `:rehash-size SIZE'. */
|| (INTEGERP (rehash_size) && XINT (rehash_size) <= 0)
|| XFLOATINT (rehash_size) <= 1.0)
Fsignal (Qerror,
- list2 (build_string ("Illegal hash table rehash size"),
+ list2 (build_string ("Invalid hash table rehash size"),
rehash_size));
-
+
/* Look for `:rehash-threshold THRESHOLD'. */
i = get_key_arg (QCrehash_threshold, nargs, args, used);
rehash_threshold = i < 0 ? make_float (DEFAULT_REHASH_THRESHOLD) : args[i];
|| XFLOATINT (rehash_threshold) <= 0.0
|| XFLOATINT (rehash_threshold) > 1.0)
Fsignal (Qerror,
- list2 (build_string ("Illegal hash table rehash threshold"),
+ list2 (build_string ("Invalid hash table rehash threshold"),
rehash_threshold));
-
+
/* Look for `:weakness WEAK'. */
i = get_key_arg (QCweakness, nargs, args, used);
weak = i < 0 ? Qnil : args[i];
+ if (EQ (weak, Qt))
+ weak = Qkey_and_value;
if (!NILP (weak)
- && !EQ (weak, Qt)
&& !EQ (weak, Qkey)
- && !EQ (weak, Qvalue))
- Fsignal (Qerror, list2 (build_string ("Illegal hash table weakness"),
+ && !EQ (weak, Qvalue)
+ && !EQ (weak, Qkey_or_value)
+ && !EQ (weak, Qkey_and_value))
+ Fsignal (Qerror, list2 (build_string ("Invalid hash table weakness"),
weak));
-
+
/* Now, all args should have been used up, or there's a problem. */
for (i = 0; i < nargs; ++i)
if (!used[i])
DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
- "Return a copy of hash table TABLE.")
- (table)
+ doc: /* Return a copy of hash table TABLE. */)
+ (table)
Lisp_Object table;
{
return copy_hash_table (check_hash_table (table));
DEFUN ("makehash", Fmakehash, Smakehash, 0, 1, 0,
- "Create a new hash table.\n\
-Optional first argument TEST specifies how to compare keys in\n\
-the table. Predefined tests are `eq', `eql', and `equal'. Default\n\
-is `eql'. New tests can be defined with `define-hash-table-test'.")
- (test)
+ doc: /* Create a new hash table.
+
+Optional first argument TEST specifies how to compare keys in the
+table. Predefined tests are `eq', `eql', and `equal'. Default is
+`eql'. New tests can be defined with `define-hash-table-test'. */)
+ (test)
Lisp_Object test;
{
Lisp_Object args[2];
args[0] = QCtest;
- args[1] = test;
+ args[1] = NILP (test) ? Qeql : test;
return Fmake_hash_table (2, args);
}
DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
- "Return the number of elements in TABLE.")
- (table)
- Lisp_Object table;
+ doc: /* Return the number of elements in TABLE. */)
+ (table)
+ Lisp_Object table;
{
return check_hash_table (table)->count;
}
-
+
DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
Shash_table_rehash_size, 1, 1, 0,
- "Return the current rehash size of TABLE.")
- (table)
- Lisp_Object table;
+ doc: /* Return the current rehash size of TABLE. */)
+ (table)
+ Lisp_Object table;
{
return check_hash_table (table)->rehash_size;
}
-
+
DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
Shash_table_rehash_threshold, 1, 1, 0,
- "Return the current rehash threshold of TABLE.")
- (table)
- Lisp_Object table;
+ doc: /* Return the current rehash threshold of TABLE. */)
+ (table)
+ Lisp_Object table;
{
return check_hash_table (table)->rehash_threshold;
}
-
+
DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
- "Return the size of TABLE.\n\
-The size can be used as an argument to `make-hash-table' to create\n\
-a hash table than can hold as many elements of TABLE holds\n\
-without need for resizing.")
- (table)
+ doc: /* Return the size of TABLE.
+The size can be used as an argument to `make-hash-table' to create
+a hash table than can hold as many elements of TABLE holds
+without need for resizing. */)
+ (table)
Lisp_Object table;
{
struct Lisp_Hash_Table *h = check_hash_table (table);
return make_number (HASH_TABLE_SIZE (h));
}
-
+
DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
- "Return the test TABLE uses.")
- (table)
- Lisp_Object table;
+ doc: /* Return the test TABLE uses. */)
+ (table)
+ Lisp_Object table;
{
return check_hash_table (table)->test;
}
-
+
DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
1, 1, 0,
- "Return the weakness of TABLE.")
- (table)
- Lisp_Object table;
+ doc: /* Return the weakness of TABLE. */)
+ (table)
+ Lisp_Object table;
{
return check_hash_table (table)->weak;
}
-
+
DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
- "Return t if OBJ is a Lisp hash table object.")
- (obj)
+ doc: /* Return t if OBJ is a Lisp hash table object. */)
+ (obj)
Lisp_Object obj;
{
return HASH_TABLE_P (obj) ? Qt : Qnil;
DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
- "Clear hash table TABLE.")
- (table)
+ doc: /* Clear hash table TABLE. */)
+ (table)
Lisp_Object table;
{
hash_clear (check_hash_table (table));
DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
- "Look up KEY in TABLE and return its associated value.\n\
-If KEY is not found, return DFLT which defaults to nil.")
- (key, table, dflt)
+ doc: /* Look up KEY in TABLE and return its associated value.
+If KEY is not found, return DFLT which defaults to nil. */)
+ (key, table, dflt)
Lisp_Object key, table, dflt;
{
struct Lisp_Hash_Table *h = check_hash_table (table);
DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
- "Associate KEY with VALUE is hash table TABLE.\n\
-If KEY is already present in table, replace its current value with\n\
-VALUE.")
- (key, value, table)
+ doc: /* Associate KEY with VALUE in hash table TABLE.
+If KEY is already present in table, replace its current value with
+VALUE. */)
+ (key, value, table)
Lisp_Object key, value, table;
{
struct Lisp_Hash_Table *h = check_hash_table (table);
HASH_VALUE (h, i) = value;
else
hash_put (h, key, value, hash);
-
- return Qnil;
+
+ return value;
}
DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
- "Remove KEY from TABLE.")
- (key, table)
+ doc: /* Remove KEY from TABLE. */)
+ (key, table)
Lisp_Object key, table;
{
struct Lisp_Hash_Table *h = check_hash_table (table);
DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
- "Call FUNCTION for all entries in hash table TABLE.\n\
-FUNCTION is called with 2 arguments KEY and VALUE.")
- (function, table)
+ doc: /* Call FUNCTION for all entries in hash table TABLE.
+FUNCTION is called with 2 arguments KEY and VALUE. */)
+ (function, table)
Lisp_Object function, table;
{
struct Lisp_Hash_Table *h = check_hash_table (table);
args[2] = HASH_VALUE (h, i);
Ffuncall (3, args);
}
-
+
return Qnil;
}
DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
Sdefine_hash_table_test, 3, 3, 0,
- "Define a new hash table test with name NAME, a symbol.\n\
-In hash tables create with NAME specified as test, use TEST to compare\n\
-keys, and HASH for computing hash codes of keys.\n\
-\n\
-TEST must be a function taking two arguments and returning non-nil\n\
-if both arguments are the same. HASH must be a function taking\n\
-one argument and return an integer that is the hash code of the\n\
-argument. Hash code computation should use the whole value range of\n\
-integers, including negative integers.")
- (name, test, hash)
+ doc: /* Define a new hash table test with name NAME, a symbol.
+
+In hash tables created with NAME specified as test, use TEST to
+compare keys, and HASH for computing hash codes of keys.
+
+TEST must be a function taking two arguments and returning non-nil if
+both arguments are the same. HASH must be a function taking one
+argument and return an integer that is the hash code of the argument.
+Hash code computation should use the whole value range of integers,
+including negative integers. */)
+ (name, test, hash)
Lisp_Object name, test, hash;
{
return Fput (name, Qhash_table_test, list2 (test, hash));
}
+\f
+/************************************************************************
+ MD5
+ ************************************************************************/
+
+#include "md5.h"
+#include "coding.h"
+
+DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
+ doc: /* Return MD5 message digest of OBJECT, a buffer or string.
+
+A message digest is a cryptographic checksum of a document, and the
+algorithm to calculate it is defined in RFC 1321.
+
+The two optional arguments START and END are character positions
+specifying for which part of OBJECT the message digest should be
+computed. If nil or omitted, the digest is computed for the whole
+OBJECT.
+
+The MD5 message digest is computed from the result of encoding the
+text in a coding system, not directly from the internal Emacs form of
+the text. The optional fourth argument CODING-SYSTEM specifies which
+coding system to encode the text with. It should be the same coding
+system that you used or will use when actually writing the text into a
+file.
+
+If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
+OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
+system would be chosen by default for writing this text into a file.
+
+If OBJECT is a string, the most preferred coding system (see the
+command `prefer-coding-system') is used.
+
+If NOERROR is non-nil, silently assume the `raw-text' coding if the
+guesswork fails. Normally, an error is signaled in such case. */)
+ (object, start, end, coding_system, noerror)
+ Lisp_Object object, start, end, coding_system, noerror;
+{
+ unsigned char digest[16];
+ unsigned char value[33];
+ int i;
+ int size;
+ int size_byte = 0;
+ int start_char = 0, end_char = 0;
+ int start_byte = 0, end_byte = 0;
+ register int b, e;
+ register struct buffer *bp;
+ int temp;
+
+ if (STRINGP (object))
+ {
+ if (NILP (coding_system))
+ {
+ /* Decide the coding-system to encode the data with. */
+
+ if (STRING_MULTIBYTE (object))
+ /* use default, we can't guess correct value */
+ coding_system = SYMBOL_VALUE (XCAR (Vcoding_category_list));
+ else
+ coding_system = Qraw_text;
+ }
+
+ if (NILP (Fcoding_system_p (coding_system)))
+ {
+ /* Invalid coding system. */
+
+ if (!NILP (noerror))
+ coding_system = Qraw_text;
+ else
+ while (1)
+ Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil));
+ }
+
+ if (STRING_MULTIBYTE (object))
+ object = code_convert_string1 (object, coding_system, Qnil, 1);
+
+ size = XSTRING (object)->size;
+ size_byte = STRING_BYTES (XSTRING (object));
+
+ if (!NILP (start))
+ {
+ CHECK_NUMBER (start);
+
+ start_char = XINT (start);
+
+ if (start_char < 0)
+ start_char += size;
+
+ start_byte = string_char_to_byte (object, start_char);
+ }
+
+ if (NILP (end))
+ {
+ end_char = size;
+ end_byte = size_byte;
+ }
+ else
+ {
+ CHECK_NUMBER (end);
+
+ end_char = XINT (end);
+
+ if (end_char < 0)
+ end_char += size;
+
+ end_byte = string_char_to_byte (object, end_char);
+ }
+
+ if (!(0 <= start_char && start_char <= end_char && end_char <= size))
+ args_out_of_range_3 (object, make_number (start_char),
+ make_number (end_char));
+ }
+ else
+ {
+ CHECK_BUFFER (object);
+
+ bp = XBUFFER (object);
+
+ if (NILP (start))
+ b = BUF_BEGV (bp);
+ else
+ {
+ CHECK_NUMBER_COERCE_MARKER (start);
+ b = XINT (start);
+ }
+
+ if (NILP (end))
+ e = BUF_ZV (bp);
+ else
+ {
+ CHECK_NUMBER_COERCE_MARKER (end);
+ e = XINT (end);
+ }
+
+ if (b > e)
+ temp = b, b = e, e = temp;
+
+ if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
+ args_out_of_range (start, end);
+
+ if (NILP (coding_system))
+ {
+ /* Decide the coding-system to encode the data with.
+ See fileio.c:Fwrite-region */
+
+ if (!NILP (Vcoding_system_for_write))
+ coding_system = Vcoding_system_for_write;
+ else
+ {
+ int force_raw_text = 0;
+
+ coding_system = XBUFFER (object)->buffer_file_coding_system;
+ if (NILP (coding_system)
+ || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
+ {
+ coding_system = Qnil;
+ if (NILP (current_buffer->enable_multibyte_characters))
+ force_raw_text = 1;
+ }
+
+ if (NILP (coding_system) && !NILP (Fbuffer_file_name(object)))
+ {
+ /* Check file-coding-system-alist. */
+ Lisp_Object args[4], val;
+
+ args[0] = Qwrite_region; args[1] = start; args[2] = end;
+ args[3] = Fbuffer_file_name(object);
+ val = Ffind_operation_coding_system (4, args);
+ if (CONSP (val) && !NILP (XCDR (val)))
+ coding_system = XCDR (val);
+ }
+
+ if (NILP (coding_system)
+ && !NILP (XBUFFER (object)->buffer_file_coding_system))
+ {
+ /* If we still have not decided a coding system, use the
+ default value of buffer-file-coding-system. */
+ coding_system = XBUFFER (object)->buffer_file_coding_system;
+ }
+
+ if (!force_raw_text
+ && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
+ /* Confirm that VAL can surely encode the current region. */
+ coding_system = call3 (Vselect_safe_coding_system_function,
+ make_number (b), make_number (e),
+ coding_system);
+
+ if (force_raw_text)
+ coding_system = Qraw_text;
+ }
+
+ if (NILP (Fcoding_system_p (coding_system)))
+ {
+ /* Invalid coding system. */
+
+ if (!NILP (noerror))
+ coding_system = Qraw_text;
+ else
+ while (1)
+ Fsignal (Qcoding_system_error, Fcons (coding_system, Qnil));
+ }
+ }
+
+ object = make_buffer_string (b, e, 0);
+
+ if (STRING_MULTIBYTE (object))
+ object = code_convert_string1 (object, coding_system, Qnil, 1);
+ }
+
+ md5_buffer (XSTRING (object)->data + start_byte,
+ STRING_BYTES(XSTRING (object)) - (size_byte - end_byte),
+ digest);
+
+ for (i = 0; i < 16; i++)
+ sprintf (&value[2 * i], "%02x", digest[i]);
+ value[32] = '\0';
+
+ return make_string (value, 32);
+}
\f
void
staticpro (&Qvalue);
Qhash_table_test = intern ("hash-table-test");
staticpro (&Qhash_table_test);
+ Qkey_or_value = intern ("key-or-value");
+ staticpro (&Qkey_or_value);
+ Qkey_and_value = intern ("key-and-value");
+ staticpro (&Qkey_and_value);
defsubr (&Ssxhash);
defsubr (&Smake_hash_table);
defsubr (&Sremhash);
defsubr (&Smaphash);
defsubr (&Sdefine_hash_table_test);
-
+
Qstring_lessp = intern ("string-lessp");
staticpro (&Qstring_lessp);
Qprovide = intern ("provide");
staticpro (&string_char_byte_cache_string);
string_char_byte_cache_string = Qnil;
+ require_nesting_list = Qnil;
+ staticpro (&require_nesting_list);
+
Fset (Qyes_or_no_p_history, Qnil);
DEFVAR_LISP ("features", &Vfeatures,
- "A list of symbols which are the features of the executing emacs.\n\
-Used by `featurep' and `require', and altered by `provide'.");
+ doc: /* A list of symbols which are the features of the executing emacs.
+Used by `featurep' and `require', and altered by `provide'. */);
Vfeatures = Qnil;
+ Qsubfeatures = intern ("subfeatures");
+ staticpro (&Qsubfeatures);
DEFVAR_BOOL ("use-dialog-box", &use_dialog_box,
- "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
-This applies to y-or-n and yes-or-no questions asked by commands\n\
-invoked by mouse clicks and mouse menu items.");
+ doc: /* *Non-nil means mouse commands use dialog boxes to ask questions.
+This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
+invoked by mouse clicks and mouse menu items. */);
use_dialog_box = 1;
defsubr (&Sidentity);
defsubr (&Sstring_as_unibyte);
defsubr (&Scopy_alist);
defsubr (&Ssubstring);
+ defsubr (&Ssubstring_no_properties);
defsubr (&Snthcdr);
defsubr (&Snth);
defsubr (&Selt);
defsubr (&Sget);
defsubr (&Splist_put);
defsubr (&Sput);
+ defsubr (&Slax_plist_get);
+ defsubr (&Slax_plist_put);
defsubr (&Sequal);
defsubr (&Sfillarray);
defsubr (&Schar_table_subtype);
defsubr (&Schar_table_range);
defsubr (&Sset_char_table_range);
defsubr (&Sset_char_table_default);
+ defsubr (&Soptimize_char_table);
defsubr (&Smap_char_table);
defsubr (&Snconc);
defsubr (&Smapcar);
+ defsubr (&Smapc);
defsubr (&Smapconcat);
defsubr (&Sy_or_n_p);
defsubr (&Syes_or_no_p);
defsubr (&Sfeaturep);
defsubr (&Srequire);
defsubr (&Sprovide);
- defsubr (&Swidget_plist_member);
+ defsubr (&Splist_member);
defsubr (&Swidget_put);
defsubr (&Swidget_get);
defsubr (&Swidget_apply);
defsubr (&Sbase64_decode_region);
defsubr (&Sbase64_encode_string);
defsubr (&Sbase64_decode_string);
+ defsubr (&Smd5);
}
HCoop / bpt / emacs.git / blobdiff