/* 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 Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512;
-static bool internal_equal (Lisp_Object, Lisp_Object, int, bool);
+static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
\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
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))
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 (! 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))
}
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);
}
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. */
+
+static void
+validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to,
+ ptrdiff_t size, EMACS_INT *ifrom, EMACS_INT *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);
+ EMACS_INT 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;
}
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 tem;
CHECK_LIST_CONS (tail, list);
tem = XCAR (tail);
- if (FLOATP (tem) && internal_equal (elt, tem, 0, 0))
+ if (FLOATP (tem) && internal_equal (elt, tem, 0, 0, Qnil))
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;
}
for (i = n = 0; i < ASIZE (seq); ++i)
if (NILP (Fequal (AREF (seq, i), elt)))
- p->u.contents[n++] = AREF (seq, i);
+ p->contents[n++] = AREF (seq, i);
XSETVECTOR (seq, p);
}
(Lisp_Object obj1, Lisp_Object obj2)
{
if (FLOATP (obj1))
- return internal_equal (obj1, obj2, 0, 0) ? Qt : Qnil;
+ return internal_equal (obj1, obj2, 0, 0, Qnil) ? Qt : Qnil;
else
return EQ (obj1, obj2) ? Qt : Qnil;
}
Symbols must match exactly. */)
(register Lisp_Object o1, Lisp_Object o2)
{
- return internal_equal (o1, o2, 0, 0) ? Qt : Qnil;
+ return internal_equal (o1, o2, 0, 0, Qnil) ? Qt : Qnil;
}
DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
of strings. (`equal' ignores text properties.) */)
(register Lisp_Object o1, Lisp_Object o2)
{
- return internal_equal (o1, o2, 0, 1) ? Qt : Qnil;
+ return internal_equal (o1, o2, 0, 1, Qnil) ? Qt : Qnil;
}
/* DEPTH is current depth of recursion. Signal an error if it
PROPS means compare string text properties too. */
static bool
-internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props)
+internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props,
+ Lisp_Object ht)
{
- if (depth > 200)
- error ("Stack overflow in equal");
+ if (depth > 10)
+ {
+ if (depth > 200)
+ error ("Stack overflow in equal");
+ if (NILP (ht))
+ {
+ Lisp_Object args[2];
+ args[0] = QCtest;
+ args[1] = Qeq;
+ ht = Fmake_hash_table (2, args);
+ }
+ switch (XTYPE (o1))
+ {
+ case Lisp_Cons: case Lisp_Misc: case Lisp_Vectorlike:
+ {
+ struct Lisp_Hash_Table *h = XHASH_TABLE (ht);
+ EMACS_UINT hash;
+ ptrdiff_t i = hash_lookup (h, o1, &hash);
+ if (i >= 0)
+ { /* `o1' was seen already. */
+ Lisp_Object o2s = HASH_VALUE (h, i);
+ if (!NILP (Fmemq (o2, o2s)))
+ return 1;
+ else
+ set_hash_value_slot (h, i, Fcons (o2, o2s));
+ }
+ else
+ hash_put (h, o1, Fcons (o2, Qnil), hash);
+ }
+ default: ;
+ }
+ }
tail_recurse:
QUIT;
}
case Lisp_Cons:
- if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props))
+ if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props, ht))
return 0;
o1 = XCDR (o1);
o2 = XCDR (o2);
+ /* FIXME: This inf-loops in a circular list! */
goto tail_recurse;
case Lisp_Misc:
if (OVERLAYP (o1))
{
if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
- depth + 1, props)
+ depth + 1, props, ht)
|| !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
- depth + 1, props))
+ depth + 1, props, ht))
return 0;
o1 = XOVERLAY (o1)->plist;
o2 = XOVERLAY (o2)->plist;
/* Boolvectors are compared much like strings. */
if (BOOL_VECTOR_P (o1))
{
- if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
+ EMACS_INT size = bool_vector_size (o1);
+ if (size != bool_vector_size (o2))
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)))
+ if (memcmp (bool_vector_data (o1), bool_vector_data (o2),
+ bool_vector_bytes (size)))
return 0;
return 1;
}
Lisp_Object v1, v2;
v1 = AREF (o1, i);
v2 = AREF (o2, i);
- if (!internal_equal (v1, v2, depth + 1, props))
+ if (!internal_equal (v1, v2, depth + 1, props, ht))
return 0;
}
return 1;
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);
UNGCPRO;
return obj;
}
-#endif /* HAVE_MENUS */
args[0] = prompt;
args[1] = build_string ("(yes or no) ");
{
struct Lisp_Vector *v;
ptrdiff_t i, incr, incr_max, old_size, new_size;
- ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / sizeof *v->u.contents;
+ ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / sizeof *v->contents;
ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
? nitems_max : C_language_max);
eassert (VECTORP (vec));
memory_full (SIZE_MAX);
new_size = old_size + incr;
v = allocate_vector (new_size);
- memcpy (v->u.contents, XVECTOR (vec)->u.contents, old_size * sizeof *v->u.contents);
+ memcpy (v->contents, XVECTOR (vec)->contents, old_size * sizeof *v->contents);
for (i = old_size; i < new_size; ++i)
- v->u.contents[i] = Qnil;
+ v->contents[i] = Qnil;
XSETVECTOR (vec, v);
return vec;
}
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
current garbage collection. Remove weak tables that don't survive
from Vweak_hash_tables. Called from gc_sweep. */
+NO_INLINE /* For better stack traces */
void
sweep_weak_hash_tables (void)
{
static EMACS_UINT
sxhash_bool_vector (Lisp_Object vec)
{
- EMACS_UINT hash = XBOOL_VECTOR (vec)->size;
+ EMACS_INT size = bool_vector_size (vec);
+ EMACS_UINT hash = size;
int i, n;
- n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->header.size);
+ n = min (SXHASH_MAX_LEN, bool_vector_words (size));
for (i = 0; i < n; ++i)
- hash = sxhash_combine (hash, XBOOL_VECTOR (vec)->data[i]);
+ hash = sxhash_combine (hash, bool_vector_data (vec)[i]);
return SXHASH_REDUCE (hash);
}
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));
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
{
HCoop / bpt / emacs.git / blobdiff