/* 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
+ Free Software Foundation, Inc.
This file is part of GNU Emacs.
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))
XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK);
else if (CONSP (sequence))
{
- for (i = 0, tail = sequence; !NILP (tail); i++)
+ i = 0;
+ while (CONSP (sequence))
{
+ sequence = XCDR (sequence);
+ ++i;
+
+ if (!CONSP (sequence))
+ break;
+
+ sequence = XCDR (sequence);
+ ++i;
QUIT;
- tail = Fcdr (tail);
}
- XSETFASTINT (val, i);
+ if (!NILP (sequence))
+ wrong_type_argument (Qlistp, sequence);
+
+ val = make_number (i);
}
else if (NILP (sequence))
XSETFASTINT (val, 0);
/* halftail is used to detect circular lists. */
halftail = list;
- for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
{
if (EQ (tail, halftail) && len != 0)
break;
len++;
if ((len & 1) == 0)
- halftail = XCONS (halftail)->cdr;
+ halftail = XCDR (halftail);
}
XSETINT (length, len);
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++];
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 ("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.")
+Each argument may be a string or a list or vector of characters (integers).")
(nargs, args)
int nargs;
Lisp_Object *args;
return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}
+/* In string STR of length LEN, see if bytes before STR[I] combine
+ with bytes after STR[I] to form a single character. If so, return
+ the number of bytes after STR[I] which combine in this way.
+ Otherwize, return 0. */
+
+static int
+count_combining (str, len, i)
+ unsigned char *str;
+ int len, i;
+{
+ int j = i - 1, bytes;
+
+ if (i == 0 || i == len || CHAR_HEAD_P (str[i]))
+ return 0;
+ while (j >= 0 && !CHAR_HEAD_P (str[j])) j--;
+ if (j < 0 || ! BASE_LEADING_CODE_P (str[j]))
+ return 0;
+ PARSE_MULTIBYTE_SEQ (str + j, len - j, bytes);
+ return (bytes <= i - j ? 0 : bytes - (i - j));
+}
+
+/* This structure holds information of an argument of `concat' that is
+ a string and has text properties to be copied. */
+struct textprop_rec
+{
+ int argnum; /* refer to ARGS (arguments of `concat') */
+ int from; /* refer to ARGS[argnum] (argument string) */
+ int to; /* refer to VAL (the target string) */
+};
+
static Lisp_Object
concat (nargs, args, target_type, last_special)
int nargs;
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;
Lisp_Object last_tail;
Lisp_Object prev;
int some_multibyte;
- /* When we make a multibyte string, we must pay attention to the
- byte combining problem, i.e., a byte may be combined with a
- multibyte charcter of the previous string. This flag tells if we
- must consider such a situation or not. */
- int maybe_combine_byte;
+ /* When we make a multibyte string, we can't copy text properties
+ while concatinating each string because the length of resulting
+ 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 = 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, Faref (this, make_number (0)));
else if (CONSP (this))
- for (; CONSP (this); this = XCONS (this)->cdr)
+ for (; CONSP (this); this = XCDR (this))
{
- ch = XCONS (this)->car;
+ ch = XCAR (this);
if (! INTEGERP (ch))
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))
/* Copy the contents of the args into the result. */
if (CONSP (val))
- tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
+ tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
else
toindex = 0, toindex_byte = 0;
prev = Qnil;
+ if (STRINGP (val))
+ textprops
+ = (struct textprop_rec *) alloca (sizeof (struct textprop_rec) * nargs);
- maybe_combine_byte = 0;
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;
if (!CONSP (this))
thislen = Flength (this), thisleni = XINT (thislen);
- if (STRINGP (this) && STRINGP (val)
- && ! NULL_INTERVAL_P (XSTRING (this)->intervals))
- copy_text_properties (make_number (0), thislen, this,
- make_number (toindex), val, Qnil);
-
/* Between strings of the same kind, copy fast. */
if (STRINGP (this) && STRINGP (val)
&& STRING_MULTIBYTE (this) == some_multibyte)
{
int thislen_byte = STRING_BYTES (XSTRING (this));
+ int combined;
+
bcopy (XSTRING (this)->data, XSTRING (val)->data + toindex_byte,
STRING_BYTES (XSTRING (this)));
- if (some_multibyte
- && toindex_byte > 0
- && !ASCII_BYTE_P (XSTRING (val)->data[toindex_byte - 1])
- && !CHAR_HEAD_P (XSTRING (this)->data[0]))
- maybe_combine_byte = 1;
+ combined = (some_multibyte && toindex_byte > 0
+ ? count_combining (XSTRING (val)->data,
+ toindex_byte + thislen_byte,
+ toindex_byte)
+ : 0);
+ if (! NULL_INTERVAL_P (XSTRING (this)->intervals))
+ {
+ textprops[num_textprops].argnum = argnum;
+ /* We ignore text properties on characters being combined. */
+ textprops[num_textprops].from = combined;
+ textprops[num_textprops++].to = toindex;
+ }
toindex_byte += thislen_byte;
- toindex += thisleni;
+ toindex += thisleni - combined;
+ XSTRING (val)->size -= combined;
}
/* Copy a single-byte string to a multibyte string. */
else if (STRINGP (this) && STRINGP (val))
{
+ if (! NULL_INTERVAL_P (XSTRING (this)->intervals))
+ {
+ textprops[num_textprops].argnum = argnum;
+ textprops[num_textprops].from = 0;
+ textprops[num_textprops++].to = toindex;
+ }
toindex_byte += copy_text (XSTRING (this)->data,
XSTRING (val)->data + toindex_byte,
XSTRING (this)->size, 0, 1);
`this' is exhausted. */
if (NILP (this)) break;
if (CONSP (this))
- elt = XCONS (this)->car, this = XCONS (this)->cdr;
+ elt = XCAR (this), this = XCDR (this);
else if (thisindex >= thisleni)
break;
else if (STRINGP (this))
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)
{
- XCONS (tail)->car = elt;
+ XCAR (tail) = elt;
prev = tail;
- tail = XCONS (tail)->cdr;
+ tail = XCDR (tail);
}
else if (VECTORP (val))
XVECTOR (val)->contents[toindex++] = elt;
CHECK_NUMBER (elt, 0);
if (SINGLE_BYTE_CHAR_P (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
- && !ASCII_BYTE_P (XSTRING (val)->data[toindex_byte - 1])
- && !CHAR_HEAD_P (XINT (elt)))
- maybe_combine_byte = 1;
- XSTRING (val)->data[toindex_byte++] = XINT (elt);
- toindex++;
+ && count_combining (XSTRING (val)->data,
+ toindex_byte, toindex_byte - 1))
+ XSTRING (val)->size--;
+ else
+ toindex++;
}
else
/* If we have any multibyte characters,
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))
- XCONS (prev)->cdr = last_tail;
+ XCDR (prev) = last_tail;
- if (maybe_combine_byte)
- /* Character counter of the multibyte string VAL may be wrong
- because of byte combining problem. We must re-calculate it. */
- XSTRING (val)->size = multibyte_chars_in_text (XSTRING (val)->data,
- XSTRING (val)->size_byte);
+ if (num_textprops > 0)
+ {
+ Lisp_Object props;
+ for (argnum = 0; argnum < num_textprops; argnum++)
+ {
+ this = args[textprops[argnum].argnum];
+ 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 (argnum > 0
+ && textprops[argnum - 1].argnum + 1 == textprops[argnum].argnum)
+ make_composition_value_copy (props);
+ add_text_properties_from_list (val, props,
+ make_number (textprops[argnum].to));
+ }
+ }
return val;
}
\f
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_above > char_index)
{
- int best_above_byte_saved = --best_above_byte;
-
- while (best_above_byte > 0
- && !CHAR_HEAD_P (XSTRING (string)->data[best_above_byte]))
+ unsigned char *pend = XSTRING (string)->data + best_above_byte;
+ unsigned char *pbeg = pend - best_above_byte;
+ unsigned char *p = pend - 1;
+ int bytes;
+
+ while (p > pbeg && !CHAR_HEAD_P (*p)) p--;
+ PARSE_MULTIBYTE_SEQ (p, pend - p, bytes);
+ if (bytes == pend - p)
+ best_above_byte -= bytes;
+ else if (bytes > pend - p)
+ best_above_byte -= (pend - p);
+ else
best_above_byte--;
- if (!BASE_LEADING_CODE_P (XSTRING (string)->data[best_above_byte]))
- best_above_byte = best_above_byte_saved;
best_above--;
}
i = best_above;
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;
{
while (best_above_byte > byte_index)
{
- int best_above_byte_saved = --best_above_byte;
-
- while (best_above_byte > 0
- && !CHAR_HEAD_P (XSTRING (string)->data[best_above_byte]))
+ unsigned char *pend = XSTRING (string)->data + best_above_byte;
+ unsigned char *pbeg = pend - best_above_byte;
+ unsigned char *p = pend - 1;
+ int bytes;
+
+ while (p > pbeg && !CHAR_HEAD_P (*p)) p--;
+ PARSE_MULTIBYTE_SEQ (p, pend - p, bytes);
+ if (bytes == pend - p)
+ best_above_byte -= bytes;
+ else if (bytes > pend - p)
+ best_above_byte -= (pend - p);
+ else
best_above_byte--;
- if (!BASE_LEADING_CODE_P (XSTRING (string)->data[best_above_byte]))
- best_above_byte = best_above_byte_saved;
best_above--;
}
i = best_above;
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.")
+Otherwise it is a newly created string, with no text properties.\n\
+If STRING is multibyte and contains a character of charset\n\
+`eight-bit-control' or `eight-bit-graphic', it is converted to the\n\
+corresponding single byte.")
(string)
Lisp_Object 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;
}
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.")
+Otherwise it is a newly created string, with no text properties.\n\
+If STRING is unibyte and contains an individual 8-bit byte (i.e. not\n\
+part of a multibyte form), it is converted to the corresponding\n\
+multibyte character of charset `eight-bit-control' or `eight-bit-graphic'.")
(string)
Lisp_Object 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;
if (NILP (alist))
return alist;
alist = concat (1, &alist, Lisp_Cons, 0);
- for (tem = alist; CONSP (tem); tem = XCONS (tem)->cdr)
+ for (tem = alist; CONSP (tem); tem = XCDR (tem))
{
register Lisp_Object car;
- car = XCONS (tem)->car;
+ car = XCAR (tem);
if (CONSP (car))
- XCONS (tem)->car = Fcons (XCONS (car)->car, XCONS (car)->cdr);
+ XCAR (tem) = Fcons (XCAR (car), XCDR (car));
}
return alist;
}
{
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);
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;
}
Lisp_Object list;
{
register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
+ 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. Comparison done with EQ.\n\
-The value is actually the tail of LIST whose car is ELT.")
+ "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)
- register Lisp_Object elt;
- Lisp_Object list;
+ Lisp_Object elt, list;
{
- register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
+ while (1)
{
- register Lisp_Object tem;
- tem = Fcar (tail);
- if (EQ (elt, tem)) return tail;
+ if (!CONSP (list) || EQ (XCAR (list), elt))
+ break;
+
+ list = XCDR (list);
+ if (!CONSP (list) || EQ (XCAR (list), elt))
+ break;
+
+ list = XCDR (list);
+ if (!CONSP (list) || EQ (XCAR (list), elt))
+ break;
+
+ list = XCDR (list);
QUIT;
}
- return Qnil;
+
+ if (!CONSP (list) && !NILP (list))
+ list = wrong_type_argument (Qlistp, list);
+
+ return list;
}
DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
The value is actually the element of LIST whose car is KEY.\n\
Elements of LIST that are not conses are ignored.")
(key, list)
- register Lisp_Object key;
- Lisp_Object list;
+ Lisp_Object key, list;
{
- register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
+ Lisp_Object result;
+
+ while (1)
{
- register Lisp_Object elt, tem;
- elt = Fcar (tail);
- if (!CONSP (elt)) continue;
- tem = XCONS (elt)->car;
- if (EQ (key, tem)) return elt;
+ 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);
+ if (!CONSP (list)
+ || (CONSP (XCAR (list))
+ && EQ (XCAR (XCAR (list)), key)))
+ break;
+
+ list = XCDR (list);
QUIT;
}
- return Qnil;
+
+ if (CONSP (list))
+ result = XCAR (list);
+ else if (NILP (list))
+ result = Qnil;
+ else
+ result = wrong_type_argument (Qlistp, list);
+
+ return result;
}
/* Like Fassq but never report an error and do not allow quits.
Lisp_Object
assq_no_quit (key, list)
- register Lisp_Object key;
- Lisp_Object list;
+ Lisp_Object key, list;
{
- register Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
- {
- register Lisp_Object elt, tem;
- elt = Fcar (tail);
- if (!CONSP (elt)) continue;
- tem = XCONS (elt)->car;
- if (EQ (key, tem)) return elt;
- }
- return Qnil;
+ while (CONSP (list)
+ && (!CONSP (XCAR (list))
+ || !EQ (XCAR (XCAR (list)), key)))
+ list = XCDR (list);
+
+ return CONSP (list) ? XCAR (list) : Qnil;
}
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)
- register Lisp_Object key;
- Lisp_Object list;
+ Lisp_Object key, list;
{
- register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
+ Lisp_Object result, car;
+
+ while (1)
{
- register Lisp_Object elt, tem;
- elt = Fcar (tail);
- if (!CONSP (elt)) continue;
- tem = Fequal (XCONS (elt)->car, key);
- if (!NILP (tem)) return elt;
+ 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);
+ if (!CONSP (list)
+ || (CONSP (XCAR (list))
+ && (car = XCAR (XCAR (list)),
+ EQ (car, key) || !NILP (Fequal (car, key)))))
+ break;
+
+ list = XCDR (list);
QUIT;
}
- return Qnil;
+
+ if (CONSP (list))
+ result = XCAR (list);
+ else if (NILP (list))
+ result = Qnil;
+ else
+ result = wrong_type_argument (Qlistp, list);
+
+ return result;
}
DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
- "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
-The value is actually the element of LIST whose cdr is ELT.")
+ "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)
register Lisp_Object key;
Lisp_Object list;
{
- register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
+ Lisp_Object result;
+
+ while (1)
{
- register Lisp_Object elt, tem;
- elt = Fcar (tail);
- if (!CONSP (elt)) continue;
- tem = XCONS (elt)->cdr;
- if (EQ (key, tem)) return elt;
+ 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);
+ if (!CONSP (list)
+ || (CONSP (XCAR (list))
+ && EQ (XCDR (XCAR (list)), key)))
+ break;
+
+ list = XCDR (list);
QUIT;
}
- return Qnil;
+
+ if (NILP (list))
+ result = Qnil;
+ else if (CONSP (list))
+ result = XCAR (list);
+ else
+ result = wrong_type_argument (Qlistp, list);
+
+ return result;
}
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)
- register Lisp_Object key;
- Lisp_Object list;
+ Lisp_Object key, list;
{
- register Lisp_Object tail;
- for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
+ Lisp_Object result, cdr;
+
+ while (1)
{
- register Lisp_Object elt, tem;
- elt = Fcar (tail);
- if (!CONSP (elt)) continue;
- tem = Fequal (XCONS (elt)->cdr, key);
- if (!NILP (tem)) return elt;
+ 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);
+ if (!CONSP (list)
+ || (CONSP (XCAR (list))
+ && (cdr = XCDR (XCAR (list)),
+ EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
+ break;
+
+ list = XCDR (list);
QUIT;
}
- return Qnil;
+
+ if (CONSP (list))
+ result = XCAR (list);
+ else if (NILP (list))
+ result = Qnil;
+ else
+ result = wrong_type_argument (Qlistp, list);
+
+ return result;
}
\f
DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
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))
- list = XCONS (tail)->cdr;
+ list = XCDR (tail);
else
- Fsetcdr (prev, XCONS (tail)->cdr);
+ Fsetcdr (prev, XCDR (tail));
}
else
prev = tail;
- tail = XCONS (tail)->cdr;
+ tail = XCDR (tail);
QUIT;
}
return list;
}
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\
+ "Delete by side effect any occurrences of ELT as a member of SEQ.\n\
+SEQ must be a list, a vector, or a string.\n\
+The modified SEQ is returned. Comparison is done with `equal'.\n\
+If SEQ is not a list, or the first member of SEQ is ELT, deleting it\n\
+is not a side effect; it is simply using a different sequence.\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;
+ (elt, seq)
+ Lisp_Object elt, seq;
{
- register Lisp_Object tail, prev;
- register Lisp_Object tem;
+ if (VECTORP (seq))
+ {
+ EMACS_INT i, n, size;
- 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_vectorlike (n);
+
+ for (i = n = 0; i < ASIZE (seq); ++i)
+ if (NILP (Fequal (AREF (seq, i), elt)))
+ p->contents[n++] = AREF (seq, i);
+
+ p->size = n;
+ 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 = XCONS (tail)->cdr;
+ if (STRING_MULTIBYTE (seq))
+ {
+ c = STRING_CHAR (&XSTRING (seq)->data[ibyte],
+ STRING_BYTES (XSTRING (seq)) - ibyte);
+ cbytes = CHAR_BYTES (c);
+ }
else
- Fsetcdr (prev, XCONS (tail)->cdr);
+ {
+ 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 = XCONS (tail)->cdr;
- 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,
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;
{
Lisp_Object new;
- for (new = Qnil; CONSP (list); list = XCONS (list)->cdr)
- new = Fcons (XCONS (list)->car, new);
+ for (new = Qnil; CONSP (list); list = XCDR (list))
+ new = Fcons (XCAR (list), new);
if (!NILP (list))
wrong_type_argument (Qconsp, list);
return new;
register Lisp_Object prop;
{
register Lisp_Object tail;
- for (tail = plist; !NILP (tail); tail = Fcdr (XCONS (tail)->cdr))
+ for (tail = plist; !NILP (tail); tail = Fcdr (XCDR (tail)))
{
register Lisp_Object tem;
tem = Fcar (tail);
if (EQ (prop, tem))
- return Fcar (XCONS (tail)->cdr);
+ return Fcar (XCDR (tail));
}
return Qnil;
}
register Lisp_Object tail, prev;
Lisp_Object newcell;
prev = Qnil;
- for (tail = plist; CONSP (tail) && CONSP (XCONS (tail)->cdr);
- tail = XCONS (XCONS (tail)->cdr)->cdr)
+ for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
+ tail = XCDR (XCDR (tail)))
{
- if (EQ (prop, XCONS (tail)->car))
+ if (EQ (prop, XCAR (tail)))
{
- Fsetcar (XCONS (tail)->cdr, val);
+ Fsetcar (XCDR (tail), val);
return plist;
}
prev = tail;
if (NILP (prev))
return newcell;
else
- Fsetcdr (XCONS (prev)->cdr, newcell);
+ Fsetcdr (XCDR (prev), newcell);
return plist;
}
switch (XTYPE (o1))
{
-#ifdef LISP_FLOAT_TYPE
case Lisp_Float:
return (extract_float (o1) == extract_float (o2));
-#endif
case Lisp_Cons:
- if (!internal_equal (XCONS (o1)->car, XCONS (o2)->car, depth + 1))
+ if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1))
return 0;
- o1 = XCONS (o1)->cdr;
- o2 = XCONS (o2)->cdr;
+ o1 = XCDR (o1);
+ o2 = XCDR (o2);
goto tail_recurse;
case Lisp_Misc:
return 0;
if (OVERLAYP (o1))
{
- if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o1),
+ if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
depth + 1)
- || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o1),
+ || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
depth + 1))
return 0;
o1 = XOVERLAY (o1)->plist;
STRING_BYTES (XSTRING (o1))))
return 0;
return 1;
+
+ case Lisp_Int:
+ case Lisp_Symbol:
+ case Lisp_Type_Limit:
+ break;
}
+
return 0;
}
\f
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;
(char_table, range)
Lisp_Object char_table, range;
{
- int i;
-
CHECK_CHAR_TABLE (char_table, 0);
if (EQ (range, Qnil))
}
else
error ("Invalid RANGE argument to `char-table-range'");
+ return Qt;
}
DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
(char_table, ch, value)
Lisp_Object char_table, ch, value;
{
- int c, i, charset, code1, code2;
+ int c, charset, code1, code2;
Lisp_Object temp;
CHECK_CHAR_TABLE (char_table, 0);
/* 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_DIMENSION (charset) == 1)
code1 = 0;
temp = XCHAR_TABLE (char_table)->contents[charset + 128];
if (!code1)
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,
+ "Optimize char table TABLE.")
+ (table)
+ Lisp_Object table;
+{
+ Lisp_Object elt;
+ int dim;
+ int i, j;
+
+ CHECK_CHAR_TABLE (table, 0);
+
+ 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);
}
}
}
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
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);
- }
- }
- else if (STRINGP (seq) && ! STRING_MULTIBYTE (seq))
- {
- /* Single-byte string. */
- for (i = 0; i < leni; i++)
- {
- XSETFASTINT (dummy, XSTRING (seq)->data[i]);
- vals[i] = call1 (fn, dummy);
+ dummy = call1 (fn, dummy);
+ if (vals)
+ vals[i] = dummy;
}
}
else if (STRINGP (seq))
{
- /* Multi-byte string. */
- int len_byte = STRING_BYTES (XSTRING (seq));
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));
- tail = XCONS (tail)->cdr;
+ dummy = call1 (fn, Fcar (tail));
+ if (vals)
+ vals[i] = dummy;
+ tail = XCDR (tail);
}
}
return Flist (leni, args);
}
-\f
-/* Anything that calls this function must protect from GC! */
+
+DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
+ "Apply FUNCTION to each element of SEQUENCE for side effects only.\n\
+Unlike `mapcar', don't accumulate the results. Return SEQUENCE.\n\
+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.\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.")
+is nil and `use-dialog-box' is non-nil.")
(prompt)
Lisp_Object prompt;
{
- register Lisp_Object obj, key, def, answer_string, map;
+ register Lisp_Object obj, key, def, map;
register int answer;
Lisp_Object xprompt;
Lisp_Object args[2];
xprompt = prompt;
GCPRO2 (prompt, xprompt);
+#ifdef HAVE_X_WINDOWS
+ if (display_busy_cursor_p)
+ cancel_busy_cursor ();
+#endif
+
while (1)
{
key = Fmake_vector (make_number (1), obj);
def = Flookup_key (map, key, Qt);
- answer_string = Fsingle_key_description (obj);
if (EQ (def, intern ("skip")))
{
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.")
+is nil, and `use-dialog-box' is non-nil.")
(prompt)
Lisp_Object prompt;
{
register Lisp_Object ans;
Lisp_Object args[2];
struct gcpro gcpro1;
- Lisp_Object menu;
CHECK_STRING (prompt, 0);
register Lisp_Object tem;
CHECK_SYMBOL (feature, 0);
tem = Fmemq (feature, Vfeatures);
+
LOADHIST_ATTACH (Fcons (Qrequire, feature));
+
if (NILP (tem))
{
int count = specpdl_ptr - specpdl;
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,
+DEFUN ("plist-member", Fplist_member, Splist_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\
if (NILP (widget))
return Qnil;
CHECK_CONS (widget, 1);
- tmp = Fwidget_plist_member (XCDR (widget), property);
+ tmp = Fplist_member (XCDR (widget), property);
if (CONSP (tmp))
{
tmp = XCDR (tmp);
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",
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);
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];
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.")
+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. */
old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
else if (old_pos > XFASTINT (beg))
old_pos = XFASTINT (beg);
- SET_PT (old_pos);
+ SET_PT (old_pos > ZV ? ZV : old_pos);
return make_number (inserted_chars);
}
DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
1, 1, 0,
- "Base64-decode STRING and return the result.")
- (string)
+ "Base64-decode STRING and return the result.")
+ (string)
Lisp_Object string;
{
char *decoded;
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))
/* Various symbols. */
-Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey_weak, Qvalue_weak;
-Lisp_Object Qkey_value_weak;
-Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweak;
-Lisp_Object Qhash_table_test;
+Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey, Qvalue;
+Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
+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_eq P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
- Lisp_Object, unsigned));
static int cmpfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
Lisp_Object, unsigned));
static int cmpfn_equal P_ ((struct Lisp_Hash_Table *, 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
/* 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;
Low-level Functions
***********************************************************************/
-/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
- HASH2 in hash table H using `eq'. Value is non-zero if KEY1 and
- KEY2 are the same. */
-
-static int
-cmpfn_eq (h, key1, hash1, key2, hash2)
- struct Lisp_Hash_Table *h;
- Lisp_Object key1, key2;
- unsigned hash1, hash2;
-{
- return EQ (key1, key2);
-}
-
-
/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
KEY2 are the same. */
Lisp_Object key1, key2;
unsigned hash1, hash2;
{
- return (EQ (key1, key2)
- || (FLOATP (key1)
- && FLOATP (key2)
- && XFLOAT (key1)->data == XFLOAT (key2)->data));
+ return (FLOATP (key1)
+ && FLOATP (key2)
+ && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
}
Lisp_Object key1, key2;
unsigned hash1, hash2;
{
- return (EQ (key1, key2)
- || (hash1 == hash2
- && !NILP (Fequal (key1, key2))));
+ 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-weak', `value-weak' or `key-value-weak'. */
+ 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,
/* 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);
+ if (XFASTINT (size) == 0)
+ size = make_number (1);
+
/* Allocate a vector, and initialize it. */
len = VECSIZE (struct Lisp_Hash_Table);
v = allocate_vectorlike (len);
/* Initialize hash table slots. */
sz = XFASTINT (size);
h = (struct Lisp_Hash_Table *) v;
-
+
h->test = test;
if (EQ (test, Qeql))
{
}
else if (EQ (test, Qeq))
{
- h->cmpfn = cmpfn_eq;
+ h->cmpfn = NULL;
h->hashfn = hashfn_eq;
}
else if (EQ (test, Qequal))
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. */
}
+/* Return a copy of hash table H1. Keys and values are not copied,
+ only the table itself is. */
+
+Lisp_Object
+copy_hash_table (h1)
+ struct Lisp_Hash_Table *h1;
+{
+ 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;
+ next = h2->vec_next;
+ bcopy (h1, h2, sizeof *h2);
+ h2->vec_next = next;
+ h2->key_and_value = Fcopy_sequence (h1->key_and_value);
+ h2->hash = Fcopy_sequence (h1->hash);
+ h2->next = Fcopy_sequence (h1->next);
+ h2->index = Fcopy_sequence (h1->index);
+ XSET_HASH_TABLE (table, h2);
+
+ /* Maybe add this hash table to the list of all weak hash tables. */
+ if (!NILP (h2->weak))
+ {
+ h2->next_weak = Vweak_hash_tables;
+ Vweak_hash_tables = table;
+ }
+
+ return table;
+}
+
+
/* Resize hash table H if it's too full. If H cannot be resized
because it's already too large, throw an error. */
{
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 (h->cmpfn (h, key, hash_code, HASH_KEY (h, i), HASH_HASH (h, i)))
+ if (EQ (key, HASH_KEY (h, i))
+ || (h->cmpfn
+ && h->cmpfn (h, key, hash_code,
+ 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 (h->cmpfn (h, key, hash_code, HASH_KEY (h, i), HASH_HASH (h, i)))
+ if (EQ (key, HASH_KEY (h, i))
+ || (h->cmpfn
+ && h->cmpfn (h, key, hash_code,
+ 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, prev;
+
+ /* Follow collision chain, removing entries that
+ don't survive this garbage collection. */
+ idx = HASH_INDEX (h, bucket);
+ prev = Qnil;
+ while (!GC_NILP (idx))
{
- if (XFASTINT (h->count) > 0)
+ int remove_p;
+ int i = XFASTINT (idx);
+ Lisp_Object next;
+ int key_known_to_survive_p, value_known_to_survive_p;
+
+ key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
+ value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
+
+ 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, i) = next;
+ else
+ HASH_NEXT (h, XFASTINT (prev)) = next;
+
+ /* Add to free list. */
+ HASH_NEXT (h, i) = h->next_free;
+ h->next_free = idx;
- n = XVECTOR (h->index)->size & ~ARRAY_MARK_FLAG;
- for (bucket = 0; bucket < n; ++bucket)
+ /* 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
+ {
+ if (!remove_p)
{
- Lisp_Object idx, key, value, prev, next;
+ /* 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_weak))
- remove_p = !survives_gc_p (HASH_KEY (h, i));
- else if (EQ (h->weak, Qvalue_weak))
- remove_p = !survives_gc_p (HASH_VALUE (h, i));
- else if (EQ (h->weak, Qkey_value_weak))
- 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;
}
}
}
+
+ idx = next;
}
- 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;
}
/* Combine two integers X and Y for hashing. */
#define SXHASH_COMBINE(X, Y) \
- ((((unsigned)(X) << 4) + ((unsigned)(X) >> 24) & 0x0fffffff) \
+ ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
+ (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:
case Lisp_Float:
{
- unsigned char *p = (unsigned char *) &XFLOAT (obj)->data;
- unsigned char *e = p + sizeof XFLOAT (obj)->data;
+ unsigned char *p = (unsigned char *) &XFLOAT_DATA (obj);
+ unsigned char *e = p + sizeof XFLOAT_DATA (obj);
for (hash = 0; p < e; ++p)
hash = SXHASH_COMBINE (hash, *p);
break;
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.
+: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.
+: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\
+: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\
+: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\
-:WEAK WEAK -- WEAK must be one of nil, t, `key-weak', `value-weak' or\n\
-`key-value-weak'. WEAK t means the same as `key-value-weak'. Elements\n\
- are removed from a weak hash table when their key, value or both \n\
-according to WEAKNESS are otherwise unreferenced. Default is nil.")
+:weakness WEAK -- WEAK must be one of nil, t, `key', `value',\n\
+`key-or-value', or `key-and-value'. If WEAK is not nil, the table returned\n\
+is a weak table. Key/value pairs are removed from a weak hash table when\n\
+there are no non-weak references pointing to their key, value, one of key\n\
+or value, or both key and value, depending on WEAK. WEAK t is equivalent\n\
+to `key-and-value'. Default value of WEAK is nil.")
(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"),
+ Fsignal (Qerror, list2 (build_string ("Invalid hash table test"),
test));
user_test = Fnth (make_number (0), prop);
user_hash = Fnth (make_number (1), prop);
/* 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 `:weak WEAK'. */
- i = get_key_arg (QCweak, nargs, args, used);
+
+ /* Look for `:weakness WEAK'. */
+ i = get_key_arg (QCweakness, nargs, args, used);
weak = i < 0 ? Qnil : args[i];
if (EQ (weak, Qt))
- weak = Qkey_value_weak;
+ weak = Qkey_and_value;
if (!NILP (weak)
- && !EQ (weak, Qkey_weak)
- && !EQ (weak, Qvalue_weak)
- && !EQ (weak, Qkey_value_weak))
- Fsignal (Qerror, list2 (build_string ("Illegal hash table weakness"),
+ && !EQ (weak, Qkey)
+ && !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 ("makehash", Fmakehash, Smakehash, 0, MANY, 0,
- "Create a new hash table.\n\
-Optional first argument SIZE is a hint to the implementation as\n\
-to how many elements will be put in the table. Default is 65.\n\
-\n\
-Optional second 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'.\n\
-\n\
-Optional third argument WEAK must be one of nil, t, `key-weak',\n\
- `value-weak' or `key-value-weak'. WEAK t means the same as\n\
- `key-value-weak'. Default is nil. Elements of weak hash tables\n\
-are removed when their key, value or both are otherwise unreferenced.\n\
-\n\
-The rest of the optional arguments are keyword/value pairs. The\n\
-following are recognized:\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.")
- (nargs, args)
- int nargs;
- Lisp_Object *args;
+DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
+ "Return a copy of hash table TABLE.")
+ (table)
+ Lisp_Object table;
{
- Lisp_Object args2[nargs + 6];
- int i, j;
-
- /* Recognize size argument. */
- i = j = 0;
- if (INTEGERP (args[i]))
- {
- args2[j++] = QCsize;
- args2[j++] = args[i++];
- }
-
- /* Recognize test argument. */
- if (SYMBOLP (args[i])
- && !EQ (args[i], QCrehash_size)
- && !EQ (args[i], QCrehash_threshold)
- && !EQ (args[i], QCweak))
- {
- args2[j++] = QCtest;
- args2[j++] = args[i++];
- }
-
- /* Recognize weakness argument. */
- if (EQ (args[i], Qt)
- || NILP (args[i])
- || EQ (args[i], Qkey_weak)
- || EQ (args[i], Qvalue_weak)
- || EQ (args[i], Qkey_value_weak))
- {
- args2[j++] = QCweak;
- args2[j++] = args[i++];
- }
+ return copy_hash_table (check_hash_table (table));
+}
- /* Copy remaining arguments. */
- while (i < nargs)
- args2[j++] = args[i++];
- return Fmake_hash_table (j, args2);
+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)
+ Lisp_Object test;
+{
+ Lisp_Object args[2];
+ args[0] = QCtest;
+ args[1] = NILP (test) ? Qeql : test;
+ return Fmake_hash_table (2, args);
}
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.")
{
return check_hash_table (table)->rehash_size;
}
-
+
DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
Shash_table_rehash_threshold, 1, 1, 0,
{
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\
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.")
return check_hash_table (table)->test;
}
-
-DEFUN ("hash-table-weak", Fhash_table_weak, Shash_table_weak, 1, 1, 0,
+
+DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
+ 1, 1, 0,
"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)
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.")
- (table, key, dflt)
- Lisp_Object table, key;
+ (key, table, dflt)
+ Lisp_Object key, table, dflt;
{
struct Lisp_Hash_Table *h = check_hash_table (table);
int i = hash_lookup (h, key, NULL);
DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
- "Associate KEY with VALUE is hash table TABLE.\n\
+ "Associate KEY with VALUE in hash table TABLE.\n\
If KEY is already present in table, replace its current value with\n\
VALUE.")
- (table, key, value)
- Lisp_Object table, key, value;
+ (key, value, table)
+ Lisp_Object key, value, table;
{
struct Lisp_Hash_Table *h = check_hash_table (table);
int i;
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.")
- (table, key)
- Lisp_Object table, key;
+ (key, table)
+ Lisp_Object key, table;
{
struct Lisp_Hash_Table *h = check_hash_table (table);
hash_remove (h, key);
args[2] = HASH_VALUE (h, i);
Ffuncall (3, args);
}
-
+
return Qnil;
}
}
+\f
+/************************************************************************
+ MD5
+ ************************************************************************/
+
+#include "md5.h"
+#include "coding.h"
+
+DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
+ "Return MD5 message digest of OBJECT, a buffer or string.\n\
+\n\
+The two optional arguments START and END are character positions\n\
+specifying for which part of OBJECT the message digest should be computed.\n\
+If nil or omitted, the digest is computed for the whole OBJECT.\n\
+\n\
+Third optional argument CODING-SYSTEM specifies the coding system text\n\
+should be converted to before computing the digest. If nil or omitted,\n\
+the current format is used or a format is guessed.\n\
+\n\
+Fourth optional argument NOERROR is there for compatability with other\n\
+Emacsen and is ignored.")
+ (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 = XSYMBOL (XCAR (Vcoding_category_list))->value;
+ 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, 1);
+
+ 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, 2);
+
+ 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, 0);
+
+ bp = XBUFFER (object);
+
+ if (NILP (start))
+ b = BUF_BEGV (bp);
+ else
+ {
+ CHECK_NUMBER_COERCE_MARKER (start, 0);
+ b = XINT (start);
+ }
+
+ if (NILP (end))
+ e = BUF_ZV (bp);
+ else
+ {
+ CHECK_NUMBER_COERCE_MARKER (end, 1);
+ 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 (&QCrehash_size);
QCrehash_threshold = intern (":rehash-threshold");
staticpro (&QCrehash_threshold);
- QCweak = intern (":weak");
- staticpro (&QCweak);
- Qkey_weak = intern ("key-weak");
- staticpro (&Qkey_weak);
- Qvalue_weak = intern ("value-weak");
- staticpro (&Qvalue_weak);
- Qkey_value_weak = intern ("key-value-weak");
- staticpro (&Qkey_value_weak);
+ QCweakness = intern (":weakness");
+ staticpro (&QCweakness);
+ Qkey = intern ("key");
+ staticpro (&Qkey);
+ Qvalue = intern ("value");
+ 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 (&Scopy_hash_table);
defsubr (&Smakehash);
defsubr (&Shash_table_count);
defsubr (&Shash_table_rehash_size);
defsubr (&Shash_table_rehash_threshold);
defsubr (&Shash_table_size);
defsubr (&Shash_table_test);
- defsubr (&Shash_table_weak);
+ defsubr (&Shash_table_weakness);
defsubr (&Shash_table_p);
defsubr (&Sclrhash);
defsubr (&Sgethash);
defsubr (&Sremhash);
defsubr (&Smaphash);
defsubr (&Sdefine_hash_table_test);
-
+
Qstring_lessp = intern ("string-lessp");
staticpro (&Qstring_lessp);
Qprovide = intern ("provide");
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);
}