/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
- Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
+ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
Foundation, Inc.
This file is part of GNU Emacs.
#include <config.h>
#include <stdio.h>
+#include <byteswap.h>
+#include <count-one-bits.h>
+#include <count-trailing-zeros.h>
#include <intprops.h>
#include "lisp.h"
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;
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)
{
xsignal2 (Qwrong_type_argument, predicate, value);
}
-void
-pure_write_error (Lisp_Object obj)
-{
- xsignal2 (Qerror, build_string ("Attempt to modify read-only object"), obj);
-}
-
void
args_out_of_range (Lisp_Object a1, Lisp_Object a2)
{
}
DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
- doc: /* Return SYMBOL's function definition. Error if that is void. */)
+ doc: /* Return SYMBOL's function definition, or nil if that is void. */)
(register Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
if (AUTOLOADP (function))
Fput (symbol, Qautoload, XCDR (function));
+ /* Convert to eassert or remove after GC bug is found. In the
+ meantime, check unconditionally, at a slight perf hit. */
+ if (valid_lisp_object_p (definition) < 1)
+ emacs_abort ();
+
set_symbol_function (symbol, definition);
return definition;
The optional third argument DOCSTRING specifies the documentation string
for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
determined by DEFINITION.
+
+Internally, this normally uses `fset', but if SYMBOL has a
+`defalias-fset-function' property, the associated value is used instead.
+
The return value is undefined. */)
(register Lisp_Object symbol, Lisp_Object definition, Lisp_Object docstring)
{
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)
}
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))
{
}
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))
{
arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
enum Arith_Comparison comparison)
{
- for (ptrdiff_t argnum = 1; argnum < nargs; ++argnum)
+ ptrdiff_t argnum;
+ for (argnum = 1; argnum < nargs; ++argnum)
{
- if (EQ (Qnil, arithcompare (args[argnum-1], args[argnum], comparison)))
+ if (EQ (Qnil, arithcompare (args[argnum - 1], args[argnum], comparison)))
return Qnil;
}
return Qt;
}
DEFUN ("<", Flss, Slss, 1, MANY, 0,
- doc: /* Return t if each arg is less than the next arg. All must be numbers or markers.
+ doc: /* Return t if each arg (a number or marker), is less than the next arg.
usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
}
DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
- doc: /* Return t if each arg is greater than the next arg. All must be numbers or markers.
+ doc: /* Return t if each arg (a number or marker) is greater than the next arg.
usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
}
DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
- doc: /* Return t if each arg is less than or equal to the next arg.
-All must be numbers or markers.
+ doc: /* Return t if each arg (a number or marker) is less than or equal to the next.
usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
}
DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0,
- doc: /* Return t if each arg is greater than or equal to the next arg.
-All must be numbers or markers.
-usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
+ doc: /* Return t if each arg (a number or marker) is greater than or equal to the next.
+usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
{
return arithcompare (num1, num2, ARITH_NOTEQUAL);
}
-
-DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
- doc: /* Return t if NUMBER is zero. */)
- (register Lisp_Object number)
-{
- CHECK_NUMBER_OR_FLOAT (number);
-
- if (FLOATP (number))
- {
- if (XFLOAT_DATA (number) == 0.0)
- return Qt;
- return Qnil;
- }
-
- if (!XINT (number))
- return Qt;
- return Qnil;
-}
\f
/* Convert the cons-of-integers, integer, or float value C to an
unsigned value with maximum value MAX. Signal an error if C does not
DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
doc: /* Parse STRING as a decimal number and return the number.
-This parses both integers and floating point numbers.
-It ignores leading spaces and tabs, and all trailing chars.
+Ignore leading spaces and tabs, and all trailing chars. Return 0 if
+STRING cannot be parsed as an integer or floating point number.
If BASE, interpret STRING as a number in that base. If BASE isn't
present, base 10 is used. BASE must be between 2 and 16 (inclusive).
-If the base used is not 10, STRING is always parsed as integer. */)
+If the base used is not 10, STRING is always parsed as an integer. */)
(register Lisp_Object string, Lisp_Object base)
{
register char *p;
if (XINT (count) >= BITS_PER_EMACS_INT)
XSETINT (val, 0);
else if (XINT (count) > 0)
- XSETINT (val, XINT (value) << XFASTINT (count));
+ XSETINT (val, XUINT (value) << XFASTINT (count));
else if (XINT (count) <= -BITS_PER_EMACS_INT)
XSETINT (val, XINT (value) < 0 ? -1 : 0);
else
/* 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. Also, we
- always allocate bool vectors with at least one size_t of storage so
- that we don't have to special-case empty bit vectors. */
+ operations below. These extra bits are always zero. */
-static size_t
-bool_vector_spare_mask (ptrdiff_t nr_bits)
+static bits_word
+bool_vector_spare_mask (EMACS_INT nr_bits)
{
- eassert_and_assume (nr_bits > 0);
- return (((size_t) 1) << (nr_bits % BITS_PER_SIZE_T)) - 1;
+ return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1;
}
-#if _MSC_VER >= 1500 && (defined _M_IX86 || defined _M_X64)
-# define USE_MSC_POPCOUNT
-#elif __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)
-# define USE_GCC_POPCOUNT
+/* Info about unsigned long long, falling back on unsigned long
+ if unsigned long long is not available. */
+
+#if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
+enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long long) };
+# define ULL_MAX ULLONG_MAX
#else
-# define NEED_GENERIC_POPCOUNT
+enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long) };
+# define ULL_MAX ULONG_MAX
+# define count_one_bits_ll count_one_bits_l
+# define count_trailing_zeros_ll count_trailing_zeros_l
#endif
-#ifdef USE_MSC_POPCOUNT
-#define NEED_GENERIC_POPCOUNT
-#endif
+/* Shift VAL right by the width of an unsigned long long.
+ BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
-#ifdef NEED_GENERIC_POPCOUNT
-static unsigned int
-popcount_size_t_generic (size_t val)
+static bits_word
+shift_right_ull (bits_word w)
{
- unsigned short j;
- unsigned int count = 0;
-
- for (j = 0; j < BITS_PER_SIZE_T; ++j)
- count += !!((((size_t) 1) << j) & val);
-
- return count;
+ /* 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;
}
-#endif
-#ifdef USE_MSC_POPCOUNT
-static unsigned int
-popcount_size_t_msc (size_t val)
-{
- unsigned int count;
-
-#pragma intrinsic __cpuid
- /* While gcc falls back to its own generic code if the machine on
- which it's running doesn't support popcount, we need to perform the
- detection and fallback ourselves when compiling with Microsoft's
- compiler. */
-
- static enum {
- popcount_unknown_support,
- popcount_use_generic,
- popcount_use_intrinsic
- } popcount_state;
-
- if (popcount_state == popcount_unknown_support)
- {
- int cpu_info[4];
- __cpuid (cpu_info, 1);
- if (cpu_info[2] & (1<<23)) /* See MSDN. */
- popcount_state = popcount_use_intrinsic;
- else
- popcount_state = popcount_use_generic;
- }
+/* Return the number of 1 bits in W. */
- if (popcount_state == popcount_use_intrinsic)
- {
-# if BITS_PER_SIZE_T == 64
-# pragma intrinsic __popcnt64
- count = __popcnt64 (val);
-# else
-# pragma intrinsic __popcnt
- count = __popcnt (val);
-# endif
- }
- else
- count = popcount_size_t_generic (val);
-
- return count;
-}
-#endif /* USE_MSC_POPCOUNT */
-
-#ifdef USE_GCC_POPCOUNT
-static unsigned int
-popcount_size_t_gcc (size_t val)
+static int
+count_one_bits_word (bits_word w)
{
-# if BITS_PER_SIZE_T == 64
- return __builtin_popcountll (val);
-# else
- return __builtin_popcount (val);
-# endif
-}
-#endif /* USE_GCC_POPCOUNT */
-
-static unsigned int
-popcount_size_t (size_t val)
-{
-#if defined USE_MSC_POPCOUNT
- return popcount_size_t_msc (val);
-#elif defined USE_GCC_POPCOUNT
- return popcount_size_t_gcc (val);
-#else
- return popcount_size_t_generic (val);
-#endif
+ 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),
+ (i += BITS_PER_ULL) < BITS_PER_BITS_WORD)
+ w = shift_right_ull (w);
+ return count;
+ }
}
enum bool_vector_op { bool_vector_exclusive_or,
bool_vector_subsetp };
static Lisp_Object
-bool_vector_binop_driver (Lisp_Object op1,
- Lisp_Object op2,
+bool_vector_binop_driver (Lisp_Object a,
+ Lisp_Object b,
Lisp_Object dest,
enum bool_vector_op op)
{
EMACS_INT nr_bits;
- size_t *adata, *bdata, *cdata;
- ptrdiff_t i;
- size_t changed = 0;
- size_t mword;
+ bits_word *adata, *bdata, *destdata;
+ ptrdiff_t i = 0;
ptrdiff_t nr_words;
- CHECK_BOOL_VECTOR (op1);
- CHECK_BOOL_VECTOR (op2);
+ 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_bits = min (XBOOL_VECTOR (op1)->size,
- XBOOL_VECTOR (op2)->size);
+ nr_words = bool_vector_words (nr_bits);
+ adata = bool_vector_data (a);
+ bdata = bool_vector_data (b);
if (NILP (dest))
{
- dest = Fmake_bool_vector (make_number (nr_bits), Qnil);
- changed = 1;
+ dest = make_uninit_bool_vector (nr_bits);
+ destdata = bool_vector_data (dest);
}
else
{
CHECK_BOOL_VECTOR (dest);
- nr_bits = min (nr_bits, XBOOL_VECTOR (dest)->size);
- }
+ 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;
- eassert_and_assume (nr_bits >= 0);
- nr_words = ROUNDUP (nr_bits, BITS_PER_SIZE_T) / BITS_PER_SIZE_T;
+ 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;
+ }
- adata = (size_t *) XBOOL_VECTOR (dest)->data;
- bdata = (size_t *) XBOOL_VECTOR (op1)->data;
- cdata = (size_t *) XBOOL_VECTOR (op2)->data;
- i = 0;
- do
+ return Qnil;
+ }
+
+ set_dest:
+ switch (op)
{
- if (op == bool_vector_exclusive_or)
- mword = bdata[i] ^ cdata[i];
- else if (op == bool_vector_union || op == bool_vector_subsetp)
- mword = bdata[i] | cdata[i];
- else if (op == bool_vector_intersection)
- mword = bdata[i] & cdata[i];
- else if (op == bool_vector_set_difference)
- mword = bdata[i] &~ cdata[i];
- else
- abort ();
+ 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;
- changed |= adata[i] ^ mword;
+ case bool_vector_intersection:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] & bdata[i];
+ break;
- if (op != bool_vector_subsetp)
- adata[i] = mword;
+ case bool_vector_set_difference:
+ for (; i < nr_words; i++)
+ destdata[i] = adata[i] &~ bdata[i];
+ break;
- i++;
+ default:
+ eassume (0);
}
- while (i < nr_words);
- return changed ? dest : Qnil;
+ 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 unsigned int
-count_trailing_zero_bits (size_t val)
-{
- if (val == 0)
- return CHAR_BIT * sizeof (val);
-
-#if defined USE_GCC_POPCOUNT && BITS_PER_SIZE_T == 64
- return __builtin_ctzll (val);
-#elif defined USE_GCC_POPCOUNT && BITS_PER_SIZE_T == 32
- return __builtin_ctz (val);
-#elif _MSC_VER && BITS_PER_SIZE_T == 64
-# pragma intrinsic _BitScanForward64
- {
- /* No support test needed: support since 386. */
- unsigned long result;
- _BitScanForward64 (&result, val);
- return (unsigned int) result;
- }
-#elif _MSC_VER && BITS_PER_SIZE_T == 32
-# pragma intrinsic _BitScanForward
- {
- /* No support test needed: support since 386. */
- unsigned long result;
- _BitScanForward (&result, val);
- return (unsigned int) result;
- }
-#else
- {
- unsigned int count;
- count = 0;
- for (val = ~val; val & 1; val >>= 1)
- ++count;
+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 == ULL_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 & ULL_MAX)
+ return count + count_trailing_zeros_ll (val);
+ val = shift_right_ull (val);
+ }
- return count;
- }
-#endif
+ 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 size_t
-size_t_to_host_endian (size_t val)
+static bits_word
+bits_word_to_host_endian (bits_word val)
{
-#ifdef WORDS_BIGENDIAN
-# if BITS_PER_SIZE_T == 64
- return swap64 (val);
-# else
- return swap32 (val);
-# endif
-#else
+#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: /* Compute C = A ^ B, bitwise exclusive or.
-A, B, and C must be bool vectors. If C is nil, allocate a new bool
-vector in which to store the result. Return the destination vector if
-it changed or nil otherwise. */
- )
+ 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: /* Compute C = A | B, bitwise or.
-A, B, and C must be bool vectors. If C is nil, allocate a new bool
-vector in which to store the result. Return the destination vector if
-it changed or nil otherwise. */)
+ 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: /* Compute C = A & B, bitwise and.
-A, B, and C must be bool vectors. If C is nil, allocate a new bool
-vector in which to store the result. Return the destination vector if
-it changed or nil otherwise. */)
+ 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: /* Compute C = A &~ B, set difference.
-A, B, and C must be bool vectors. If C is nil, allocate a new bool
-vector in which to store the result. Return the destination vector if
-it changed or nil otherwise. */)
+ 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: )
+ 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)
{
- /* Like bool_vector_union, but doesn't modify b. */
- return bool_vector_binop_driver (b, a, b, bool_vector_subsetp);
+ 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 B = ~A.
-B must be a bool vector. A must be a bool vector or nil.
-If A is nil, allocate a new bool vector in which to store the result.
+ 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;
- size_t *bdata, *adata;
+ bits_word *bdata, *adata;
ptrdiff_t i;
- size_t mword;
CHECK_BOOL_VECTOR (a);
- nr_bits = XBOOL_VECTOR (a)->size;
+ nr_bits = bool_vector_size (a);
if (NILP (b))
- b = Fmake_bool_vector (make_number (nr_bits), Qnil);
+ b = make_uninit_bool_vector (nr_bits);
else
{
CHECK_BOOL_VECTOR (b);
- nr_bits = min (nr_bits, XBOOL_VECTOR (b)->size);
+ if (bool_vector_size (b) != nr_bits)
+ wrong_length_argument (a, b, Qnil);
}
- bdata = (size_t *) XBOOL_VECTOR (b)->data;
- adata = (size_t *) XBOOL_VECTOR (a)->data;
+ bdata = bool_vector_data (b);
+ adata = bool_vector_data (a);
- eassert_and_assume (nr_bits >= 0);
+ for (i = 0; i < nr_bits / BITS_PER_BITS_WORD; i++)
+ bdata[i] = BITS_WORD_MAX & ~adata[i];
- for (i = 0; i < nr_bits / BITS_PER_SIZE_T; i++)
- bdata[i] = ~adata[i];
-
- if (nr_bits % BITS_PER_SIZE_T)
+ if (nr_bits % BITS_PER_BITS_WORD)
{
- mword = size_t_to_host_endian (adata[i]);
+ bits_word mword = bits_word_to_host_endian (adata[i]);
mword = ~mword;
mword &= bool_vector_spare_mask (nr_bits);
- bdata[i] = size_t_to_host_endian (mword);
+ bdata[i] = bits_word_to_host_endian (mword);
}
return b;
}
-DEFUN ("bool-vector-count-matches", Fbool_vector_count_matches,
- Sbool_vector_count_matches, 2, 2, 0,
- doc: /* Count how many elements in A equal B.
-A must be a bool vector. B is a generalized bool. */)
- (Lisp_Object a, Lisp_Object 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)
{
- ptrdiff_t count;
+ EMACS_INT count;
EMACS_INT nr_bits;
- size_t *adata;
- size_t match;
- ptrdiff_t i;
+ bits_word *adata;
+ ptrdiff_t i, nwords;
CHECK_BOOL_VECTOR (a);
- nr_bits = XBOOL_VECTOR (a)->size;
+ nr_bits = bool_vector_size (a);
+ nwords = bool_vector_words (nr_bits);
count = 0;
- match = NILP (b) ? (size_t) -1 : 0;
- adata = (size_t *) XBOOL_VECTOR (a)->data;
-
- eassert_and_assume (nr_bits >= 0);
+ adata = bool_vector_data (a);
- for (i = 0; i < nr_bits / BITS_PER_SIZE_T; ++i)
- count += popcount_size_t (adata[i] ^ match);
-
- /* Mask out trailing parts of final mword. */
- if (nr_bits % BITS_PER_SIZE_T)
- {
- size_t mword = adata[i] ^ match;
- mword = size_t_to_host_endian (mword);
- count += popcount_size_t (mword & bool_vector_spare_mask (nr_bits));
- }
+ for (i = 0; i < nwords; i++)
+ count += count_one_bits_word (adata[i]);
return make_number (count);
}
-DEFUN ("bool-vector-count-matches-at",
- Fbool_vector_count_matches_at,
- Sbool_vector_count_matches_at, 3, 3, 0,
- doc: /* Count how many consecutive elements in A equal B at i.
-A must be a bool vector. B is a generalized boolean. i is an
-index into the vector. */)
+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)
{
- ptrdiff_t count;
+ EMACS_INT count;
EMACS_INT nr_bits;
- ptrdiff_t offset;
- size_t *adata;
- size_t twiddle;
- size_t mword; /* Machine word. */
- ptrdiff_t pos;
+ 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 = XBOOL_VECTOR (a)->size;
+ 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 = (size_t *) XBOOL_VECTOR (a)->data;
-
- assume (nr_bits >= 0);
- nr_words = ROUNDUP (nr_bits, BITS_PER_SIZE_T) / BITS_PER_SIZE_T;
-
- pos = XFASTINT (i) / BITS_PER_SIZE_T;
- offset = XFASTINT (i) % BITS_PER_SIZE_T;
+ 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 : (size_t) -1;
+ twiddle = NILP (b) ? 0 : BITS_WORD_MAX;
/* Scan the remainder of the mword at the current offset. */
if (pos < nr_words && offset != 0)
{
- mword = size_t_to_host_endian (adata[pos]);
+ 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);
- count = min (count, BITS_PER_SIZE_T - offset);
pos++;
- if (count + offset < BITS_PER_SIZE_T)
+ 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)
- {
- count += BITS_PER_SIZE_T;
- ++pos;
- }
+ 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 = size_t_to_host_endian (adata[pos]);
+ mword = bits_word_to_host_endian (adata[pos]);
mword ^= twiddle;
count += count_trailing_zero_bits (mword);
}
- else if (nr_bits % BITS_PER_SIZE_T != 0)
+ 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_SIZE_T - nr_bits % BITS_PER_SIZE_T;
+ count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD;
}
return make_number (count);
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");
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,
defsubr (&Sleq);
defsubr (&Sgeq);
defsubr (&Sneq);
- defsubr (&Szerop);
defsubr (&Splus);
defsubr (&Sminus);
defsubr (&Stimes);
defsubr (&Sbool_vector_set_difference);
defsubr (&Sbool_vector_not);
defsubr (&Sbool_vector_subsetp);
- defsubr (&Sbool_vector_count_matches);
- defsubr (&Sbool_vector_count_matches_at);
+ defsubr (&Sbool_vector_count_consecutive);
+ defsubr (&Sbool_vector_count_population);
set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function);
HCoop / bpt / emacs.git / blobdiff