X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/39eb0cb563f5287270f3946804456dc766386638..680e6b8c5a28489733df544edb074fd29d0522a0:/src/data.c
diff --git a/src/data.c b/src/data.c
index 51b0266eca..1fe7a1c9b6 100644
--- a/src/data.c
+++ b/src/data.c
@@ -21,6 +21,9 @@ along with GNU Emacs. If not, see . */
#include
#include
+#include
+#include
+#include
#include
#include "lisp.h"
@@ -38,6 +41,7 @@ Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
static Lisp_Object Qsubr;
Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
Lisp_Object Qerror, Quser_error, Qquit, Qargs_out_of_range;
+static Lisp_Object Qwrong_length_argument;
static Lisp_Object Qwrong_type_argument;
Lisp_Object Qvoid_variable, Qvoid_function;
static Lisp_Object Qcyclic_function_indirection;
@@ -54,6 +58,7 @@ Lisp_Object Qintegerp, Qwholenump, Qsymbolp, Qlistp, Qconsp;
static Lisp_Object Qnatnump;
Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
+Lisp_Object Qbool_vector_p;
Lisp_Object Qbuffer_or_string_p;
static Lisp_Object Qkeywordp, Qboundp;
Lisp_Object Qfboundp;
@@ -175,6 +180,18 @@ set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
blv->valcell = val;
}
+static _Noreturn void
+wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
+{
+ Lisp_Object size1 = make_number (bool_vector_size (a1));
+ Lisp_Object size2 = make_number (bool_vector_size (a2));
+ if (NILP (a3))
+ xsignal2 (Qwrong_length_argument, size1, size2);
+ else
+ xsignal3 (Qwrong_length_argument, size1, size2,
+ make_number (bool_vector_size (a3)));
+}
+
Lisp_Object
wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value)
{
@@ -616,7 +633,7 @@ global value outside of any lexical scope. */)
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
if (blv->fwd)
/* In set_internal, we un-forward vars when their value is
- set to Qunbound. */
+ set to Qunbound. */
return Qt;
else
{
@@ -627,7 +644,7 @@ global value outside of any lexical scope. */)
}
case SYMBOL_FORWARDED:
/* In set_internal, we un-forward vars when their value is
- set to Qunbound. */
+ set to Qunbound. */
return Qt;
default: emacs_abort ();
}
@@ -1534,8 +1551,12 @@ Note that binding the variable with `let', or setting it while
a `let'-style binding made in this buffer is in effect,
does not make the variable buffer-local. Return VARIABLE.
-In most cases it is better to use `make-local-variable',
-which makes a variable local in just one buffer.
+This globally affects all uses of this variable, so it belongs together with
+the variable declaration, rather than with its uses (if you just want to make
+a variable local to the current buffer for one particular use, use
+`make-local-variable'). Buffer-local bindings are normally cleared
+while setting up a new major mode, unless they have a `permanent-local'
+property.
The function `default-value' gets the default value and `set-default' sets it. */)
(register Lisp_Object variable)
@@ -1995,7 +2016,7 @@ If the current binding is global (the default), the value is nil. */)
}
/* This code is disabled now that we use the selected frame to return
- keyboard-local-values. */
+ keyboard-local-values. */
#if 0
extern struct terminal *get_terminal (Lisp_Object display, int);
@@ -2124,13 +2145,9 @@ or a byte-code object. IDX starts at 0. */)
}
else if (BOOL_VECTOR_P (array))
{
- int val;
-
- if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
+ if (idxval < 0 || idxval >= bool_vector_size (array))
args_out_of_range (array, idx);
-
- val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
- return (val & (1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)) ? Qt : Qnil);
+ return bool_vector_ref (array, idxval);
}
else if (CHAR_TABLE_P (array))
{
@@ -2174,18 +2191,9 @@ bool-vector. IDX starts at 0. */)
}
else if (BOOL_VECTOR_P (array))
{
- int val;
-
- if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
+ if (idxval < 0 || idxval >= bool_vector_size (array))
args_out_of_range (array, idx);
-
- val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
-
- if (! NILP (newelt))
- val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR);
- else
- val &= ~(1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR));
- XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR] = val;
+ bool_vector_set (array, idxval, !NILP (newelt));
}
else if (CHAR_TABLE_P (array))
{
@@ -2956,6 +2964,432 @@ lowercase l) for small endian machines. */)
return make_number (order);
}
+/* Because we round up the bool vector allocate size to word_size
+ units, we can safely read past the "end" of the vector in the
+ operations below. These extra bits are always zero. */
+
+static bits_word
+bool_vector_spare_mask (EMACS_INT nr_bits)
+{
+ return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1;
+}
+
+/* Info about unsigned long long, falling back on unsigned long
+ if unsigned long long is not available. */
+
+#if HAVE_UNSIGNED_LONG_LONG_INT
+enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long long) };
+#else
+enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long) };
+# define ULLONG_MAX ULONG_MAX
+# define count_one_bits_ll count_one_bits_l
+#endif
+
+/* Shift VAL right by the width of an unsigned long long.
+ BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
+
+static bits_word
+shift_right_ull (bits_word w)
+{
+ /* Pacify bogus GCC warning about shift count exceeding type width. */
+ int shift = BITS_PER_ULL - BITS_PER_BITS_WORD < 0 ? BITS_PER_ULL : 0;
+ return w >> shift;
+}
+
+/* Return the number of 1 bits in W. */
+
+static int
+count_one_bits_word (bits_word w)
+{
+ if (BITS_WORD_MAX <= UINT_MAX)
+ return count_one_bits (w);
+ else if (BITS_WORD_MAX <= ULONG_MAX)
+ return count_one_bits_l (w);
+ else
+ {
+ int i = 0, count = 0;
+ while (count += count_one_bits_ll (w),
+ BITS_PER_BITS_WORD <= (i += BITS_PER_ULL))
+ w = shift_right_ull (w);
+ return count;
+ }
+}
+
+enum bool_vector_op { bool_vector_exclusive_or,
+ bool_vector_union,
+ bool_vector_intersection,
+ bool_vector_set_difference,
+ bool_vector_subsetp };
+
+static Lisp_Object
+bool_vector_binop_driver (Lisp_Object a,
+ Lisp_Object b,
+ Lisp_Object dest,
+ enum bool_vector_op op)
+{
+ EMACS_INT nr_bits;
+ bits_word *adata, *bdata, *destdata;
+ ptrdiff_t i = 0;
+ ptrdiff_t nr_words;
+
+ CHECK_BOOL_VECTOR (a);
+ CHECK_BOOL_VECTOR (b);
+
+ nr_bits = bool_vector_size (a);
+ if (bool_vector_size (b) != nr_bits)
+ wrong_length_argument (a, b, dest);
+
+ nr_words = bool_vector_words (nr_bits);
+ adata = bool_vector_data (a);
+ bdata = bool_vector_data (b);
+
+ if (NILP (dest))
+ {
+ dest = make_uninit_bool_vector (nr_bits);
+ destdata = bool_vector_data (dest);
+ }
+ else
+ {
+ CHECK_BOOL_VECTOR (dest);
+ destdata = bool_vector_data (dest);
+ if (bool_vector_size (dest) != nr_bits)
+ wrong_length_argument (a, b, dest);
+
+ switch (op)
+ {
+ case bool_vector_exclusive_or:
+ for (; i < nr_words; i++)
+ if (destdata[i] != (adata[i] ^ bdata[i]))
+ goto set_dest;
+ break;
+
+ case bool_vector_subsetp:
+ for (; i < nr_words; i++)
+ if (adata[i] &~ bdata[i])
+ return Qnil;
+ return Qt;
+
+ case bool_vector_union:
+ for (; i < nr_words; i++)
+ if (destdata[i] != (adata[i] | bdata[i]))
+ goto set_dest;
+ break;
+
+ case bool_vector_intersection:
+ for (; i < nr_words; i++)
+ if (destdata[i] != (adata[i] & bdata[i]))
+ goto set_dest;
+ break;
+
+ case bool_vector_set_difference:
+ for (; i < nr_words; i++)
+ if (destdata[i] != (adata[i] &~ bdata[i]))
+ goto set_dest;
+ break;
+ }
+
+ return Qnil;
+ }
+
+ set_dest:
+ switch (op)
+ {
+ case bool_vector_exclusive_or:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] ^ bdata[i];
+ break;
+
+ case bool_vector_union:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] | bdata[i];
+ break;
+
+ case bool_vector_intersection:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] & bdata[i];
+ break;
+
+ case bool_vector_set_difference:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] &~ bdata[i];
+ break;
+
+ default:
+ eassume (0);
+ }
+
+ return dest;
+}
+
+/* PRECONDITION must be true. Return VALUE. This odd construction
+ works around a bogus GCC diagnostic "shift count >= width of type". */
+
+static int
+pre_value (bool precondition, int value)
+{
+ eassume (precondition);
+ return precondition ? value : 0;
+}
+
+/* Compute the number of trailing zero bits in val. If val is zero,
+ return the number of bits in val. */
+static int
+count_trailing_zero_bits (bits_word val)
+{
+ if (BITS_WORD_MAX == UINT_MAX)
+ return count_trailing_zeros (val);
+ if (BITS_WORD_MAX == ULONG_MAX)
+ return count_trailing_zeros_l (val);
+ if (BITS_WORD_MAX == ULLONG_MAX)
+ return count_trailing_zeros_ll (val);
+
+ /* The rest of this code is for the unlikely platform where bits_word differs
+ in width from unsigned int, unsigned long, and unsigned long long. */
+ val |= ~ BITS_WORD_MAX;
+ if (BITS_WORD_MAX <= UINT_MAX)
+ return count_trailing_zeros (val);
+ if (BITS_WORD_MAX <= ULONG_MAX)
+ return count_trailing_zeros_l (val);
+ else
+ {
+ int count;
+ for (count = 0;
+ count < BITS_PER_BITS_WORD - BITS_PER_ULL;
+ count += BITS_PER_ULL)
+ {
+ if (val & ULLONG_MAX)
+ return count + count_trailing_zeros_ll (val);
+ val = shift_right_ull (val);
+ }
+
+ if (BITS_PER_BITS_WORD % BITS_PER_ULL != 0
+ && BITS_WORD_MAX == (bits_word) -1)
+ val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX,
+ BITS_PER_BITS_WORD % BITS_PER_ULL);
+ return count + count_trailing_zeros_ll (val);
+ }
+}
+
+static bits_word
+bits_word_to_host_endian (bits_word val)
+{
+#ifndef WORDS_BIGENDIAN
+ return val;
+#else
+ if (BITS_WORD_MAX >> 31 == 1)
+ return bswap_32 (val);
+# if HAVE_UNSIGNED_LONG_LONG
+ if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
+ return bswap_64 (val);
+# endif
+ {
+ int i;
+ bits_word r = 0;
+ for (i = 0; i < sizeof val; i++)
+ {
+ r = ((r << 1 << (CHAR_BIT - 1))
+ | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
+ val = val >> 1 >> (CHAR_BIT - 1);
+ }
+ return r;
+ }
+#endif
+}
+
+DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or,
+ Sbool_vector_exclusive_or, 2, 3, 0,
+ doc: /* Return A ^ B, bitwise exclusive or.
+If optional third argument C is given, store result into C.
+A, B, and C must be bool vectors of the same length.
+Return the destination vector if it changed or nil otherwise. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object c)
+{
+ return bool_vector_binop_driver (a, b, c, bool_vector_exclusive_or);
+}
+
+DEFUN ("bool-vector-union", Fbool_vector_union,
+ Sbool_vector_union, 2, 3, 0,
+ doc: /* Return A | B, bitwise or.
+If optional third argument C is given, store result into C.
+A, B, and C must be bool vectors of the same length.
+Return the destination vector if it changed or nil otherwise. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object c)
+{
+ return bool_vector_binop_driver (a, b, c, bool_vector_union);
+}
+
+DEFUN ("bool-vector-intersection", Fbool_vector_intersection,
+ Sbool_vector_intersection, 2, 3, 0,
+ doc: /* Return A & B, bitwise and.
+If optional third argument C is given, store result into C.
+A, B, and C must be bool vectors of the same length.
+Return the destination vector if it changed or nil otherwise. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object c)
+{
+ return bool_vector_binop_driver (a, b, c, bool_vector_intersection);
+}
+
+DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference,
+ Sbool_vector_set_difference, 2, 3, 0,
+ doc: /* Return A &~ B, set difference.
+If optional third argument C is given, store result into C.
+A, B, and C must be bool vectors of the same length.
+Return the destination vector if it changed or nil otherwise. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object c)
+{
+ return bool_vector_binop_driver (a, b, c, bool_vector_set_difference);
+}
+
+DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp,
+ Sbool_vector_subsetp, 2, 2, 0,
+ doc: /* Return t if every t value in A is also t in B, nil otherwise.
+A and B must be bool vectors of the same length. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ return bool_vector_binop_driver (a, b, b, bool_vector_subsetp);
+}
+
+DEFUN ("bool-vector-not", Fbool_vector_not,
+ Sbool_vector_not, 1, 2, 0,
+ doc: /* Compute ~A, set complement.
+If optional second argument B is given, store result into B.
+A and B must be bool vectors of the same length.
+Return the destination vector. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ EMACS_INT nr_bits;
+ bits_word *bdata, *adata;
+ ptrdiff_t i;
+
+ CHECK_BOOL_VECTOR (a);
+ nr_bits = bool_vector_size (a);
+
+ if (NILP (b))
+ b = make_uninit_bool_vector (nr_bits);
+ else
+ {
+ CHECK_BOOL_VECTOR (b);
+ if (bool_vector_size (b) != nr_bits)
+ wrong_length_argument (a, b, Qnil);
+ }
+
+ bdata = bool_vector_data (b);
+ adata = bool_vector_data (a);
+
+ for (i = 0; i < nr_bits / BITS_PER_BITS_WORD; i++)
+ bdata[i] = BITS_WORD_MAX & ~adata[i];
+
+ if (nr_bits % BITS_PER_BITS_WORD)
+ {
+ bits_word mword = bits_word_to_host_endian (adata[i]);
+ mword = ~mword;
+ mword &= bool_vector_spare_mask (nr_bits);
+ bdata[i] = bits_word_to_host_endian (mword);
+ }
+
+ return b;
+}
+
+DEFUN ("bool-vector-count-population", Fbool_vector_count_population,
+ Sbool_vector_count_population, 1, 1, 0,
+ doc: /* Count how many elements in A are t.
+A is a bool vector. To count A's nil elements, subtract the return
+value from A's length. */)
+ (Lisp_Object a)
+{
+ EMACS_INT count;
+ EMACS_INT nr_bits;
+ bits_word *adata;
+ ptrdiff_t i, nwords;
+
+ CHECK_BOOL_VECTOR (a);
+
+ nr_bits = bool_vector_size (a);
+ nwords = bool_vector_words (nr_bits);
+ count = 0;
+ adata = bool_vector_data (a);
+
+ for (i = 0; i < nwords; i++)
+ count += count_one_bits_word (adata[i]);
+
+ return make_number (count);
+}
+
+DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive,
+ Sbool_vector_count_consecutive, 3, 3, 0,
+ doc: /* Count how many consecutive elements in A equal B starting at I.
+A is a bool vector, B is t or nil, and I is an index into A. */)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object i)
+{
+ EMACS_INT count;
+ EMACS_INT nr_bits;
+ int offset;
+ bits_word *adata;
+ bits_word twiddle;
+ bits_word mword; /* Machine word. */
+ ptrdiff_t pos, pos0;
+ ptrdiff_t nr_words;
+
+ CHECK_BOOL_VECTOR (a);
+ CHECK_NATNUM (i);
+
+ nr_bits = bool_vector_size (a);
+ if (XFASTINT (i) > nr_bits) /* Allow one past the end for convenience */
+ args_out_of_range (a, i);
+
+ adata = bool_vector_data (a);
+ nr_words = bool_vector_words (nr_bits);
+ pos = XFASTINT (i) / BITS_PER_BITS_WORD;
+ offset = XFASTINT (i) % BITS_PER_BITS_WORD;
+ count = 0;
+
+ /* By XORing with twiddle, we transform the problem of "count
+ consecutive equal values" into "count the zero bits". The latter
+ operation usually has hardware support. */
+ twiddle = NILP (b) ? 0 : BITS_WORD_MAX;
+
+ /* Scan the remainder of the mword at the current offset. */
+ if (pos < nr_words && offset != 0)
+ {
+ mword = bits_word_to_host_endian (adata[pos]);
+ mword ^= twiddle;
+ mword >>= offset;
+
+ /* Do not count the pad bits. */
+ mword |= (bits_word) 1 << (BITS_PER_BITS_WORD - offset);
+
+ count = count_trailing_zero_bits (mword);
+ pos++;
+ if (count + offset < BITS_PER_BITS_WORD)
+ return make_number (count);
+ }
+
+ /* Scan whole words until we either reach the end of the vector or
+ find an mword that doesn't completely match. twiddle is
+ endian-independent. */
+ pos0 = pos;
+ while (pos < nr_words && adata[pos] == twiddle)
+ pos++;
+ count += (pos - pos0) * BITS_PER_BITS_WORD;
+
+ if (pos < nr_words)
+ {
+ /* If we stopped because of a mismatch, see how many bits match
+ in the current mword. */
+ mword = bits_word_to_host_endian (adata[pos]);
+ mword ^= twiddle;
+ count += count_trailing_zero_bits (mword);
+ }
+ else if (nr_bits % BITS_PER_BITS_WORD != 0)
+ {
+ /* If we hit the end, we might have overshot our count. Reduce
+ the total by the number of spare bits at the end of the
+ vector. */
+ count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD;
+ }
+
+ return make_number (count);
+}
void
@@ -2973,6 +3407,7 @@ syms_of_data (void)
DEFSYM (Qerror, "error");
DEFSYM (Quser_error, "user-error");
DEFSYM (Qquit, "quit");
+ DEFSYM (Qwrong_length_argument, "wrong-length-argument");
DEFSYM (Qwrong_type_argument, "wrong-type-argument");
DEFSYM (Qargs_out_of_range, "args-out-of-range");
DEFSYM (Qvoid_function, "void-function");
@@ -3005,6 +3440,7 @@ syms_of_data (void)
DEFSYM (Qsequencep, "sequencep");
DEFSYM (Qbufferp, "bufferp");
DEFSYM (Qvectorp, "vectorp");
+ DEFSYM (Qbool_vector_p, "bool-vector-p");
DEFSYM (Qchar_or_string_p, "char-or-string-p");
DEFSYM (Qmarkerp, "markerp");
DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p");
@@ -3046,6 +3482,7 @@ syms_of_data (void)
PUT_ERROR (Qquit, Qnil, "Quit");
PUT_ERROR (Quser_error, error_tail, "");
+ PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument");
PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range");
PUT_ERROR (Qvoid_function, error_tail,
@@ -3222,6 +3659,15 @@ syms_of_data (void)
defsubr (&Ssubr_arity);
defsubr (&Ssubr_name);
+ defsubr (&Sbool_vector_exclusive_or);
+ defsubr (&Sbool_vector_union);
+ defsubr (&Sbool_vector_intersection);
+ defsubr (&Sbool_vector_set_difference);
+ defsubr (&Sbool_vector_not);
+ defsubr (&Sbool_vector_subsetp);
+ defsubr (&Sbool_vector_count_consecutive);
+ defsubr (&Sbool_vector_count_population);
+
set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function);
DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,