New function: buf-count-ones.

* buf.c (buf_count_ones): New function.
(buf_init): Register buf-count-ones intrinsic.

* buf.h (buf_count_ones): Declared.

* tests/012/buf.h: New tests.

* txr.1: Documented.

4 files changed, 201 insertions, 0 deletions

diff --git a/buf.c b/buf.c
index 0bb21a5c..c8d51cdc 100644
--- a/buf.c
+++ b/buf.c
@@ -1761,6 +1761,54 @@ val buf_zero_p(val buf)
   return t;
 }
 
+val buf_count_ones(val buf)
+{
+  val self = lit("buf-count-ones");
+  struct buf *b = buf_handle(buf, self);
+  ucnum l = c_unum(b->len, self), i;
+  ucnum *ucdata = coerce(ucnum *, b->data);
+  ucnum total[2] = { 0, 0 };
+
+  for (i = 0; i < l / sizeof (ucnum); i++) {
+    ucnum d = ucdata[i];
+#if SIZEOF_PTR == 8
+    d = ((d & 0xAAAAAAAAAAAAAAAA) >>  1) + (d & 0x5555555555555555);
+    d = ((d & 0xCCCCCCCCCCCCCCCC) >>  2) + (d & 0x3333333333333333);
+    d = ((d & 0xF0F0F0F0F0F0F0F0) >>  4) + (d & 0x0F0F0F0F0F0F0F0F);
+    d = ((d & 0xFF00FF00FF00FF00) >>  8) + (d & 0x00FF00FF00FF00FF);
+    d = ((d & 0xFFFF0000FFFF0000) >> 16) + (d & 0x0000FFFF0000FFFF);
+    d = ((d & 0xFFFFFFFF00000000) >> 32) + (d & 0x00000000FFFFFFFF);
+#elif SIZEOF_PTR == 4
+    d = ((d & 0xAAAAAAAA) >>  1) + (d & 0x55555555);
+    d = ((d & 0xCCCCCCCC) >>  2) + (d & 0x33333333);
+    d = ((d & 0xF0F0F0F0) >>  4) + (d & 0x0F0F0F0F);
+    d = ((d & 0xFF00FF00) >>  8) + (d & 0x00FF00FF);
+    d = ((d & 0xFFFF0000) >> 16) + (d & 0x0000FFFF);
+#else
+#error portme
+#endif
+    total[1] += d;
+    if (total[1] < d)
+      total[0]++;
+  }
+
+  for (i = l / sizeof (ucnum) * sizeof (ucnum); i < l; i++) {
+    unsigned d = b->data[i];
+
+    d = ((d & 0xAA) >> 1) + (d & 0x55);
+    d = ((d & 0xCC) >> 2) + (d & 0x33);
+    d = ((d & 0xF0) >> 4) + (d & 0x0F);
+
+    total[1] += d;
+    if (total[1] < d)
+      total[0]++;
+  }
+
+  return total[0]
+         ? plus(ash(unum(total[0]), num_fast(8 * SIZEOF_PTR)), unum(total[1]))
+         : unum(total[1]);
+}
+
 void buf_init(void)
 {
   reg_fun(intern(lit("make-buf"), user_package), func_n3o(make_buf, 1));
@@ -1865,6 +1913,7 @@ void buf_init(void)
   reg_fun(intern(lit("buf-bitset"), user_package), func_n1(buf_bitset));
   reg_fun(intern(lit("buf-bit"), user_package), func_n2(buf_bit));
   reg_fun(intern(lit("buf-zero-p"), user_package), func_n1(buf_zero_p));
+  reg_fun(intern(lit("buf-count-ones"), user_package), func_n1(buf_count_ones));
 
   fill_stream_ops(&buf_strm_ops);
 }
diff --git a/buf.h b/buf.h
index 2a599339..3782ef25 100644
--- a/buf.h
+++ b/buf.h
@@ -135,5 +135,6 @@ val buf_trunc(val buf, val bits);
 val buf_bitset(val buf);
 val buf_bit(val buf, val bit);
 val buf_zero_p(val buf);
+val buf_count_ones(val buf);
 
 void buf_init(void);
diff --git a/tests/012/buf.tl b/tests/012/buf.tl
index 173522ce..923a945e 100644
--- a/tests/012/buf.tl
+++ b/tests/012/buf.tl
@@ -368,3 +368,143 @@
   (buf-zero-p #b'00000000000000000001') nil
   (buf-zero-p #b'00000000000000000000') t
   (buf-zero-p #b'000000000000000001') nil)
+
+(mtest
+  (buf-count-ones #b'') 0
+  (buf-count-ones #b'00') 0
+  (buf-count-ones #b'80') 1
+  (buf-count-ones #b'40') 1
+  (buf-count-ones #b'20') 1
+  (buf-count-ones #b'10') 1
+  (buf-count-ones #b'08') 1
+  (buf-count-ones #b'04') 1
+  (buf-count-ones #b'02') 1
+  (buf-count-ones #b'01') 1
+  (buf-count-ones #b'c0') 2
+  (buf-count-ones #b'60') 2
+  (buf-count-ones #b'30') 2
+  (buf-count-ones #b'18') 2
+  (buf-count-ones #b'0c') 2
+  (buf-count-ones #b'06') 2
+  (buf-count-ones #b'03') 2
+  (buf-count-ones #b'aa') 4
+  (buf-count-ones #b'55') 4
+  (buf-count-ones #b'ff') 8
+  (buf-count-ones #b'0000') 0
+  (buf-count-ones #b'0080') 1
+  (buf-count-ones #b'0040') 1
+  (buf-count-ones #b'0020') 1
+  (buf-count-ones #b'0010') 1
+  (buf-count-ones #b'0008') 1
+  (buf-count-ones #b'0004') 1
+  (buf-count-ones #b'0002') 1
+  (buf-count-ones #b'0001') 1
+  (buf-count-ones #b'00c0') 2
+  (buf-count-ones #b'0060') 2
+  (buf-count-ones #b'0030') 2
+  (buf-count-ones #b'0018') 2
+  (buf-count-ones #b'000c') 2
+  (buf-count-ones #b'0006') 2
+  (buf-count-ones #b'0003') 2
+  (buf-count-ones #b'00aa') 4
+  (buf-count-ones #b'0055') 4
+  (buf-count-ones #b'00ff') 8
+  (buf-count-ones #b'0000') 0
+  (buf-count-ones #b'ffff0080') 17
+  (buf-count-ones #b'ffff0040') 17
+  (buf-count-ones #b'ffff0020') 17
+  (buf-count-ones #b'ffff0010') 17
+  (buf-count-ones #b'ffff0008') 17
+  (buf-count-ones #b'ffff0004') 17
+  (buf-count-ones #b'ffff0002') 17
+  (buf-count-ones #b'ffff0001') 17
+  (buf-count-ones #b'ffff00c0') 18
+  (buf-count-ones #b'ffff0060') 18
+  (buf-count-ones #b'ffff0030') 18
+  (buf-count-ones #b'ffff0018') 18
+  (buf-count-ones #b'ffff000c') 18
+  (buf-count-ones #b'ffff0006') 18
+  (buf-count-ones #b'ffff0003') 18
+  (buf-count-ones #b'ffff00aa') 20
+  (buf-count-ones #b'ffff0055') 20
+  (buf-count-ones #b'ffff00ff') 24
+  (buf-count-ones #b'aaffff0080') 21
+  (buf-count-ones #b'aaffff0040') 21
+  (buf-count-ones #b'aaffff0020') 21
+  (buf-count-ones #b'aaffff0010') 21
+  (buf-count-ones #b'aaffff0008') 21
+  (buf-count-ones #b'aaffff0004') 21
+  (buf-count-ones #b'aaffff0002') 21
+  (buf-count-ones #b'aaffff0001') 21
+  (buf-count-ones #b'aaffff00c0') 22
+  (buf-count-ones #b'aaffff0060') 22
+  (buf-count-ones #b'aaffff0030') 22
+  (buf-count-ones #b'aaffff0018') 22
+  (buf-count-ones #b'aaffff000c') 22
+  (buf-count-ones #b'aaffff0006') 22
+  (buf-count-ones #b'aaffff0003') 22
+  (buf-count-ones #b'aaffff00aa') 24
+  (buf-count-ones #b'aaffff0055') 24
+  (buf-count-ones #b'aaffff00ff') 28
+  (buf-count-ones #b'5555aaaaffff0080') 33
+  (buf-count-ones #b'5555aaaaffff0040') 33
+  (buf-count-ones #b'5555aaaaffff0020') 33
+  (buf-count-ones #b'5555aaaaffff0010') 33
+  (buf-count-ones #b'5555aaaaffff0008') 33
+  (buf-count-ones #b'5555aaaaffff0004') 33
+  (buf-count-ones #b'5555aaaaffff0002') 33
+  (buf-count-ones #b'5555aaaaffff0001') 33
+  (buf-count-ones #b'5555aaaaffff00c0') 34
+  (buf-count-ones #b'5555aaaaffff0060') 34
+  (buf-count-ones #b'5555aaaaffff0030') 34
+  (buf-count-ones #b'5555aaaaffff0018') 34
+  (buf-count-ones #b'5555aaaaffff000c') 34
+  (buf-count-ones #b'5555aaaaffff0006') 34
+  (buf-count-ones #b'5555aaaaffff0003') 34
+  (buf-count-ones #b'5555aaaaffff00aa') 36
+  (buf-count-ones #b'5555aaaaffff0055') 36
+  (buf-count-ones #b'5555aaaaffff00ff') 40
+  (buf-count-ones #b'fe5555aaaaffff0080') 40
+  (buf-count-ones #b'fe5555aaaaffff0040') 40
+  (buf-count-ones #b'fe5555aaaaffff0020') 40
+  (buf-count-ones #b'fe5555aaaaffff0010') 40
+  (buf-count-ones #b'fe5555aaaaffff0008') 40
+  (buf-count-ones #b'fe5555aaaaffff0004') 40
+  (buf-count-ones #b'fe5555aaaaffff0002') 40
+  (buf-count-ones #b'fe5555aaaaffff0001') 40
+  (buf-count-ones #b'fe5555aaaaffff00c0') 41
+  (buf-count-ones #b'fe5555aaaaffff0060') 41
+  (buf-count-ones #b'fe5555aaaaffff0030') 41
+  (buf-count-ones #b'fe5555aaaaffff0018') 41
+  (buf-count-ones #b'fe5555aaaaffff000c') 41
+  (buf-count-ones #b'fe5555aaaaffff0006') 41
+  (buf-count-ones #b'fe5555aaaaffff0003') 41
+  (buf-count-ones #b'fe5555aaaaffff00aa') 43
+  (buf-count-ones #b'fe5555aaaaffff0055') 43
+  (buf-count-ones #b'fe5555aaaaffff00ff') 47)
+
+(each-prod ((i 0..128))
+  (mvtest
+    (buf-count-ones (buf-ash #b'01' i)) 1
+    (buf-count-ones (buf-ash #b'03' i)) 2
+    (buf-count-ones (buf-ash #b'05' i)) 2
+    (buf-count-ones (buf-ash #b'09' i)) 2
+    (buf-count-ones (buf-ash #b'11' i)) 2
+    (buf-count-ones (buf-ash #b'07' i)) 3
+    (buf-count-ones (buf-ash #b'0B' i)) 3
+    (buf-count-ones (buf-ash #b'0D' i)) 3
+    (buf-count-ones (buf-ash #b'0F' i)) 4
+    (buf-count-ones (buf-ash #b'1B' i)) 4
+    (buf-count-ones (buf-ash #b'1B' i)) 4
+    (buf-count-ones (buf-ash #b'17' i)) 4
+    (buf-count-ones (buf-ash #b'1F' i)) 5
+    (buf-count-ones (buf-ash #b'2F' i)) 5
+    (buf-count-ones (buf-ash #b'37' i)) 5
+    (buf-count-ones (buf-ash #b'3D' i)) 5
+    (buf-count-ones (buf-ash #b'3F' i)) 6
+    (buf-count-ones (buf-ash #b'5F' i)) 6
+    (buf-count-ones (buf-ash #b'6F' i)) 6
+    (buf-count-ones (buf-ash #b'77' i)) 6
+    (buf-count-ones (buf-ash #b'7B' i)) 6
+    (buf-count-ones (buf-ash #b'7D' i)) 6
+    (buf-count-ones (buf-ash #b'7f' i)) 7))
diff --git a/txr.1 b/txr.1
index df6c3aaa..a2338dea 100644
--- a/txr.1
+++ b/txr.1
@@ -30486,6 +30486,17 @@ does not contain any bytes that are nonzero, otherwise
 
 An empty buffer satisfies this condition.
 
+.coNP Function @ buf-count-ones
+.synb
+.mets (buf-count-ones << buf )
+.syne
+.desc
+The
+.code buf-count-ones
+function returns a non-negative integer indicating the number of
+occurrences of the bit value 1 in
+.metn buf .
+
 .coNP Functions @ buf-compress and @ buf-decompress
 .synb
 .mets (buf-compress < buf <> [ level ])