From 26d5e46c02b03bd2384ad5481510dc82578da508 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Thu, 26 Oct 2017 22:13:56 +0000
Subject: [PATCH] Add common integer bit string ffs, fls, ctz, and clz.

(ffs x): find first set, 1-indexed with 0 for 0
(fls x): find last set, 1-indexed with 0 for 0 (same as integer-length)
(ctz x): count trailing zeros (same as ffs)
((clz n) x): count leading zeros in n-bit word x
---
 src/runtime/integer-bits.scm        | 36 +++++++++++++++++++++
 src/runtime/runtime.pkg             |  4 +++
 tests/runtime/test-integer-bits.scm | 49 +++++++++++++++++++++++++++++
 3 files changed, 89 insertions(+)

diff --git a/src/runtime/integer-bits.scm b/src/runtime/integer-bits.scm
index 22bf9c12a..5f9a598a0 100644
--- a/src/runtime/integer-bits.scm
+++ b/src/runtime/integer-bits.scm
@@ -216,3 +216,39 @@ USA.
 (define (shiftin x mask)
   ;; (bitwise-and ... mask)?
   (shift-left x (first-set-bit mask)))
+
+;;; Other standardish bit operations
+
+;;; Find First Set, 1-indexed; (ffs 0) = 0
+;;;
+;;; (Note some authors use 0-indexed ffs, and fail or return -1 for 0.)
+
+(define-integrable (ffs x)
+  (+ 1 (first-set-bit x)))
+
+;;; Find Last Set, 1-indexed; (fls 0) = 0
+;;;
+;;; For negative inputs, we find last clear, a.k.a. find last set of
+;;; complement.
+;;;
+;;; (Note some authors use 0-indexed fls, and fail or return -1 for 0.)
+
+(define-integrable (fls x)
+  (integer-length x))
+
+;;; Count Trailing Zeros; (ctz 0) = 0
+
+(define-integrable (ctz x)
+  (ffs x))
+
+;;; Count Leading Zeros in an n-bit word
+
+(declare (integrate clz))
+(define ((clz n) x)
+  ;; Round up to a power of two minus 1, at most 2^n; count the
+  ;; low-order one bits; subtract from n to get the zero bits
+  (assert (< x (shift-left 1 n)))
+  (let loop ((i 1) (x x))
+    (if (< i n)
+        (loop (* i 2) (bitwise-ior x (shift-right x i)))
+        (- n (bit-count x)))))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index aeb97efc0..36973f43a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -374,10 +374,14 @@ USA.
 	  bitwise-merge
 	  bitwise-not
 	  clear-bit
+	  clz
+	  ctz
 	  edit-bit-field
 	  extract-bit
 	  extract-bit-field
+	  ffs
 	  first-set-bit
+	  fls
 	  hamming-distance
 	  integer-length
 	  replace-bit-field
diff --git a/tests/runtime/test-integer-bits.scm b/tests/runtime/test-integer-bits.scm
index 107b37a45..de479c2e5 100644
--- a/tests/runtime/test-integer-bits.scm
+++ b/tests/runtime/test-integer-bits.scm
@@ -413,3 +413,52 @@ USA.
 
 (define-per-bit-test 'EXTRACT-BIT
   (lambda (n i) (assert-eqv (zero? (extract-bit i n)) (bit-clear? i n))))
+
+(define-test 'FFS:0 (lambda () (assert-= 0 (ffs 0))))
+(define-test 'FFS:1 (lambda () (assert-= 1 (ffs 1))))
+(define-test 'FFS:2 (lambda () (assert-= 2 (ffs 2))))
+(define-test 'FFS:3 (lambda () (assert-= 1 (ffs 3))))
+(define-test 'FFS:-1 (lambda () (assert-= 1 (ffs -1))))
+(define-test 'FFS:-2 (lambda () (assert-= 2 (ffs -2))))
+(define-test 'FFS:-3 (lambda () (assert-= 1 (ffs -3))))
+
+(define-per-bit-test 'FFS
+  (lambda (n i)
+    (assert-= (ffs n) (bit-count (bitwise-xor n (- n 1)))
+              'EXPRESSION `(FFS ,n))
+    (assert-= (ffs n) (+ 1 (first-set-bit n)) 'EXPRESSION `(FFS ,n))
+    (assert-= (ffs n) (+ 1 (first-set-bit n)) 'EXPRESSION `(FFS ,n))
+    (assert-= (ffs (- 0 n)) (ffs n) 'EXPRESSION `(FFS (- 0 ,n)))
+    ;; Clear the low i bits of n.
+    (let ((n (bitwise-andc2 n (bit-mask i 0))))
+      (assert-= (ffs n) (bit-count (bitwise-xor n (- n 1)))
+                'EXPRESSION `(FFS ,n))
+      (assert-= (ffs n) (+ 1 (first-set-bit n)) 'EXPRESSION `(FFS ,n))
+      (assert-= (ffs (- 0 n)) (ffs n) 'EXPRESSION `(FFS (- 0 ,n)))
+      (assert->= (ffs n) (+ i 1) 'EXPRESSION `(FFS ,n))
+      ;; Set the ith bit of n and make equality hold exactly.
+      (assert-= (ffs (bitwise-ior n (shift-left 1 i))) (+ i 1)
+                'EXPRESSION `(FFS (BITWISE-IOR ,n (SHIFT-LEFT 1 ,i))))
+      (assert-= (ffs (- 0 (bitwise-ior n (shift-left 1 i)))) (+ i 1)
+                'EXPRESSION `(FFS (- 0 (BITWISE-IOR ,N (SHIFT-LEFT 1 ,i))))))))
+
+(define-test 'CLZ:8:0 (lambda () (assert-= 8 ((clz 8) 0))))
+(define-test 'CLZ:8:1 (lambda () (assert-= 7 ((clz 8) 1))))
+(define-test 'CLZ:8:2 (lambda () (assert-= 6 ((clz 8) 2))))
+(define-test 'CLZ:8:3 (lambda () (assert-= 6 ((clz 8) 3))))
+(define-test 'CLZ:8:FF (lambda () (assert-= 0 ((clz 8) #xff))))
+
+;;; Number of octets in a UTF-8 sequence given the initial octet.
+
+(define (utf8-n o)
+  (max 1 ((clz 8) (bitwise-andc1 o #xff))))
+
+(define-test 'UTF8-N:1 (lambda () (assert-= 1 (utf8-n #b01101101))))
+(define-test 'UTF8-N:2 (lambda () (assert-= 2 (utf8-n #b11001101))))
+(define-test 'UTF8-N:3 (lambda () (assert-= 3 (utf8-n #b11101101))))
+(define-test 'UTF8-N:4 (lambda () (assert-= 4 (utf8-n #b11110011))))
+
+;;; Not real UTF-8, but the arithmetic works out the same!
+
+(define-test 'UTF8-N:5 (lambda () (assert-= 5 (utf8-n #b11111001))))
+(define-test 'UTF8-N:6 (lambda () (assert-= 6 (utf8-n #b11111101))))
-- 
2.25.1