[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] trunk r114426: Add set operations for bool-vector.
|
From: |
Daniel Colascione |
|
Subject: |
[Emacs-diffs] trunk r114426: Add set operations for bool-vector. |
|
Date: |
Sun, 22 Sep 2013 09:35:25 +0000 |
|
User-agent: |
Bazaar (2.6b2) |
------------------------------------------------------------
revno: 114426
revision-id: address@hidden
parent: address@hidden
committer: Daniel Colascione <address@hidden>
branch nick: trunk
timestamp: Sun 2013-09-22 01:31:55 -0800
message:
Add set operations for bool-vector.
http://lists.gnu.org/archive/html/emacs-devel/2013-09/msg00404.html
* data.c (Qbool_vector_p): New symbol.
(bool_vector_spare_mask,popcount_size_t_generic)
(popcount_size_t_msc,popcount_size_t_gcc)
(popcount_size_t)
(bool_vector_binop_driver)
(count_trailing_zero_bits,size_t_to_host_endian)
(Fbool_vector_exclusive_or)
(Fbool_vector_union)
(Fbool_vector_intersection,Fbool_vector_set_difference)
(Fbool_vector_subsetp,Fbool_vector_not)
(Fbool_vector_count_matches)
(Fbool_vector_count_matches_at): New functions.
(syms_of_data): Intern new symbol, functions.
* alloc.c (bool_vector_payload_bytes): New function.
(Fmake_bool_vector): Instead of calling Fmake_vector,
which performs redundant initialization and argument checking,
just call allocate_vector ourselves. Make sure we clear any
terminating padding to zero.
(vector_nbytes,sweep_vectors): Use bool_vector_payload_bytes
instead of open-coding the size calculation.
(vroundup_ct): New macro.
(vroundup): Assume argument >= 0; invoke vroundup_ct.
* casetab.c (shuffle,set_identity): Change lint_assume to assume.
* composite.c (composition_gstring_put_cache): Change
lint_assume to assume.
* conf_post.h (assume): New macro.
(lint_assume): Remove.
* dispnew.c (update_frame_1): Change lint_assume to assume.
* ftfont.c (ftfont_shape_by_flt): Change lint_assume
to assume.
* image.c (gif_load): Change lint_assume to assume.
* lisp.h (eassert_and_assume): New macro.
(Qbool_vector_p): Declare.
(CHECK_BOOL_VECTOR,ROUNDUP,BITS_PER_SIZE_T): New macros.
(swap16,swap32,swap64): New inline functions.
* macfont.c (macfont_shape): Change lint_assume to assume.
* ralloc.c: Rename ROUNDUP to PAGE_ROUNDUP throughout.
* xsettings.c (parse_settings): Use new swap16 and
swap32 from lisp.h instead of file-specific macros.
modified:
etc/ChangeLog changelog-20091113204419-o5vbwnq5f7feedwu-1485
etc/NEWS news-20100311060928-aoit31wvzf25yr1z-1
src/ChangeLog changelog-20091113204419-o5vbwnq5f7feedwu-1438
src/alloc.c alloc.c-20091113204419-o5vbwnq5f7feedwu-252
src/casetab.c casetab.c-20091113204419-o5vbwnq5f7feedwu-155
src/composite.c
composite.c-20091113204419-o5vbwnq5f7feedwu-1728
src/conf_post.h conf_post.h-20120730211826-q0qbxxwh2emw52hd-1
src/data.c data.c-20091113204419-o5vbwnq5f7feedwu-251
src/dispnew.c dispnew.c-20091113204419-o5vbwnq5f7feedwu-258
src/ftfont.c ftfont.c-20091113204419-o5vbwnq5f7feedwu-8542
src/image.c image.c-20091113204419-o5vbwnq5f7feedwu-2969
src/intervals.c intervals.c-20091113204419-o5vbwnq5f7feedwu-519
src/lisp.h lisp.h-20091113204419-o5vbwnq5f7feedwu-253
src/macfont.m macfont.m-20130915173740-04lgloz0557bz98l-2
src/ralloc.c ralloc.c-20091113204419-o5vbwnq5f7feedwu-157
src/xsettings.c xsettings.c-20091117210551-bqxn4u9uesl3d17a-4
test/ChangeLog changelog-20091113204419-o5vbwnq5f7feedwu-8588
test/automated/data-tests.el datatests.el-20130911041418-ha1keli7tcoxl2ij-1
=== modified file 'etc/ChangeLog'
--- a/etc/ChangeLog 2013-09-17 07:31:09 +0000
+++ b/etc/ChangeLog 2013-09-22 09:31:55 +0000
@@ -1,4 +1,8 @@
-2013-09-15 Jan Djärv <address@hidden>
+2013-09-22 Daniel Colascione <address@hidden>
+
+ * NEWS: Mention new bool-vector functionality.
+
+aaaa2013-09-15 Jan Djärv <address@hidden>
* NEWS: Mention the macfont backend.
=== modified file 'etc/NEWS'
--- a/etc/NEWS 2013-09-21 08:16:13 +0000
+++ b/etc/NEWS 2013-09-22 09:31:55 +0000
@@ -638,6 +638,16 @@
* Lisp Changes in Emacs 24.4
+** New bool-vector set operation functions:
+*** `bool-vector-exclusive-or'
+*** `bool-vector-union'
+*** `bool-vector-intersection'
+*** `bool-vector-set-difference'
+*** `bool-vector-not'
+*** `bool-vector-subset'
+*** `bool-vector-count-matches'
+*** `bool-vector-count-matches-at'
+
** Comparison functions =, <, >, <=, >= now take many arguments.
** The second argument of `eval' can now be a lexical-environment.
=== modified file 'src/ChangeLog'
--- a/src/ChangeLog 2013-09-22 07:13:14 +0000
+++ b/src/ChangeLog 2013-09-22 09:31:55 +0000
@@ -1,3 +1,45 @@
+2013-09-22 Daniel Colascione <address@hidden>
+
+ * data.c (Qbool_vector_p): New symbol.
+ (bool_vector_spare_mask,popcount_size_t_generic)
+ (popcount_size_t_msc,popcount_size_t_gcc)
+ (popcount_size_t)
+ (bool_vector_binop_driver)
+ (count_trailing_zero_bits,size_t_to_host_endian)
+ (Fbool_vector_exclusive_or)
+ (Fbool_vector_union)
+ (Fbool_vector_intersection,Fbool_vector_set_difference)
+ (Fbool_vector_subsetp,Fbool_vector_not)
+ (Fbool_vector_count_matches)
+ (Fbool_vector_count_matches_at): New functions.
+ (syms_of_data): Intern new symbol, functions.
+ * alloc.c (bool_vector_payload_bytes): New function.
+ (Fmake_bool_vector): Instead of calling Fmake_vector,
+ which performs redundant initialization and argument checking,
+ just call allocate_vector ourselves. Make sure we clear any
+ terminating padding to zero.
+ (vector_nbytes,sweep_vectors): Use bool_vector_payload_bytes
+ instead of open-coding the size calculation.
+ (vroundup_ct): New macro.
+ (vroundup): Assume argument >= 0; invoke vroundup_ct.
+ * casetab.c (shuffle,set_identity): Change lint_assume to assume.
+ * composite.c (composition_gstring_put_cache): Change
+ lint_assume to assume.
+ * conf_post.h (assume): New macro.
+ (lint_assume): Remove.
+ * dispnew.c (update_frame_1): Change lint_assume to assume.
+ * ftfont.c (ftfont_shape_by_flt): Change lint_assume
+ to assume.
+ * image.c (gif_load): Change lint_assume to assume.
+ * lisp.h (eassert_and_assume): New macro.
+ (Qbool_vector_p): Declare.
+ (CHECK_BOOL_VECTOR,ROUNDUP,BITS_PER_SIZE_T): New macros.
+ (swap16,swap32,swap64): New inline functions.
+ * macfont.c (macfont_shape): Change lint_assume to assume.
+ * ralloc.c: Rename ROUNDUP to PAGE_ROUNDUP throughout.
+ * xsettings.c (parse_settings): Use new swap16 and
+ swap32 from lisp.h instead of file-specific macros.
+
2013-09-22 Eli Zaretskii <address@hidden>
* xdisp.c (try_window_id): Don't abort if cursor row could not be
=== modified file 'src/alloc.c'
--- a/src/alloc.c 2013-09-20 15:34:36 +0000
+++ b/src/alloc.c 2013-09-22 09:31:55 +0000
@@ -2001,6 +2001,35 @@
return val;
}
+verify (sizeof (size_t) * CHAR_BIT == BITS_PER_SIZE_T);
+verify ((BITS_PER_SIZE_T & (BITS_PER_SIZE_T - 1)) == 0);
+
+static
+ptrdiff_t
+bool_vector_payload_bytes (ptrdiff_t nr_bits,
+ ptrdiff_t* exact_needed_bytes_out)
+{
+ ptrdiff_t exact_needed_bytes;
+ ptrdiff_t needed_bytes;
+
+ eassert_and_assume (nr_bits >= 0);
+
+ exact_needed_bytes = ROUNDUP ((size_t) nr_bits, CHAR_BIT) / CHAR_BIT;
+ needed_bytes = ROUNDUP ((size_t) nr_bits, BITS_PER_SIZE_T) / CHAR_BIT;
+
+ if (needed_bytes == 0)
+ {
+ /* Always allocate at least one machine word of payload so that
+ bool-vector operations in data.c don't need a special case
+ for empty vectors. */
+ needed_bytes = sizeof (size_t);
+ }
+
+ if (exact_needed_bytes_out != NULL)
+ *exact_needed_bytes_out = exact_needed_bytes;
+
+ return needed_bytes;
+}
DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
doc: /* Return a new bool-vector of length LENGTH, using INIT for each
element.
@@ -2009,37 +2038,43 @@
{
register Lisp_Object val;
struct Lisp_Bool_Vector *p;
- ptrdiff_t length_in_chars;
- EMACS_INT length_in_elts;
- int bits_per_value;
- int extra_bool_elts = ((bool_header_size - header_size + word_size - 1)
- / word_size);
+ ptrdiff_t exact_payload_bytes;
+ ptrdiff_t total_payload_bytes;
+ ptrdiff_t needed_elements;
CHECK_NATNUM (length);
-
- bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
-
- length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
-
- val = Fmake_vector (make_number (length_in_elts + extra_bool_elts), Qnil);
-
- /* No Lisp_Object to trace in there. */
+ if (PTRDIFF_MAX < XFASTINT (length))
+ memory_full (SIZE_MAX);
+
+ total_payload_bytes = bool_vector_payload_bytes
+ (XFASTINT (length), &exact_payload_bytes);
+
+ eassert_and_assume (exact_payload_bytes <= total_payload_bytes);
+ eassert_and_assume (0 <= exact_payload_bytes);
+
+ needed_elements = ROUNDUP ((size_t) ((bool_header_size - header_size)
+ + total_payload_bytes),
+ word_size) / word_size;
+
+ p = (struct Lisp_Bool_Vector* ) allocate_vector (needed_elements);
+ XSETVECTOR (val, p);
XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0);
- p = XBOOL_VECTOR (val);
p->size = XFASTINT (length);
-
- length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR);
- if (length_in_chars)
+ if (exact_payload_bytes)
{
- memset (p->data, ! NILP (init) ? -1 : 0, length_in_chars);
+ memset (p->data, ! NILP (init) ? -1 : 0, exact_payload_bytes);
/* Clear any extraneous bits in the last byte. */
- p->data[length_in_chars - 1]
+ p->data[exact_payload_bytes - 1]
&= (1 << ((XFASTINT (length) - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1)) - 1;
}
+ /* Clear padding at the end. */
+ memset (p->data + exact_payload_bytes,
+ 0,
+ total_payload_bytes - exact_payload_bytes);
+
return val;
}
@@ -2565,24 +2600,22 @@
roundup_size = COMMON_MULTIPLE (word_size, USE_LSB_TAG ? GCALIGNMENT : 1)
};
-/* ROUNDUP_SIZE must be a power of 2. */
-verify ((roundup_size & (roundup_size - 1)) == 0);
-
/* Verify assumptions described above. */
verify ((VECTOR_BLOCK_SIZE % roundup_size) == 0);
verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
-/* Round up X to nearest mult-of-ROUNDUP_SIZE. */
-
-#define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
+/* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
+#define vroundup_ct(x) ROUNDUP((size_t)(x), roundup_size)
+/* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
+#define vroundup(x) (assume((x) >= 0), vroundup_ct(x))
/* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
-#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
+#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
/* Size of the minimal vector allocated from block. */
-#define VBLOCK_BYTES_MIN vroundup (header_size + sizeof (Lisp_Object))
+#define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
/* Size of the largest vector allocated from block. */
@@ -2642,7 +2675,7 @@
struct large_vector *vector;
#if USE_LSB_TAG
/* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
- unsigned char c[vroundup (sizeof (struct large_vector *))];
+ unsigned char c[vroundup_ct (sizeof (struct large_vector *))];
#endif
} next;
struct Lisp_Vector v;
@@ -2783,10 +2816,14 @@
if (size & PSEUDOVECTOR_FLAG)
{
if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR))
- size = (bool_header_size
- + (((struct Lisp_Bool_Vector *) v)->size
- + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR);
+ {
+ struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) v;
+ ptrdiff_t payload_bytes =
+ bool_vector_payload_bytes (bv->size, NULL);
+
+ eassert_and_assume (payload_bytes >= 0);
+ size = bool_header_size + ROUNDUP (payload_bytes, word_size);
+ }
else
size = (header_size
+ ((size & PSEUDOVECTOR_SIZE_MASK)
@@ -2886,17 +2923,11 @@
total_vectors++;
if (vector->header.size & PSEUDOVECTOR_FLAG)
{
- struct Lisp_Bool_Vector *b = (struct Lisp_Bool_Vector *) vector;
-
/* All non-bool pseudovectors are small enough to be allocated
from vector blocks. This code should be redesigned if some
pseudovector type grows beyond VBLOCK_BYTES_MAX. */
eassert (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BOOL_VECTOR));
-
- total_vector_slots
- += (bool_header_size
- + ((b->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR)) / word_size;
+ total_vector_slots += vector_nbytes (vector) / word_size;
}
else
total_vector_slots
=== modified file 'src/casetab.c'
--- a/src/casetab.c 2013-08-26 05:20:59 +0000
+++ b/src/casetab.c 2013-09-22 09:31:55 +0000
@@ -205,7 +205,7 @@
from = to = XINT (c);
to++;
- lint_assume (to <= MAX_CHAR + 1);
+ assume (to <= MAX_CHAR + 1);
for (; from < to; from++)
CHAR_TABLE_SET (table, from, make_number (from));
}
@@ -232,7 +232,7 @@
from = to = XINT (c);
to++;
- lint_assume (to <= MAX_CHAR + 1);
+ assume (to <= MAX_CHAR + 1);
for (; from < to; from++)
{
Lisp_Object tem = Faref (table, elt);
=== modified file 'src/composite.c'
--- a/src/composite.c 2013-09-20 15:34:36 +0000
+++ b/src/composite.c 2013-09-22 09:31:55 +0000
@@ -674,7 +674,7 @@
len = j;
}
- lint_assume (len <= TYPE_MAXIMUM (ptrdiff_t) - 2);
+ assume (len <= TYPE_MAXIMUM (ptrdiff_t) - 2);
copy = Fmake_vector (make_number (len + 2), Qnil);
LGSTRING_SET_HEADER (copy, Fcopy_sequence (header));
for (i = 0; i < len; i++)
=== modified file 'src/conf_post.h'
--- a/src/conf_post.h 2013-09-20 15:34:36 +0000
+++ b/src/conf_post.h 2013-09-22 09:31:55 +0000
@@ -248,16 +248,24 @@
# define FLEXIBLE_ARRAY_MEMBER 1
#endif
+/* assume(cond) tells the compiler (and lint) that a certain condition
+ * will always hold, and that it should optimize (or check) accordingly. */
+#if defined lint
+# define assume(cond) ((cond) ? (void) 0 : abort ())
+#elif (__GNUC__ == 4 && __GNUC_MINOR__ >= 5) || __GNUC__ > 4
+# define assume(cond) ((x) || (__builtin_unreachable(), 0))
+#elif defined __MSC_VER
+# define assume(cond) __assume ((cond))
+#else
+# define assume(cond) (0 && (cond))
+#endif
+
/* Use this to suppress gcc's `...may be used before initialized' warnings. */
#ifdef lint
/* Use CODE only if lint checking is in effect. */
# define IF_LINT(Code) Code
-/* Assume that the expression COND is true. This differs in intent
- from 'assert', as it is a message from the programmer to the compiler. */
-# define lint_assume(cond) ((cond) ? (void) 0 : abort ())
#else
# define IF_LINT(Code) /* empty */
-# define lint_assume(cond) ((void) (0 && (cond)))
#endif
/* conf_post.h ends here */
=== modified file 'src/data.c'
--- a/src/data.c 2013-09-11 07:20:20 +0000
+++ b/src/data.c 2013-09-22 09:31:55 +0000
@@ -54,6 +54,7 @@
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;
@@ -2956,6 +2957,457 @@
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. 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. */
+
+static inline
+size_t
+bool_vector_spare_mask (ptrdiff_t nr_bits)
+{
+ eassert_and_assume (nr_bits > 0);
+ return (((size_t) 1) << (nr_bits % BITS_PER_SIZE_T)) - 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
+#else
+# define NEED_GENERIC_POPCOUNT
+#endif
+
+#ifdef USE_MSC_POPCOUNT
+#define NEED_GENERIC_POPCOUNT
+#endif
+
+#ifdef NEED_GENERIC_POPCOUNT
+static inline
+unsigned int
+popcount_size_t_generic (size_t val)
+{
+ unsigned short j;
+ unsigned int count = 0;
+
+ for (j = 0; j < BITS_PER_SIZE_T; ++j)
+ count += !!((((size_t) 1) << j) & val);
+
+ return count;
+}
+#endif
+
+#ifdef USE_MSC_POPCOUNT
+static inline
+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;
+ }
+
+ 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 inline
+unsigned int
+popcount_size_t_gcc (size_t val)
+{
+# if BITS_PER_SIZE_T == 64
+ return __builtin_popcountll (val);
+# else
+ return __builtin_popcount (val);
+# endif
+}
+#endif /* USE_GCC_POPCOUNT */
+
+static inline
+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
+}
+
+enum bool_vector_op { bool_vector_exclusive_or,
+ bool_vector_union,
+ bool_vector_intersection,
+ bool_vector_set_difference,
+ bool_vector_subsetp };
+
+static inline
+Lisp_Object
+bool_vector_binop_driver (Lisp_Object op1,
+ Lisp_Object op2,
+ 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;
+ ptrdiff_t nr_words;
+
+ CHECK_BOOL_VECTOR (op1);
+ CHECK_BOOL_VECTOR (op2);
+
+ nr_bits = min (XBOOL_VECTOR (op1)->size,
+ XBOOL_VECTOR (op2)->size);
+
+ if (NILP (dest))
+ {
+ dest = Fmake_bool_vector (make_number (nr_bits), Qnil);
+ changed = 1;
+ }
+ else
+ {
+ CHECK_BOOL_VECTOR (dest);
+ nr_bits = min (nr_bits, XBOOL_VECTOR (dest)->size);
+ }
+
+ eassert_and_assume (nr_bits >= 0);
+ nr_words = ROUNDUP(nr_bits, BITS_PER_SIZE_T) / BITS_PER_SIZE_T;
+
+ adata = (size_t*) XBOOL_VECTOR (dest)->data;
+ bdata = (size_t*) XBOOL_VECTOR (op1)->data;
+ cdata = (size_t*) XBOOL_VECTOR (op2)->data;
+ i = 0;
+ do
+ {
+ 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 ();
+
+ changed |= adata[i] ^ mword;
+
+ if (op != bool_vector_subsetp)
+ adata[i] = mword;
+
+ i += 1;
+ }
+ while (i < nr_words);
+ return changed ? dest : Qnil;
+}
+
+/* Compute the number of trailing zero bits in val. If val is zero,
+ return the number of bits in val. */
+static inline
+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;
+
+ return count;
+ }
+#endif
+}
+
+static inline
+size_t
+size_t_to_host_endian (size_t val)
+{
+#ifdef WORDS_BIGENDIAN
+# if BITS_PER_SIZE_T == 64
+ return swap64 (val);
+# else
+ return swap32 (val);
+# endif
+#else
+ return val;
+#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. */
+ )
+ (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. */)
+ (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. */)
+ (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. */)
+ (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: )
+ (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);
+}
+
+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.
+Return the destination vector. */)
+ (Lisp_Object a, Lisp_Object b)
+{
+ EMACS_INT nr_bits;
+ size_t *bdata, *adata;
+ ptrdiff_t i;
+ size_t mword;
+
+ CHECK_BOOL_VECTOR (a);
+ nr_bits = XBOOL_VECTOR (a)->size;
+
+ if (NILP (b))
+ b = Fmake_bool_vector (make_number (nr_bits), Qnil);
+ else
+ {
+ CHECK_BOOL_VECTOR (b);
+ nr_bits = min (nr_bits, XBOOL_VECTOR (b)->size);
+ }
+
+ bdata = (size_t*) XBOOL_VECTOR (b)->data;
+ adata = (size_t*) XBOOL_VECTOR (a)->data;
+ i = 0;
+
+ eassert_and_assume (nr_bits >= 0);
+
+ while (i < nr_bits / BITS_PER_SIZE_T)
+ {
+ bdata[i] = ~adata[i];
+ i += 1;
+ }
+
+ if (nr_bits % BITS_PER_SIZE_T)
+ {
+ mword = size_t_to_host_endian (adata[i]);
+ mword = ~mword;
+ mword &= bool_vector_spare_mask (nr_bits);
+ bdata[i] = size_t_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)
+{
+ ptrdiff_t count;
+ EMACS_INT nr_bits;
+ size_t *adata;
+ size_t match;
+ ptrdiff_t i;
+
+ CHECK_BOOL_VECTOR (a);
+
+ nr_bits = XBOOL_VECTOR (a)->size;
+ count = 0;
+ match = NILP (b) ? (size_t) -1 : 0;
+ adata = (size_t*) XBOOL_VECTOR (a)->data;
+
+ eassert_and_assume (nr_bits >= 0);
+
+ 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));
+ }
+
+ 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.*/)
+ (Lisp_Object a, Lisp_Object b, Lisp_Object i)
+{
+ ptrdiff_t count;
+ EMACS_INT nr_bits;
+ ptrdiff_t offset;
+ size_t *adata;
+ size_t twiddle;
+ size_t mword; /* Machine word. */
+ ptrdiff_t pos;
+ ptrdiff_t nr_words;
+
+ CHECK_BOOL_VECTOR (a);
+ CHECK_NATNUM (i);
+
+ nr_bits = XBOOL_VECTOR (a)->size;
+ 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;
+ 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;
+
+ /* 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 ^= twiddle;
+ mword >>= offset;
+ count = count_trailing_zero_bits (mword);
+ count = min (count, BITS_PER_SIZE_T - offset);
+ pos += 1;
+ if (count + offset < BITS_PER_SIZE_T)
+ 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. */
+ while (pos < nr_words && adata[pos] == twiddle)
+ {
+ count += BITS_PER_SIZE_T;
+ ++pos;
+ }
+
+ 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 ^= twiddle;
+ count += count_trailing_zero_bits (mword);
+ }
+ else if (nr_bits % BITS_PER_SIZE_T != 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;
+ }
+
+ return make_number (count);
+}
void
@@ -3005,6 +3457,7 @@
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");
@@ -3222,6 +3675,15 @@
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_matches);
+ defsubr (&Sbool_vector_count_matches_at);
+
set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function);
DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
=== modified file 'src/dispnew.c'
--- a/src/dispnew.c 2013-09-20 15:34:36 +0000
+++ b/src/dispnew.c 2013-09-22 09:31:55 +0000
@@ -4451,7 +4451,7 @@
}
}
- lint_assume (0 <= FRAME_LINES (f));
+ assume (0 <= FRAME_LINES (f));
pause_p = 0 < i && i < FRAME_LINES (f) - 1;
/* Now just clean up termcap drivers and set cursor, etc. */
=== modified file 'src/ftfont.c'
--- a/src/ftfont.c 2013-08-03 03:29:03 +0000
+++ b/src/ftfont.c 2013-09-22 09:31:55 +0000
@@ -2425,7 +2425,7 @@
}
len = i;
- lint_assume (len <= STRING_BYTES_BOUND);
+ assume (len <= STRING_BYTES_BOUND);
if (with_variation_selector)
{
=== modified file 'src/image.c'
--- a/src/image.c 2013-09-17 06:33:24 +0000
+++ b/src/image.c 2013-09-22 09:31:55 +0000
@@ -7523,7 +7523,7 @@
{
while (subimg_height <= row)
{
- lint_assume (pass < 3);
+ assume (pass < 3);
row = interlace_start[++pass];
}
=== modified file 'src/intervals.c'
--- a/src/intervals.c 2013-09-20 15:34:36 +0000
+++ b/src/intervals.c 2013-09-22 09:31:55 +0000
@@ -1405,7 +1405,7 @@
start, length);
else
{
- lint_assume (- TYPE_MAXIMUM (ptrdiff_t) <= length);
+ assume (- TYPE_MAXIMUM (ptrdiff_t) <= length);
adjust_intervals_for_deletion (buffer, start, -length);
}
}
=== modified file 'src/lisp.h'
--- a/src/lisp.h 2013-09-20 15:34:36 +0000
+++ b/src/lisp.h 2013-09-22 09:31:55 +0000
@@ -131,6 +131,13 @@
? (void) 0 \
: die (# cond, __FILE__, __LINE__))
#endif /* ENABLE_CHECKING */
+
+/* When checking is enabled, identical to eassert. When checking is
+ * disabled, instruct the compiler (when the compiler has such
+ * capability) to assume that cond is true and optimize
+ * accordingly. */
+#define eassert_and_assume(cond) (eassert (cond), assume (cond))
+
/* Use the configure flag --enable-check-lisp-object-type to make
Lisp_Object use a struct type instead of the default int. The flag
@@ -730,6 +737,7 @@
extern Lisp_Object Qarrayp, Qbufferp, Qbuffer_or_string_p, Qchar_table_p;
extern Lisp_Object Qconsp, Qfloatp, Qintegerp, Qlambda, Qlistp, Qmarkerp, Qnil;
extern Lisp_Object Qnumberp, Qstringp, Qsymbolp, Qvectorp;
+extern Lisp_Object Qbool_vector_p;
extern Lisp_Object Qvector_or_char_table_p, Qwholenump;
extern Lisp_Object Qwindow;
extern Lisp_Object Ffboundp (Lisp_Object);
@@ -2359,6 +2367,11 @@
CHECK_TYPE (VECTORP (x), Qvectorp, x);
}
INLINE void
+CHECK_BOOL_VECTOR (Lisp_Object x)
+{
+ CHECK_TYPE (BOOL_VECTOR_P (x), Qbool_vector_p, x);
+}
+INLINE void
CHECK_VECTOR_OR_STRING (Lisp_Object x)
{
CHECK_TYPE (VECTORP (x) || STRINGP (x), Qarrayp, x);
@@ -4347,6 +4360,43 @@
return 0;
}
+INLINE
+uint16_t
+swap16 (uint16_t val)
+{
+ return (val << 8) | (val & 0xFF);
+}
+
+INLINE
+uint32_t
+swap32 (uint32_t val)
+{
+ uint32_t low = swap16 (val & 0xFFFF);
+ uint32_t high = swap16 (val >> 16);
+ return (low << 16) | high;
+}
+
+#ifdef UINT64_MAX
+INLINE
+uint64_t
+swap64 (uint64_t val)
+{
+ uint64_t low = swap32 (val & 0xFFFFFFFF);
+ uint64_t high = swap32 (val >> 32);
+ return (low << 32) | high;
+}
+#endif
+
+#if ((SIZE_MAX >> 31) >> 1) & 1
+# define BITS_PER_SIZE_T 64
+#else
+# define BITS_PER_SIZE_T 32
+#endif
+
+/* Round x to the next multiple of y. Does not overflow. Evaluates
+ arguments repeatedly. */
+#define ROUNDUP(x,y) ((y)*((x)/(y) + ((x)%(y)!=0)))
+
INLINE_HEADER_END
#endif /* EMACS_LISP_H */
=== modified file 'src/macfont.m'
--- a/src/macfont.m 2013-09-15 19:36:20 +0000
+++ b/src/macfont.m 2013-09-22 09:31:55 +0000
@@ -2817,7 +2817,7 @@
}
len = i;
- lint_assume (len <= TYPE_MAXIMUM (EMACS_INT) - 2);
+ assume (len <= TYPE_MAXIMUM (EMACS_INT) - 2);
if (INT_MAX / 2 < len)
memory_full (SIZE_MAX);
=== modified file 'src/ralloc.c'
--- a/src/ralloc.c 2013-07-05 16:58:01 +0000
+++ b/src/ralloc.c 2013-09-22 09:31:55 +0000
@@ -85,7 +85,7 @@
/* Macros for rounding. Note that rounding to any value is possible
by changing the definition of PAGE. */
#define PAGE (getpagesize ())
-#define ROUNDUP(size) (((size_t) (size) + page_size - 1) \
+#define PAGE_ROUNDUP(size) (((size_t) (size) + page_size - 1) \
& ~((size_t) (page_size - 1)))
#define MEM_ALIGN sizeof (double)
@@ -281,7 +281,7 @@
Get some extra, so we can come here less often. */
get = size + extra_bytes - already_available;
- get = (char *) ROUNDUP ((char *) last_heap->end + get)
+ get = (char *) PAGE_ROUNDUP ((char *) last_heap->end + get)
- (char *) last_heap->end;
if (real_morecore (get) != last_heap->end)
@@ -344,7 +344,7 @@
else
{
excess = ((char *) last_heap->end
- - (char *) ROUNDUP ((char *) last_heap->end - excess));
+ - (char *) PAGE_ROUNDUP ((char *) last_heap->end - excess));
/* If the system doesn't want that much memory back, leave
the end of the last heap unchanged to reflect that. This
can occur if break_value is still within the original
@@ -768,9 +768,9 @@
not always find a space which is contiguous to the previous. */
void *new_bloc_start;
heap_ptr h = first_heap;
- size_t get = ROUNDUP (size);
+ size_t get = PAGE_ROUNDUP (size);
- address = (void *) ROUNDUP (virtual_break_value);
+ address = (void *) PAGE_ROUNDUP (virtual_break_value);
/* Search the list upward for a heap which is large enough. */
while ((char *) h->end < (char *) MEM_ROUNDUP ((char *) address + get))
@@ -778,7 +778,7 @@
h = h->next;
if (h == NIL_HEAP)
break;
- address = (void *) ROUNDUP (h->start);
+ address = (void *) PAGE_ROUNDUP (h->start);
}
/* If not found, obtain more space. */
@@ -790,9 +790,9 @@
return 0;
if (first_heap == last_heap)
- address = (void *) ROUNDUP (virtual_break_value);
+ address = (void *) PAGE_ROUNDUP (virtual_break_value);
else
- address = (void *) ROUNDUP (last_heap->start);
+ address = (void *) PAGE_ROUNDUP (last_heap->start);
h = last_heap;
}
@@ -1054,7 +1054,7 @@
for (h = first_heap; h; h = h->next)
{
assert (h->prev == ph);
- assert ((void *) ROUNDUP (h->end) == h->end);
+ assert ((void *) PAGE_ROUNDUP (h->end) == h->end);
#if 0 /* ??? The code in ralloc.c does not really try to ensure
the heap start has any sort of alignment.
Perhaps it should. */
@@ -1190,7 +1190,7 @@
if (break_value == NULL)
emacs_abort ();
- extra_bytes = ROUNDUP (50000);
+ extra_bytes = PAGE_ROUNDUP (50000);
#endif
#ifdef DOUG_LEA_MALLOC
@@ -1212,7 +1212,7 @@
#endif
#ifndef SYSTEM_MALLOC
- first_heap->end = (void *) ROUNDUP (first_heap->start);
+ first_heap->end = (void *) PAGE_ROUNDUP (first_heap->start);
/* The extra call to real_morecore guarantees that the end of the
address space is a multiple of page_size, even if page_size is
=== modified file 'src/xsettings.c'
--- a/src/xsettings.c 2013-09-17 07:06:42 +0000
+++ b/src/xsettings.c 2013-09-22 09:31:55 +0000
@@ -336,9 +336,6 @@
XUngrabServer (dpy);
}
-#define SWAP32(nr) (((nr) << 24) | (((nr) << 8) & 0xff0000) \
- | (((nr) >> 8) & 0xff00) | ((nr) >> 24))
-#define SWAP16(nr) (((nr) << 8) | ((nr) >> 8))
#define PAD(nr) (((nr) + 3) & ~3)
/* Parse xsettings and extract those that deal with Xft.
@@ -408,7 +405,7 @@
if (bytes < 12) return BadLength;
memcpy (&n_settings, prop+8, 4);
- if (my_bo != that_bo) n_settings = SWAP32 (n_settings);
+ if (my_bo != that_bo) n_settings = swap32 (n_settings);
bytes_parsed = 12;
memset (settings, 0, sizeof (*settings));
@@ -430,7 +427,7 @@
memcpy (&nlen, prop+bytes_parsed, 2);
bytes_parsed += 2;
- if (my_bo != that_bo) nlen = SWAP16 (nlen);
+ if (my_bo != that_bo) nlen = swap16 (nlen);
if (bytes_parsed+nlen > bytes) return BadLength;
to_cpy = nlen > 127 ? 127 : nlen;
memcpy (name, prop+bytes_parsed, to_cpy);
@@ -457,7 +454,7 @@
if (want_this)
{
memcpy (&ival, prop+bytes_parsed, 4);
- if (my_bo != that_bo) ival = SWAP32 (ival);
+ if (my_bo != that_bo) ival = swap32 (ival);
}
bytes_parsed += 4;
break;
@@ -466,7 +463,7 @@
if (bytes_parsed+4 > bytes) return BadLength;
memcpy (&vlen, prop+bytes_parsed, 4);
bytes_parsed += 4;
- if (my_bo != that_bo) vlen = SWAP32 (vlen);
+ if (my_bo != that_bo) vlen = swap32 (vlen);
if (want_this)
{
to_cpy = vlen > 127 ? 127 : vlen;
=== modified file 'test/ChangeLog'
--- a/test/ChangeLog 2013-09-20 19:59:42 +0000
+++ b/test/ChangeLog 2013-09-22 09:31:55 +0000
@@ -1,3 +1,21 @@
+2013-09-22 Daniel Colascione <address@hidden>
+
+ * automated/data-test.el:
+ (bool-vector-count-matches-all-0-nil)
+ (bool-vector-count-matches-all-0-t)
+ (bool-vector-count-matches-1-il,bool-vector-count-matches-1-t)
+ (bool-vector-count-matches-at,bool-vector-intersection-op)
+ (bool-vector-union-op,bool-vector-xor-op)
+ (bool-vector-set-difference-op)
+ (bool-vector-change-detection,bool-vector-not): New tests.
+ (mock-bool-vector-count-matches-at)
+ (test-bool-vector-bv-from-hex-string)
+ (test-bool-vector-to-hex-string)
+ (test-bool-vector-count-matches-at-tc)
+ (test-bool-vector-apply-mock-op)
+ (test-bool-vector-binop): New helper functions.
+ (bool-vector-test-vectors): New testcase data.
+
2013-09-20 Ryan <address@hidden> (tiny change)
* automated/advice-tests.el (advice-test-called-interactively-p-around)
=== modified file 'test/automated/data-tests.el'
--- a/test/automated/data-tests.el 2013-09-11 05:03:23 +0000
+++ b/test/automated/data-tests.el 2013-09-22 09:31:55 +0000
@@ -21,6 +21,9 @@
;;; Code:
+(require 'cl-lib)
+(eval-when-compile (require 'cl))
+
(ert-deftest data-tests-= ()
(should-error (=))
(should (= 1))
@@ -71,5 +74,186 @@
;; Short circuits before getting to bad arg
(should-not (>= 8 9 'foo)))
-;;; data-tests.el ends here
-
+;; Bool vector tests. Compactly represent bool vectors as hex
+;; strings.
+
+(ert-deftest bool-vector-count-matches-all-0-nil ()
+ (cl-loop for sz in '(0 45 1 64 9 344)
+ do (let* ((bv (make-bool-vector sz nil)))
+ (should
+ (eql
+ (bool-vector-count-matches bv nil)
+ sz)))))
+
+(ert-deftest bool-vector-count-matches-all-0-t ()
+ (cl-loop for sz in '(0 45 1 64 9 344)
+ do (let* ((bv (make-bool-vector sz nil)))
+ (should
+ (eql
+ (bool-vector-count-matches bv t)
+ 0)))))
+
+(ert-deftest bool-vector-count-matches-1-nil ()
+ (let* ((bv (make-bool-vector 45 nil)))
+ (aset bv 40 t)
+ (aset bv 0 t)
+ (should
+ (eql
+ (bool-vector-count-matches bv t)
+ 2)))
+ )
+
+(ert-deftest bool-vector-count-matches-1-t ()
+ (let* ((bv (make-bool-vector 45 nil)))
+ (aset bv 40 t)
+ (aset bv 0 t)
+ (should
+ (eql
+ (bool-vector-count-matches bv nil)
+ 43))))
+
+(defun mock-bool-vector-count-matches-at (a b i)
+ (loop for i from i below (length a)
+ while (eq (aref a i) b)
+ sum 1))
+
+(defun test-bool-vector-bv-from-hex-string (desc)
+ (let (bv nchars nibbles)
+ (dolist (c (string-to-list desc))
+ (push (string-to-number
+ (char-to-string c)
+ 16)
+ nibbles))
+ (setf bv (make-bool-vector (* 4 (length nibbles)) nil))
+ (let ((i 0))
+ (dolist (n (nreverse nibbles))
+ (dotimes (_ 4)
+ (aset bv i (> (logand 1 n) 0))
+ (incf i)
+ (setf n (lsh n -1)))))
+ bv))
+
+(defun test-bool-vector-to-hex-string (bv)
+ (let (nibbles (v (cl-coerce bv 'list)))
+ (while v
+ (push (logior
+ (lsh (if (nth 0 v) 1 0) 0)
+ (lsh (if (nth 1 v) 1 0) 1)
+ (lsh (if (nth 2 v) 1 0) 2)
+ (lsh (if (nth 3 v) 1 0) 3))
+ nibbles)
+ (setf v (nthcdr 4 v)))
+ (mapconcat (lambda (n) (format "%X" n))
+ (nreverse nibbles)
+ "")))
+
+(defun test-bool-vector-count-matches-at-tc (desc)
+ "Run a test case for bool-vector-count-matches-at.
+DESC is a string describing the test. It is a sequence of
+hexadecimal digits describing the bool vector. We exhaustively
+test all counts at all possible positions in the vector by
+comparing the subr with a much slower lisp implementation."
+ (let ((bv (test-bool-vector-bv-from-hex-string desc)))
+ (loop
+ for lf in '(nil t)
+ do (loop
+ for pos from 0 upto (length bv)
+ for cnt = (mock-bool-vector-count-matches-at bv lf pos)
+ for rcnt = (bool-vector-count-matches-at bv lf pos)
+ unless (eql cnt rcnt)
+ do (error "FAILED testcase %S %3S %3S %3S"
+ pos lf cnt rcnt)))))
+
+(defconst bool-vector-test-vectors
+'(""
+ "0"
+ "F"
+ "0F"
+ "F0"
+ "00000000000000000000000000000FFFFF0000000"
+ "44a50234053fba3340000023444a50234053fba33400000234"
+ "12341234123456123412346001234123412345612341234600"
+ "44a50234053fba33400000234"
+ "1234123412345612341234600"
+ "44a50234053fba33400000234"
+ "1234123412345612341234600"
+ "44a502340"
+ "123412341"
+ "0000000000000000000000000"
+ "FFFFFFFFFFFFFFFF1"))
+
+(ert-deftest bool-vector-count-matches-at ()
+ (mapc #'test-bool-vector-count-matches-at-tc
+ bool-vector-test-vectors))
+
+(defun test-bool-vector-apply-mock-op (mock a b c)
+ "Compute (slowly) the correct result of a bool-vector set operation."
+ (let (changed nv)
+ (assert (eql (length b) (length c)))
+ (if a (setf nv a)
+ (setf a (make-bool-vector (length b) nil))
+ (setf changed t))
+
+ (loop for i below (length b)
+ for mockr = (funcall mock
+ (if (aref b i) 1 0)
+ (if (aref c i) 1 0))
+ for r = (not (= 0 mockr))
+ do (progn
+ (unless (eq (aref a i) r)
+ (setf changed t))
+ (setf (aref a i) r)))
+ (if changed a)))
+
+(defun test-bool-vector-binop (mock real)
+ "Test a binary set operation."
+ (loop for s1 in bool-vector-test-vectors
+ for bv1 = (test-bool-vector-bv-from-hex-string s1)
+ for vecs2 = (cl-remove-if-not
+ (lambda (x) (eql (length x) (length s1)))
+ bool-vector-test-vectors)
+ do (loop for s2 in vecs2
+ for bv2 = (test-bool-vector-bv-from-hex-string s2)
+ for mock-result = (test-bool-vector-apply-mock-op
+ mock nil bv1 bv2)
+ for real-result = (funcall real bv1 bv2)
+ do (progn
+ (should (equal mock-result real-result))))))
+
+(ert-deftest bool-vector-intersection-op ()
+ (test-bool-vector-binop
+ #'logand
+ #'bool-vector-intersection))
+
+(ert-deftest bool-vector-union-op ()
+ (test-bool-vector-binop
+ #'logior
+ #'bool-vector-union))
+
+(ert-deftest bool-vector-xor-op ()
+ (test-bool-vector-binop
+ #'logxor
+ #'bool-vector-exclusive-or))
+
+(ert-deftest bool-vector-set-difference-op ()
+ (test-bool-vector-binop
+ (lambda (a b) (logand a (lognot b)))
+ #'bool-vector-set-difference))
+
+(ert-deftest bool-vector-change-detection ()
+ (let* ((vc1 (test-bool-vector-bv-from-hex-string "abcdef"))
+ (vc2 (test-bool-vector-bv-from-hex-string "012345"))
+ (vc3 (make-bool-vector (length vc1) nil))
+ (c1 (bool-vector-union vc1 vc2 vc3))
+ (c2 (bool-vector-union vc1 vc2 vc3)))
+ (should (equal c1 (test-bool-vector-apply-mock-op
+ #'logior
+ nil
+ vc1 vc2)))
+ (should (not c2))))
+
+(ert-deftest bool-vector-not ()
+ (let* ((v1 (test-bool-vector-bv-from-hex-string "FFFF3"))
+ (v2 (test-bool-vector-bv-from-hex-string "0000C"))
+ (v3 (bool-vector-not v1)))
+ (should (equal v2 v3))))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] trunk r114426: Add set operations for bool-vector.,
Daniel Colascione <=