/* Random utility Lisp functions.
-Copyright (C) 1985-1987, 1993-1995, 1997-2013 Free Software Foundation, Inc.
+Copyright (C) 1985-1987, 1993-1995, 1997-2014 Free Software Foundation,
+Inc.
This file is part of GNU Emacs.
#include "frame.h"
#include "window.h"
#include "blockinput.h"
-#ifdef HAVE_MENUS
#if defined (HAVE_X_WINDOWS)
#include "xterm.h"
#endif
-#endif /* HAVE_MENUS */
Lisp_Object Qstring_lessp;
static Lisp_Object Qprovide, Qrequire;
static Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
static Lisp_Object Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512;
-
-static bool internal_equal (Lisp_Object, Lisp_Object, int, bool);
\f
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
doc: /* Return the argument unchanged. */)
seed_random (SSDATA (limit), SBYTES (limit));
val = get_random ();
- if (NATNUMP (limit) && XFASTINT (limit) != 0)
- val %= XFASTINT (limit);
+ if (INTEGERP (limit) && 0 < XINT (limit))
+ while (true)
+ {
+ /* Return the remainder, except reject the rare case where
+ get_random returns a number so close to INTMASK that the
+ remainder isn't random. */
+ EMACS_INT remainder = val % XINT (limit);
+ if (val - remainder <= INTMASK - XINT (limit) + 1)
+ return make_number (remainder);
+ val = get_random ();
+ }
return make_number (val);
}
\f
/* Random data-structure functions. */
+static void
+CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
+{
+ CHECK_TYPE (NILP (x), Qlistp, y);
+}
+
DEFUN ("length", Flength, Slength, 1, 1, 0,
doc: /* Return the length of vector, list or string SEQUENCE.
A byte-code function object is also allowed.
else if (CHAR_TABLE_P (sequence))
XSETFASTINT (val, MAX_CHAR);
else if (BOOL_VECTOR_P (sequence))
- XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
+ XSETFASTINT (val, bool_vector_size (sequence));
else if (COMPILEDP (sequence))
XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
else if (CONSP (sequence))
return val;
}
-/* This does not check for quits. That is safe since it must terminate. */
-
DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
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,
\(exclusive). If START1 is nil, it defaults to 0, the beginning of
the string; if END1 is nil, it defaults to the length of the string.
Likewise, in string STR2, compare the part between START2 and END2.
+Like in `substring', negative values are counted from the end.
The strings are compared by the numeric values of their characters.
For instance, STR1 is "less than" STR2 if its first differing
- 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. */)
- (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
+ (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
+ Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
{
- register ptrdiff_t end1_char, end2_char;
- register ptrdiff_t i1, i1_byte, i2, i2_byte;
+ ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
CHECK_STRING (str1);
CHECK_STRING (str2);
- if (NILP (start1))
- start1 = make_number (0);
- if (NILP (start2))
- start2 = make_number (0);
- CHECK_NATNUM (start1);
- CHECK_NATNUM (start2);
- if (! NILP (end1))
- CHECK_NATNUM (end1);
- if (! NILP (end2))
- CHECK_NATNUM (end2);
-
- end1_char = SCHARS (str1);
- if (! NILP (end1) && end1_char > XINT (end1))
- end1_char = XINT (end1);
- if (end1_char < XINT (start1))
- args_out_of_range (str1, start1);
-
- end2_char = SCHARS (str2);
- if (! NILP (end2) && end2_char > XINT (end2))
- end2_char = XINT (end2);
- if (end2_char < XINT (start2))
- args_out_of_range (str2, start2);
-
- i1 = XINT (start1);
- i2 = XINT (start2);
+
+ validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
+ validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);
+
+ i1 = from1;
+ i2 = from2;
i1_byte = string_char_to_byte (str1, i1);
i2_byte = string_char_to_byte (str2, i2);
- while (i1 < end1_char && i2 < end2_char)
+ while (i1 < to1 && i2 < to2)
{
/* When we find a mismatch, we must compare the
characters, not just the bytes. */
int c1, c2;
- if (STRING_MULTIBYTE (str1))
- FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
- else
- {
- c1 = SREF (str1, i1++);
- MAKE_CHAR_MULTIBYTE (c1);
- }
-
- if (STRING_MULTIBYTE (str2))
- FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
- else
- {
- c2 = SREF (str2, i2++);
- MAKE_CHAR_MULTIBYTE (c2);
- }
+ FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte);
+ FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte);
if (c1 == c2)
continue;
if (! NILP (ignore_case))
{
- Lisp_Object tem;
-
- tem = Fupcase (make_number (c1));
- c1 = XINT (tem);
- tem = Fupcase (make_number (c2));
- c2 = XINT (tem);
+ c1 = XINT (Fupcase (make_number (c1)));
+ c2 = XINT (Fupcase (make_number (c2)));
}
if (c1 == c2)
past the character that we are comparing;
hence we don't add or subtract 1 here. */
if (c1 < c2)
- return make_number (- i1 + XINT (start1));
+ return make_number (- i1 + from1);
else
- return make_number (i1 - XINT (start1));
+ return make_number (i1 - from1);
}
- if (i1 < end1_char)
- return make_number (i1 - XINT (start1) + 1);
- if (i2 < end2_char)
- return make_number (- i1 + XINT (start1) - 1);
+ if (i1 < to1)
+ return make_number (i1 - from1 + 1);
+ if (i2 < to2)
+ return make_number (- i1 + from1 - 1);
return Qt;
}
return i1 < SCHARS (s2) ? Qt : Qnil;
}
\f
+enum concat_target_type
+ {
+ concat_cons,
+ concat_string,
+ concat_vector
+ };
+
static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
- enum Lisp_Type target_type, bool last_special);
+ enum concat_target_type target_type, bool last_special);
/* ARGSUSED */
Lisp_Object
Lisp_Object args[2];
args[0] = s1;
args[1] = s2;
- return concat (2, args, Lisp_String, 0);
+ return concat (2, args, concat_string, 0);
}
/* ARGSUSED */
args[0] = s1;
args[1] = s2;
args[2] = s3;
- return concat (3, args, Lisp_String, 0);
+ return concat (3, args, concat_string, 0);
}
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
usage: (append &rest SEQUENCES) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return concat (nargs, args, Lisp_Cons, 1);
+ return concat (nargs, args, concat_cons, 1);
}
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
usage: (concat &rest SEQUENCES) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return concat (nargs, args, Lisp_String, 0);
+ return concat (nargs, args, concat_string, 0);
}
DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
usage: (vconcat &rest SEQUENCES) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- return concat (nargs, args, Lisp_Vectorlike, 0);
+ return concat (nargs, args, concat_vector, 0);
}
if (BOOL_VECTOR_P (arg))
{
- Lisp_Object val;
- ptrdiff_t size_in_chars
- = ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR);
-
- val = Fmake_bool_vector (Flength (arg), Qnil);
- memcpy (XBOOL_VECTOR (val)->data, XBOOL_VECTOR (arg)->data,
- size_in_chars);
+ EMACS_INT nbits = bool_vector_size (arg);
+ ptrdiff_t nbytes = bool_vector_bytes (nbits);
+ Lisp_Object val = make_uninit_bool_vector (nbits);
+ memcpy (bool_vector_data (val), bool_vector_data (arg), nbytes);
return val;
}
- if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
+ if (CONSP (arg))
+ return concat (1, &arg, concat_cons, 0);
+ else if (STRINGP (arg))
+ return concat (1, &arg, concat_string, 0);
+ else if (VECTORP (arg))
+ return concat (1, &arg, concat_vector, 0);
+ else
wrong_type_argument (Qsequencep, arg);
-
- return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}
/* This structure holds information of an argument of `concat' that is
static Lisp_Object
concat (ptrdiff_t nargs, Lisp_Object *args,
- enum Lisp_Type target_type, bool last_special)
+ enum concat_target_type target_type, bool last_special)
{
Lisp_Object val;
Lisp_Object tail;
EMACS_INT len;
this = args[argnum];
len = XFASTINT (Flength (this));
- if (target_type == Lisp_String)
+ if (target_type == concat_string)
{
/* We must count the number of bytes needed in the string
as well as the number of characters. */
if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
some_multibyte = 1;
}
- else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
+ else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
else if (CONSP (this))
for (; CONSP (this); this = XCDR (this))
result_len_byte = result_len;
/* Create the output object. */
- if (target_type == Lisp_Cons)
+ if (target_type == concat_cons)
val = Fmake_list (make_number (result_len), Qnil);
- else if (target_type == Lisp_Vectorlike)
+ else if (target_type == concat_vector)
val = Fmake_vector (make_number (result_len), Qnil);
else if (some_multibyte)
val = make_uninit_multibyte_string (result_len, result_len_byte);
val = make_uninit_string (result_len);
/* In `append', if all but last arg are nil, return last arg. */
- if (target_type == Lisp_Cons && EQ (val, Qnil))
+ if (target_type == concat_cons && EQ (val, Qnil))
return last_tail;
/* Copy the contents of the args into the result. */
}
else if (BOOL_VECTOR_P (this))
{
- int byte;
- byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR];
- if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR)))
- elt = Qt;
- else
- elt = Qnil;
+ elt = bool_vector_ref (this, thisindex);
thisindex++;
}
else
if (STRING_MULTIBYTE (string))
{
- ptrdiff_t bytes = SBYTES (string);
- unsigned char *str = xmalloc (bytes);
+ unsigned char *str = (unsigned char *) xlispstrdup (string);
+ ptrdiff_t bytes = str_as_unibyte (str, SBYTES (string));
- memcpy (str, SDATA (string), bytes);
- bytes = str_as_unibyte (str, bytes);
string = make_unibyte_string ((char *) str, bytes);
xfree (str);
}
if (STRING_MULTIBYTE (string))
{
ptrdiff_t chars = SCHARS (string);
- unsigned char *str = xmalloc (chars);
+ unsigned char *str = xmalloc_atomic (chars);
ptrdiff_t converted = str_to_unibyte (SDATA (string), str, chars);
if (converted < chars)
CHECK_LIST (alist);
if (NILP (alist))
return alist;
- alist = concat (1, &alist, Lisp_Cons, 0);
+ alist = concat (1, &alist, concat_cons, 0);
for (tem = alist; CONSP (tem); tem = XCDR (tem))
{
register Lisp_Object car;
return alist;
}
-DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
+/* Check that ARRAY can have a valid subarray [FROM..TO),
+ given that its size is SIZE.
+ If FROM is nil, use 0; if TO is nil, use SIZE.
+ Count negative values backwards from the end.
+ Set *IFROM and *ITO to the two indexes used. */
+
+void
+validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to,
+ ptrdiff_t size, ptrdiff_t *ifrom, ptrdiff_t *ito)
+{
+ EMACS_INT f, t;
+
+ if (INTEGERP (from))
+ {
+ f = XINT (from);
+ if (f < 0)
+ f += size;
+ }
+ else if (NILP (from))
+ f = 0;
+ else
+ wrong_type_argument (Qintegerp, from);
+
+ if (INTEGERP (to))
+ {
+ t = XINT (to);
+ if (t < 0)
+ t += size;
+ }
+ else if (NILP (to))
+ t = size;
+ else
+ wrong_type_argument (Qintegerp, to);
+
+ if (! (0 <= f && f <= t && t <= size))
+ args_out_of_range_3 (array, from, to);
+
+ *ifrom = f;
+ *ito = t;
+}
+
+DEFUN ("substring", Fsubstring, Ssubstring, 1, 3, 0,
doc: /* Return a new string whose contents are a substring of STRING.
The returned string consists of the characters between index FROM
\(inclusive) and index TO (exclusive) of STRING. FROM and TO are
The STRING argument may also be a vector. In that case, the return
value is a new vector that contains the elements between index FROM
-\(inclusive) and index TO (exclusive) of that vector argument. */)
- (Lisp_Object string, register Lisp_Object from, Lisp_Object to)
+\(inclusive) and index TO (exclusive) of that vector argument.
+
+With one argument, just copy STRING (with properties, if any). */)
+ (Lisp_Object string, Lisp_Object from, Lisp_Object to)
{
Lisp_Object res;
- ptrdiff_t size;
- EMACS_INT from_char, to_char;
-
- CHECK_VECTOR_OR_STRING (string);
- CHECK_NUMBER (from);
+ ptrdiff_t size, ifrom, ito;
if (STRINGP (string))
size = SCHARS (string);
- else
+ else if (VECTORP (string))
size = ASIZE (string);
-
- if (NILP (to))
- to_char = size;
else
- {
- CHECK_NUMBER (to);
-
- to_char = XINT (to);
- if (to_char < 0)
- to_char += size;
- }
+ wrong_type_argument (Qarrayp, string);
- from_char = XINT (from);
- if (from_char < 0)
- from_char += size;
- 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));
+ validate_subarray (string, from, to, size, &ifrom, &ito);
if (STRINGP (string))
{
- ptrdiff_t to_byte =
- (NILP (to) ? SBYTES (string) : string_char_to_byte (string, to_char));
- ptrdiff_t from_byte = string_char_to_byte (string, from_char);
+ ptrdiff_t from_byte
+ = !ifrom ? 0 : string_char_to_byte (string, ifrom);
+ ptrdiff_t to_byte
+ = ito == size ? SBYTES (string) : string_char_to_byte (string, ito);
res = make_specified_string (SSDATA (string) + from_byte,
- to_char - from_char, to_byte - from_byte,
+ ito - ifrom, to_byte - from_byte,
STRING_MULTIBYTE (string));
- copy_text_properties (make_number (from_char), make_number (to_char),
+ copy_text_properties (make_number (ifrom), make_number (ito),
string, make_number (0), res, Qnil);
}
else
- res = Fvector (to_char - from_char, aref_addr (string, from_char));
+ res = Fvector (ito - ifrom, aref_addr (string, ifrom));
return res;
}
With one argument, just copy STRING without its properties. */)
(Lisp_Object string, register Lisp_Object from, Lisp_Object to)
{
- ptrdiff_t size;
- EMACS_INT from_char, to_char;
- ptrdiff_t from_byte, to_byte;
+ ptrdiff_t from_char, to_char, from_byte, to_byte, size;
CHECK_STRING (string);
size = SCHARS (string);
+ validate_subarray (string, from, to, size, &from_char, &to_char);
- if (NILP (from))
- from_char = 0;
- else
- {
- CHECK_NUMBER (from);
- from_char = XINT (from);
- if (from_char < 0)
- from_char += size;
- }
-
- if (NILP (to))
- to_char = size;
- else
- {
- CHECK_NUMBER (to);
- to_char = XINT (to);
- if (to_char < 0)
- to_char += size;
- }
-
- 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));
-
- from_byte = NILP (from) ? 0 : string_char_to_byte (string, from_char);
+ from_byte = !from_char ? 0 : string_char_to_byte (string, from_char);
to_byte =
- NILP (to) ? SBYTES (string) : string_char_to_byte (string, to_char);
+ to_char == size ? SBYTES (string) : string_char_to_byte (string, to_char);
return make_specified_string (SSDATA (string) + from_byte,
to_char - from_char, to_byte - from_byte,
STRING_MULTIBYTE (string));
{
register Lisp_Object tail;
- if (!FLOATP (elt))
- return Fmemq (elt, list);
-
for (tail = list; CONSP (tail); tail = XCDR (tail))
{
register Lisp_Object tem;
CHECK_LIST_CONS (tail, list);
tem = XCAR (tail);
- if (FLOATP (tem) && internal_equal (elt, tem, 0, 0))
+ if (!NILP (Feql (elt, tem)))
return tail;
QUIT;
}
the value of a list `foo'. */)
(register Lisp_Object elt, Lisp_Object list)
{
- register Lisp_Object tail, prev;
- register Lisp_Object tem;
+ Lisp_Object tail, tortoise, prev = Qnil;
+ bool skip;
- tail = list;
- prev = Qnil;
- while (CONSP (tail))
+ FOR_EACH_TAIL (tail, list, tortoise, skip)
{
- CHECK_LIST_CONS (tail, list);
- tem = XCAR (tail);
+ Lisp_Object tem = XCAR (tail);
if (EQ (elt, tem))
{
if (NILP (prev))
}
else
prev = tail;
- tail = XCDR (tail);
- QUIT;
}
return list;
}
}
DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
- doc: /* Reverse LIST by modifying cdr pointers.
-Return the reversed list. Expects a properly nil-terminated list. */)
- (Lisp_Object list)
+ doc: /* Reverse order of items in a list, vector or string SEQ.
+If SEQ is a list, it should be nil-terminated.
+This function may destructively modify SEQ to produce the value. */)
+ (Lisp_Object seq)
{
- register Lisp_Object prev, tail, next;
+ if (NILP (seq))
+ return seq;
+ else if (STRINGP (seq))
+ return Freverse (seq);
+ else if (CONSP (seq))
+ {
+ Lisp_Object prev, tail, next;
- if (NILP (list)) return list;
- prev = Qnil;
- tail = list;
- while (!NILP (tail))
+ for (prev = Qnil, tail = seq; !NILP (tail); tail = next)
+ {
+ QUIT;
+ CHECK_LIST_CONS (tail, tail);
+ next = XCDR (tail);
+ Fsetcdr (tail, prev);
+ prev = tail;
+ }
+ seq = prev;
+ }
+ else if (VECTORP (seq))
{
- QUIT;
- CHECK_LIST_CONS (tail, tail);
- next = XCDR (tail);
- Fsetcdr (tail, prev);
- prev = tail;
- tail = next;
+ ptrdiff_t i, size = ASIZE (seq);
+
+ for (i = 0; i < size / 2; i++)
+ {
+ Lisp_Object tem = AREF (seq, i);
+ ASET (seq, i, AREF (seq, size - i - 1));
+ ASET (seq, size - i - 1, tem);
+ }
}
- return prev;
+ else if (BOOL_VECTOR_P (seq))
+ {
+ ptrdiff_t i, size = bool_vector_size (seq);
+
+ for (i = 0; i < size / 2; i++)
+ {
+ bool tem = bool_vector_bitref (seq, i);
+ bool_vector_set (seq, i, bool_vector_bitref (seq, size - i - 1));
+ bool_vector_set (seq, size - i - 1, tem);
+ }
+ }
+ else
+ wrong_type_argument (Qarrayp, seq);
+ return seq;
}
DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
- doc: /* Reverse LIST, copying. Return the reversed list.
+ doc: /* Return the reversed copy of list, vector, or string SEQ.
See also the function `nreverse', which is used more often. */)
- (Lisp_Object list)
+ (Lisp_Object seq)
{
Lisp_Object new;
- for (new = Qnil; CONSP (list); list = XCDR (list))
+ if (NILP (seq))
+ return Qnil;
+ else if (CONSP (seq))
{
- QUIT;
- new = Fcons (XCAR (list), new);
+ for (new = Qnil; CONSP (seq); seq = XCDR (seq))
+ {
+ QUIT;
+ new = Fcons (XCAR (seq), new);
+ }
+ CHECK_LIST_END (seq, seq);
}
- CHECK_LIST_END (list, list);
+ else if (VECTORP (seq))
+ {
+ ptrdiff_t i, size = ASIZE (seq);
+
+ new = make_uninit_vector (size);
+ for (i = 0; i < size; i++)
+ ASET (new, i, AREF (seq, size - i - 1));
+ }
+ else if (BOOL_VECTOR_P (seq))
+ {
+ ptrdiff_t i;
+ EMACS_INT nbits = bool_vector_size (seq);
+
+ new = make_uninit_bool_vector (nbits);
+ for (i = 0; i < nbits; i++)
+ bool_vector_set (new, i, bool_vector_bitref (seq, nbits - i - 1));
+ }
+ else if (STRINGP (seq))
+ {
+ ptrdiff_t size = SCHARS (seq), bytes = SBYTES (seq);
+
+ if (size == bytes)
+ {
+ ptrdiff_t i;
+
+ new = make_uninit_string (size);
+ for (i = 0; i < size; i++)
+ SSET (new, i, SREF (seq, size - i - 1));
+ }
+ else
+ {
+ unsigned char *p, *q;
+
+ new = make_uninit_multibyte_string (size, bytes);
+ p = SDATA (seq), q = SDATA (new) + bytes;
+ while (q > SDATA (new))
+ {
+ int ch, len;
+
+ ch = STRING_CHAR_AND_LENGTH (p, len);
+ p += len, q -= len;
+ CHAR_STRING (ch, q);
+ }
+ }
+ }
+ else
+ wrong_type_argument (Qsequencep, seq);
return new;
}
\f
-Lisp_Object merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred);
-
DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
doc: /* Sort LIST, stably, comparing elements using PREDICATE.
Returns the sorted list. LIST is modified by side effects.
prev = tail;
QUIT;
}
- newcell = Fcons (prop, Fcons (val, Qnil));
+ newcell = list2 (prop, val);
if (NILP (prev))
return newcell;
else
Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
(Lisp_Object obj1, Lisp_Object obj2)
{
- if (FLOATP (obj1))
- return internal_equal (obj1, obj2, 0, 0) ? Qt : Qnil;
- else
- return EQ (obj1, obj2) ? Qt : Qnil;
+ return scm_is_true (scm_eqv_p (obj1, obj2)) ? Qt : Qnil;
}
DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
Symbols must match exactly. */)
(register Lisp_Object o1, Lisp_Object o2)
{
- return internal_equal (o1, o2, 0, 0) ? Qt : Qnil;
+ return scm_is_true (scm_equal_p (o1, o2)) ? Qt : Qnil;
}
+SCM compare_text_properties = SCM_BOOL_F;
+
DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
doc: /* Return t if two Lisp objects have similar structure and contents.
This is like `equal' except that it compares the text properties
of strings. (`equal' ignores text properties.) */)
(register Lisp_Object o1, Lisp_Object o2)
{
- return internal_equal (o1, o2, 0, 1) ? Qt : Qnil;
-}
+ Lisp_Object tem;
-/* DEPTH is current depth of recursion. Signal an error if it
- gets too deep.
- PROPS means compare string text properties too. */
+ scm_dynwind_begin (0);
+ scm_dynwind_fluid (compare_text_properties, SCM_BOOL_T);
+ tem = Fequal (o1, o2);
+ scm_dynwind_end ();
+ return tem;
+}
-static bool
-internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props)
+static SCM
+misc_equal_p (SCM o1, SCM o2)
{
- if (depth > 200)
- error ("Stack overflow in equal");
-
- tail_recurse:
- QUIT;
- if (EQ (o1, o2))
- return 1;
- if (XTYPE (o1) != XTYPE (o2))
- return 0;
-
- switch (XTYPE (o1))
+ if (XMISCTYPE (o1) != XMISCTYPE (o2))
+ return SCM_BOOL_F;
+ if (OVERLAYP (o1))
{
- case Lisp_Float:
- {
- double d1, d2;
-
- d1 = extract_float (o1);
- d2 = extract_float (o2);
- /* If d is a NaN, then d != d. Two NaNs should be `equal' even
- though they are not =. */
- return d1 == d2 || (d1 != d1 && d2 != d2);
- }
-
- case Lisp_Cons:
- if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props))
- return 0;
- o1 = XCDR (o1);
- o2 = XCDR (o2);
- goto tail_recurse;
-
- case Lisp_Misc:
- if (XMISCTYPE (o1) != XMISCTYPE (o2))
- return 0;
- if (OVERLAYP (o1))
- {
- if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
- depth + 1, props)
- || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
- depth + 1, props))
- return 0;
- o1 = XOVERLAY (o1)->plist;
- o2 = XOVERLAY (o2)->plist;
- goto tail_recurse;
- }
- if (MARKERP (o1))
- {
- return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
- && (XMARKER (o1)->buffer == 0
- || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
- }
- break;
-
- case Lisp_Vectorlike:
- {
- register int i;
- ptrdiff_t size = ASIZE (o1);
- /* Pseudovectors have the type encoded in the size field, so this test
- actually checks that the objects have the same type as well as the
- same size. */
- if (ASIZE (o2) != size)
- return 0;
- /* Boolvectors are compared much like strings. */
- if (BOOL_VECTOR_P (o1))
- {
- if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
- return 0;
- if (memcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
- ((XBOOL_VECTOR (o1)->size
- + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR)))
- return 0;
- return 1;
- }
- if (WINDOW_CONFIGURATIONP (o1))
- return compare_window_configurations (o1, o2, 0);
+ if (NILP (Fequal (OVERLAY_START (o1), OVERLAY_START (o2)))
+ || NILP (Fequal (OVERLAY_END (o1), OVERLAY_END (o2))))
+ return SCM_BOOL_F;
+ return scm_equal_p (XOVERLAY (o1)->plist, XOVERLAY (o2)->plist);
+ }
+ if (MARKERP (o1))
+ {
+ struct Lisp_Marker *m1 = XMARKER (o1), *m2 = XMARKER (o2);
+ return scm_from_bool (m1->buffer == m2->buffer
+ && (m1->buffer == 0
+ || m1->bytepos == m2->bytepos));
+ }
+ return SCM_BOOL_F;
+}
- /* Aside from them, only true vectors, char-tables, compiled
- functions, and fonts (font-spec, font-entity, font-object)
- are sensible to compare, so eliminate the others now. */
- if (size & PSEUDOVECTOR_FLAG)
- {
- if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS)
- < PVEC_COMPILED)
- return 0;
- size &= PSEUDOVECTOR_SIZE_MASK;
- }
- for (i = 0; i < size; i++)
- {
- Lisp_Object v1, v2;
- v1 = AREF (o1, i);
- v2 = AREF (o2, i);
- if (!internal_equal (v1, v2, depth + 1, props))
- return 0;
- }
- return 1;
- }
- break;
-
- case Lisp_String:
- if (SCHARS (o1) != SCHARS (o2))
- return 0;
- if (SBYTES (o1) != SBYTES (o2))
- return 0;
- if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)))
- return 0;
- if (props && !compare_string_intervals (o1, o2))
- return 0;
- return 1;
-
- default:
- break;
+static SCM
+vectorlike_equal_p (SCM o1, SCM o2)
+{
+ int i;
+ ptrdiff_t size = ASIZE (o1);
+ /* Pseudovectors have the type encoded in the size field, so this
+ test actually checks that the objects have the same type as well
+ as the same size. */
+ if (ASIZE (o2) != size)
+ return SCM_BOOL_F;
+ /* Boolvectors are compared much like strings. */
+ if (BOOL_VECTOR_P (o1))
+ {
+ if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
+ return SCM_BOOL_F;
+ if (memcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
+ ((XBOOL_VECTOR (o1)->size
+ + BOOL_VECTOR_BITS_PER_CHAR - 1)
+ / BOOL_VECTOR_BITS_PER_CHAR)))
+ return SCM_BOOL_F;
+ return SCM_BOOL_T;
+ }
+ if (WINDOW_CONFIGURATIONP (o1))
+ return scm_from_bool (compare_window_configurations (o1, o2, 0));
+
+ /* Aside from them, only true vectors, char-tables, compiled
+ functions, and fonts (font-spec, font-entity, font-object) are
+ sensible to compare, so eliminate the others now. */
+ if (size & PSEUDOVECTOR_FLAG)
+ {
+ if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS)
+ < PVEC_COMPILED)
+ return SCM_BOOL_F;
+ size &= PSEUDOVECTOR_SIZE_MASK;
}
+ for (i = 0; i < size; i++)
+ {
+ Lisp_Object v1, v2;
+ v1 = AREF (o1, i);
+ v2 = AREF (o2, i);
+ if (scm_is_false (scm_equal_p (v1, v2)))
+ return SCM_BOOL_F;
+ }
+ return SCM_BOOL_T;
+}
- return 0;
+static SCM
+string_equal_p (SCM o1, SCM o2)
+{
+ if (SCHARS (o1) != SCHARS (o2))
+ return SCM_BOOL_F;
+ if (SBYTES (o1) != SBYTES (o2))
+ return SCM_BOOL_F;
+ if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)))
+ return SCM_BOOL_F;
+ if (scm_is_true (scm_fluid_ref (compare_text_properties))
+ && !compare_string_intervals (o1, o2))
+ return SCM_BOOL_F;
+ return SCM_BOOL_T;
}
\f
p[idx] = charval;
}
else if (BOOL_VECTOR_P (array))
- {
- register unsigned char *p = XBOOL_VECTOR (array)->data;
- size =
- ((XBOOL_VECTOR (array)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR);
-
- if (size)
- {
- memset (p, ! NILP (item) ? -1 : 0, size);
-
- /* Clear any extraneous bits in the last byte. */
- p[size - 1] &= (1 << (size % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
- }
- }
+ return bool_vector_fill (array, item);
else
wrong_type_argument (Qarrayp, array);
return array;
{
for (i = 0; i < leni; i++)
{
- unsigned char byte;
- byte = XBOOL_VECTOR (seq)->data[i / BOOL_VECTOR_BITS_PER_CHAR];
- dummy = (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))) ? Qt : Qnil;
- dummy = call1 (fn, dummy);
+ dummy = call1 (fn, bool_vector_ref (seq, i));
if (vals)
vals[i] = dummy;
}
/* 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,
- doc: /* Ask user a yes-or-no question. Return t if answer is yes.
+ doc: /* Ask user a yes-or-no question.
+Return t if answer is yes, and nil if the answer is no.
PROMPT 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. */)
+If dialog boxes are supported, a dialog box will be used
+if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
(Lisp_Object prompt)
{
register Lisp_Object ans;
CHECK_STRING (prompt);
-#ifdef HAVE_MENUS
if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
- && use_dialog_box
- && window_system_available (SELECTED_FRAME ()))
+ && use_dialog_box)
{
Lisp_Object pane, menu, obj;
redisplay_preserve_echo_area (4);
- pane = Fcons (Fcons (build_string ("Yes"), Qt),
- Fcons (Fcons (build_string ("No"), Qnil),
- Qnil));
+ pane = list2 (Fcons (build_string ("Yes"), Qt),
+ Fcons (build_string ("No"), Qnil));
GCPRO1 (pane);
menu = Fcons (prompt, pane);
obj = Fx_popup_dialog (Qt, menu, Qnil);
UNGCPRO;
return obj;
}
-#endif /* HAVE_MENUS */
args[0] = prompt;
args[1] = build_string ("(yes or no) ");
return (NILP (tem)) ? Qnil : Qt;
}
+static Lisp_Object Qfuncall;
+
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
/* Run any load-hooks for this file. */
tem = Fassq (feature, Vafter_load_alist);
if (CONSP (tem))
- Fprogn (XCDR (tem));
+ Fmapc (Qfuncall, XCDR (tem));
return feature;
}
static Lisp_Object require_nesting_list;
-static Lisp_Object
+static void
require_unwind (Lisp_Object old_value)
{
- return require_nesting_list = old_value;
+ require_nesting_list = old_value;
}
DEFUN ("require", Frequire, Srequire, 1, 3, 0,
if (NILP (tem))
{
- ptrdiff_t count = SPECPDL_INDEX ();
+ dynwind_begin ();
int nesting = 0;
/* This is to make sure that loadup.el gives a clear picture
UNGCPRO;
/* If load failed entirely, return nil. */
- if (NILP (tem))
- return unbind_to (count, Qnil);
+ if (NILP (tem)){
+
+ dynwind_end ();
+ return Qnil;
+ }
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
/* Once loading finishes, don't undo it. */
Vautoload_queue = Qt;
- feature = unbind_to (count, feature);
+ dynwind_end ();
}
return feature;
key_and_value vector of the hash table. This could be done
if a `:linear-search t' argument is given to make-hash-table. */
-
-/* The list of all weak hash tables. Don't staticpro this one. */
-
-static struct Lisp_Hash_Table *weak_hash_tables;
-
/* Various symbols. */
-static Lisp_Object Qhash_table_p, Qkey, Qvalue, Qeql;
+static Lisp_Object Qhash_table_p;
+static Lisp_Object Qkey, Qvalue, Qeql;
Lisp_Object Qeq, Qequal;
Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
static Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value;
Utilities
***********************************************************************/
+static void
+CHECK_HASH_TABLE (Lisp_Object x)
+{
+ CHECK_TYPE (HASH_TABLE_P (x), Qhash_table_p, x);
+}
+
+static void
+set_hash_key_and_value (struct Lisp_Hash_Table *h, Lisp_Object key_and_value)
+{
+ h->key_and_value = key_and_value;
+}
+static void
+set_hash_next (struct Lisp_Hash_Table *h, Lisp_Object next)
+{
+ h->next = next;
+}
+static void
+set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
+{
+ gc_aset (h->next, idx, val);
+}
+static void
+set_hash_hash (struct Lisp_Hash_Table *h, Lisp_Object hash)
+{
+ h->hash = hash;
+}
+static void
+set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
+{
+ gc_aset (h->hash, idx, val);
+}
+static void
+set_hash_index (struct Lisp_Hash_Table *h, Lisp_Object index)
+{
+ h->index = index;
+}
+static void
+set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
+{
+ gc_aset (h->index, idx, val);
+}
+
/* If OBJ is a Lisp hash table, return a pointer to its struct
Lisp_Hash_Table. Otherwise, signal an error. */
static EMACS_UINT
hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
{
- EMACS_UINT hash = XHASH (key) ^ XTYPE (key);
- return hash;
+ return scm_ihashq (key, MOST_POSITIVE_FIXNUM);
}
/* Value is a hash code for KEY for use in hash table H which uses
static EMACS_UINT
hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
{
- EMACS_UINT hash;
- if (FLOATP (key))
- hash = sxhash (key, 0);
- else
- hash = XHASH (key) ^ XTYPE (key);
- return hash;
+ return scm_ihashv (key, MOST_POSITIVE_FIXNUM);
}
/* Value is a hash code for KEY for use in hash table H which uses
static EMACS_UINT
hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
{
- EMACS_UINT hash = sxhash (key, 0);
- return hash;
+ return scm_ihash (key, MOST_POSITIVE_FIXNUM);
}
/* Value is a hash code for KEY for use in hash table H which uses as
args[0] = ht->user_hash_function;
args[1] = key;
hash = Ffuncall (2, args);
- if (!INTEGERP (hash))
- signal_error ("Invalid hash code returned from user-supplied hash function", hash);
- return XUINT (hash);
+ return hashfn_eq (ht, hash);
}
/* An upper bound on the size of a hash table index. It must fit in
eassert (HASH_TABLE_P (table));
eassert (XHASH_TABLE (table) == h);
- /* Maybe add this hash table to the list of all weak hash tables. */
- if (NILP (h->weak))
- h->next_weak = NULL;
- else
- {
- h->next_weak = weak_hash_tables;
- weak_hash_tables = h;
- }
-
return table;
}
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 = weak_hash_tables;
- weak_hash_tables = h2;
- }
-
return table;
}
\f
-/************************************************************************
- Weak Hash Tables
- ************************************************************************/
-
-/* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
- entries from the table that don't survive the current GC.
- !REMOVE_ENTRIES_P means mark entries that are in use. Value is
- true if anything was marked. */
-
-static bool
-sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
-{
- ptrdiff_t bucket, n;
- bool marked;
-
- n = ASIZE (h->index) & ~ARRAY_MARK_FLAG;
- marked = 0;
-
- for (bucket = 0; bucket < n; ++bucket)
- {
- 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); !NILP (idx); idx = next)
- {
- ptrdiff_t i = XFASTINT (idx);
- bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
- bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
- bool 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
- emacs_abort ();
-
- next = HASH_NEXT (h, i);
-
- if (remove_entries_p)
- {
- if (remove_p)
- {
- /* Take out of collision chain. */
- if (NILP (prev))
- set_hash_index_slot (h, bucket, next);
- else
- set_hash_next_slot (h, XFASTINT (prev), next);
-
- /* Add to free list. */
- set_hash_next_slot (h, i, h->next_free);
- h->next_free = idx;
-
- /* Clear key, value, and hash. */
- set_hash_key_slot (h, i, Qnil);
- set_hash_value_slot (h, i, Qnil);
- set_hash_hash_slot (h, i, Qnil);
-
- h->count--;
- }
- else
- {
- prev = idx;
- }
- }
- else
- {
- if (!remove_p)
- {
- /* Make sure key and value survive. */
- if (!key_known_to_survive_p)
- {
- mark_object (HASH_KEY (h, i));
- marked = 1;
- }
-
- if (!value_known_to_survive_p)
- {
- mark_object (HASH_VALUE (h, i));
- marked = 1;
- }
- }
- }
- }
- }
-
- 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 (void)
-{
- struct Lisp_Hash_Table *h, *used, *next;
- bool 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 (h = weak_hash_tables; h; h = h->next_weak)
- {
- if (h->header.size & ARRAY_MARK_FLAG)
- marked |= sweep_weak_table (h, 0);
- }
- }
- while (marked);
-
- /* Remove tables and entries that aren't used. */
- for (h = weak_hash_tables, used = NULL; h; h = next)
- {
- next = h->next_weak;
-
- if (h->header.size & ARRAY_MARK_FLAG)
- {
- /* TABLE is marked as used. Sweep its contents. */
- if (h->count > 0)
- sweep_weak_table (h, 1);
-
- /* Add table to the list of used weak hash tables. */
- h->next_weak = used;
- used = h;
- }
- }
-
- weak_hash_tables = used;
-}
-
-
-\f
/***********************************************************************
Hash Code Computation
***********************************************************************/
-/* Maximum depth up to which to dive into Lisp structures. */
-
-#define SXHASH_MAX_DEPTH 3
-
-/* Maximum length up to which to take list and vector elements into
- account. */
-
-#define SXHASH_MAX_LEN 7
-
/* Return a hash for string PTR which has length LEN. The hash value
can be any EMACS_UINT value. */
return hash;
}
-/* Return a hash for string PTR which has length LEN. The hash
- code returned is guaranteed to fit in a Lisp integer. */
-
-static EMACS_UINT
-sxhash_string (char const *ptr, ptrdiff_t len)
-{
- EMACS_UINT hash = hash_string (ptr, len);
- return SXHASH_REDUCE (hash);
-}
-
-/* Return a hash for the floating point value VAL. */
-
-static EMACS_UINT
-sxhash_float (double val)
-{
- EMACS_UINT hash = 0;
- enum {
- WORDS_PER_DOUBLE = (sizeof val / sizeof hash
- + (sizeof val % sizeof hash != 0))
- };
- union {
- double val;
- EMACS_UINT word[WORDS_PER_DOUBLE];
- } u;
- int i;
- u.val = val;
- memset (&u.val + 1, 0, sizeof u - sizeof u.val);
- for (i = 0; i < WORDS_PER_DOUBLE; i++)
- hash = sxhash_combine (hash, u.word[i]);
- return SXHASH_REDUCE (hash);
-}
-
-/* Return a hash for list LIST. DEPTH is the current depth in the
- list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
-
-static EMACS_UINT
-sxhash_list (Lisp_Object list, int depth)
-{
- EMACS_UINT hash = 0;
- int i;
-
- if (depth < SXHASH_MAX_DEPTH)
- for (i = 0;
- CONSP (list) && i < SXHASH_MAX_LEN;
- list = XCDR (list), ++i)
- {
- EMACS_UINT hash2 = sxhash (XCAR (list), depth + 1);
- hash = sxhash_combine (hash, hash2);
- }
-
- if (!NILP (list))
- {
- EMACS_UINT hash2 = sxhash (list, depth + 1);
- hash = sxhash_combine (hash, hash2);
- }
-
- return SXHASH_REDUCE (hash);
-}
-
-
-/* Return a hash for vector VECTOR. DEPTH is the current depth in
- the Lisp structure. */
-
-static EMACS_UINT
-sxhash_vector (Lisp_Object vec, int depth)
-{
- EMACS_UINT hash = ASIZE (vec);
- int i, n;
-
- n = min (SXHASH_MAX_LEN, ASIZE (vec));
- for (i = 0; i < n; ++i)
- {
- EMACS_UINT hash2 = sxhash (AREF (vec, i), depth + 1);
- hash = sxhash_combine (hash, hash2);
- }
-
- return SXHASH_REDUCE (hash);
-}
-
-/* Return a hash for bool-vector VECTOR. */
-
-static EMACS_UINT
-sxhash_bool_vector (Lisp_Object vec)
-{
- EMACS_UINT hash = XBOOL_VECTOR (vec)->size;
- int i, n;
-
- n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->header.size);
- for (i = 0; i < n; ++i)
- hash = sxhash_combine (hash, XBOOL_VECTOR (vec)->data[i]);
-
- return SXHASH_REDUCE (hash);
-}
-
-
/* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
structure. Value is an unsigned integer clipped to INTMASK. */
EMACS_UINT
sxhash (Lisp_Object obj, int depth)
{
- EMACS_UINT hash;
-
- if (depth > SXHASH_MAX_DEPTH)
- return 0;
-
- switch (XTYPE (obj))
- {
- case_Lisp_Int:
- hash = XUINT (obj);
- break;
-
- case Lisp_Misc:
- hash = XHASH (obj);
- break;
-
- case Lisp_Symbol:
- obj = SYMBOL_NAME (obj);
- /* Fall through. */
-
- case Lisp_String:
- hash = sxhash_string (SSDATA (obj), SBYTES (obj));
- break;
-
- /* This can be everything from a vector to an overlay. */
- case Lisp_Vectorlike:
- if (VECTORP (obj))
- /* According to the CL HyperSpec, two arrays are equal only if
- they are `eq', except for strings and bit-vectors. In
- Emacs, this works differently. We have to compare element
- by element. */
- hash = sxhash_vector (obj, depth);
- else if (BOOL_VECTOR_P (obj))
- hash = sxhash_bool_vector (obj);
- else
- /* Others are `equal' if they are `eq', so let's take their
- address as hash. */
- hash = XHASH (obj);
- break;
-
- case Lisp_Cons:
- hash = sxhash_list (obj, depth);
- break;
-
- case Lisp_Float:
- hash = sxhash_float (XFLOAT_DATA (obj));
- break;
-
- default:
- emacs_abort ();
- }
-
- return hash;
+ return scm_ihash (obj, MOST_POSITIVE_FIXNUM);
}
DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
doc: /* Call FUNCTION for all entries in hash table TABLE.
-FUNCTION is called with two arguments, KEY and VALUE. */)
+FUNCTION is called with two arguments, KEY and VALUE.
+`maphash' always returns nil. */)
(Lisp_Object function, Lisp_Object table)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
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. */)
+argument and returning an object that is the hash code of the argument.
+It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
+returns nil, then (funcall TEST x1 x2) also returns nil. */)
(Lisp_Object name, Lisp_Object test, Lisp_Object hash)
{
return Fput (name, Qhash_table_test, list2 (test, hash));
/* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
static Lisp_Object
-secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror, Lisp_Object binary)
+secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start,
+ Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror,
+ Lisp_Object binary)
{
int i;
- ptrdiff_t size;
- EMACS_INT start_char = 0, end_char = 0;
- ptrdiff_t start_byte, end_byte;
+ ptrdiff_t size, start_char = 0, start_byte, end_char = 0, end_byte;
register EMACS_INT b, e;
register struct buffer *bp;
EMACS_INT temp;
object = code_convert_string (object, coding_system, Qnil, 1, 0, 1);
size = SCHARS (object);
+ validate_subarray (object, start, end, size, &start_char, &end_char);
- if (!NILP (start))
- {
- CHECK_NUMBER (start);
-
- start_char = XINT (start);
-
- if (start_char < 0)
- start_char += size;
- }
-
- if (NILP (end))
- end_char = size;
- else
- {
- CHECK_NUMBER (end);
-
- end_char = XINT (end);
-
- if (end_char < 0)
- end_char += size;
- }
-
- 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));
-
- start_byte = NILP (start) ? 0 : string_char_to_byte (object, start_char);
- end_byte =
- NILP (end) ? SBYTES (object) : string_char_to_byte (object, end_char);
+ start_byte = !start_char ? 0 : string_char_to_byte (object, start_char);
+ end_byte = (end_char == size
+ ? SBYTES (object)
+ : string_char_to_byte (object, end_char));
}
else
{
- struct buffer *prev = current_buffer;
+ dynwind_begin ();
record_unwind_current_buffer ();
}
object = make_buffer_string (b, e, 0);
- set_buffer_internal (prev);
- /* Discard the unwind protect for recovering the current
- buffer. */
- specpdl_ptr--;
+ dynwind_end ();
if (STRING_MULTIBYTE (object))
object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary);
}
\f
+void
+init_fns_once (void)
+{
+ compare_text_properties = scm_make_fluid ();
+ scm_set_smob_equalp (lisp_misc_tag, misc_equal_p);
+ scm_set_smob_equalp (lisp_string_tag, string_equal_p);
+ scm_set_smob_equalp (lisp_vectorlike_tag, vectorlike_equal_p);
+}
+
void
syms_of_fns (void)
{
+#include "fns.x"
+
DEFSYM (Qmd5, "md5");
DEFSYM (Qsha1, "sha1");
DEFSYM (Qsha224, "sha224");
DEFSYM (Qkey_or_value, "key-or-value");
DEFSYM (Qkey_and_value, "key-and-value");
- defsubr (&Ssxhash);
- defsubr (&Smake_hash_table);
- defsubr (&Scopy_hash_table);
- 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_weakness);
- defsubr (&Shash_table_p);
- defsubr (&Sclrhash);
- defsubr (&Sgethash);
- defsubr (&Sputhash);
- defsubr (&Sremhash);
- defsubr (&Smaphash);
- defsubr (&Sdefine_hash_table_test);
-
DEFSYM (Qstring_lessp, "string-lessp");
DEFSYM (Qprovide, "provide");
DEFSYM (Qrequire, "require");
DEFVAR_LISP ("features", Vfeatures,
doc: /* A list of symbols which are the features of the executing Emacs.
Used by `featurep' and `require', and altered by `provide'. */);
- Vfeatures = Fcons (intern_c_string ("emacs"), Qnil);
+ Vfeatures = list1 (intern_c_string ("emacs"));
DEFSYM (Qsubfeatures, "subfeatures");
+ DEFSYM (Qfuncall, "funcall");
#ifdef HAVE_LANGINFO_CODESET
DEFSYM (Qcodeset, "codeset");
this variable. */);
use_file_dialog = 1;
- defsubr (&Sidentity);
- defsubr (&Srandom);
- defsubr (&Slength);
- defsubr (&Ssafe_length);
- defsubr (&Sstring_bytes);
- defsubr (&Sstring_equal);
- defsubr (&Scompare_strings);
- defsubr (&Sstring_lessp);
- defsubr (&Sappend);
- defsubr (&Sconcat);
- defsubr (&Svconcat);
- defsubr (&Scopy_sequence);
- defsubr (&Sstring_make_multibyte);
- defsubr (&Sstring_make_unibyte);
- defsubr (&Sstring_as_multibyte);
- defsubr (&Sstring_as_unibyte);
- defsubr (&Sstring_to_multibyte);
- defsubr (&Sstring_to_unibyte);
- defsubr (&Scopy_alist);
- defsubr (&Ssubstring);
- defsubr (&Ssubstring_no_properties);
- defsubr (&Snthcdr);
- defsubr (&Snth);
- defsubr (&Selt);
- defsubr (&Smember);
- defsubr (&Smemq);
- defsubr (&Smemql);
- defsubr (&Sassq);
- defsubr (&Sassoc);
- defsubr (&Srassq);
- defsubr (&Srassoc);
- defsubr (&Sdelq);
- defsubr (&Sdelete);
- defsubr (&Snreverse);
- defsubr (&Sreverse);
- defsubr (&Ssort);
- defsubr (&Splist_get);
- defsubr (&Sget);
- defsubr (&Splist_put);
- defsubr (&Sput);
- defsubr (&Slax_plist_get);
- defsubr (&Slax_plist_put);
- defsubr (&Seql);
- defsubr (&Sequal);
- defsubr (&Sequal_including_properties);
- defsubr (&Sfillarray);
- defsubr (&Sclear_string);
- defsubr (&Snconc);
- defsubr (&Smapcar);
- defsubr (&Smapc);
- defsubr (&Smapconcat);
- defsubr (&Syes_or_no_p);
- defsubr (&Sload_average);
- defsubr (&Sfeaturep);
- defsubr (&Srequire);
- defsubr (&Sprovide);
- defsubr (&Splist_member);
- defsubr (&Swidget_put);
- defsubr (&Swidget_get);
- defsubr (&Swidget_apply);
- defsubr (&Sbase64_encode_region);
- defsubr (&Sbase64_decode_region);
- defsubr (&Sbase64_encode_string);
- defsubr (&Sbase64_decode_string);
- defsubr (&Smd5);
- defsubr (&Ssecure_hash);
- defsubr (&Slocale_info);
-
- {
- struct hash_table_test
- eq = { Qeq, Qnil, Qnil, NULL, hashfn_eq },
- eql = { Qeql, Qnil, Qnil, cmpfn_eql, hashfn_eql },
- equal = { Qequal, Qnil, Qnil, cmpfn_equal, hashfn_equal };
- hashtest_eq = eq;
- hashtest_eql = eql;
- hashtest_equal = equal;
- }
+ hashtest_eq.name = Qeq;
+ hashtest_eq.user_hash_function = Qnil;
+ hashtest_eq.user_cmp_function = Qnil;
+ hashtest_eq.cmpfn = 0;
+ hashtest_eq.hashfn = hashfn_eq;
+
+ hashtest_eql.name = Qeql;
+ hashtest_eql.user_hash_function = Qnil;
+ hashtest_eql.user_cmp_function = Qnil;
+ hashtest_eql.cmpfn = cmpfn_eql;
+ hashtest_eql.hashfn = hashfn_eql;
+
+ hashtest_equal.name = Qequal;
+ hashtest_equal.user_hash_function = Qnil;
+ hashtest_equal.user_cmp_function = Qnil;
+ hashtest_equal.cmpfn = cmpfn_equal;
+ hashtest_equal.hashfn = hashfn_equal;
}
HCoop / bpt / emacs.git / blobdiff