Changeset 38599 in project for release

Timestamp:

04/08/20 18:38:26 (4 months ago)

Author:

Kon Lovett

Message:

add srfi-60 inspired routines

Location:

release/5/bitwise-utils/trunk

Files:

• bitwise-utils.egg (modified) (1 diff)
• bitwise-utils.scm (modified) (5 diffs)
• tests/bitwise-utils-test.scm (modified) (1 diff)

release/5/bitwise-utils/trunk/bitwise-utils.egg

@@ -3 +3 @@
 
 ((synopsis "Bitwise utilities")
- (version "1.0.1")
+ (version "1.1.0")
  (category data)
  (author "[[kon lovett]]")

release/5/bitwise-utils/trunk/bitwise-utils.scm

@@ -1 +1 @@
 ;;;; bitwise-utils.scm  -*- Scheme -*-
 ;;;; Kon Lovett, Apr '20
+
+;portions
+
+;;;; "logical.scm", bit access and operations for integers for Scheme
+;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
 
 ;;;; Issues
@@ -41 +62 @@
   bitwise-join
   bitwise-split
-  bitwise-count)
+  bitwise-count
+  bitwise-merge
+  bitwise-nth?
+  bitwise-any?
+  bitwise-first-set
+  bitwise-reverse
+  bitwise-set-nth
+  bitwise-field bitwise-field-copy bitwise-field-reverse bitwise-field-rotate
+  integer->list list->integer)
+
 
 (import scheme)
-(import (only (chicken base) fixnum? foldl cut))
+(import (only (chicken base) sub1 add1 fixnum? foldl cut))
 (import (chicken type))
 (import (chicken foreign))
 (import (only (chicken bitwise)
-  integer-length arithmetic-shift
+  integer-length arithmetic-shift bit->boolean
   bitwise-not bitwise-and bitwise-ior))
 
@@ -61 +91 @@
 (: bitwise-split (integer fixnum --> (list-of integer)))
 (: bitwise-count (integer --> fixnum))
+(: bitwise-merge (integer integer integer --> integer))
+(: bitwise-nth? (integer fixnum --> boolean))
+(: bitwise-any? (integer integer --> boolean))
+(: bitwise-first-set (integer --> fixnum))
+(: bitwise-reverse (integer fixnum --> integer))
+(: bitwise-rotate (integer fixnum fixnum --> integer))
+(: bitwise-set-nth (integer fixnum boolean --> integer))
+(: bitwise-field (integer fixnum fixnum --> integer))
+(: bitwise-field-copy (integer integer fixnum fixnum --> integer))
+(: bitwise-field-reverse (integer fixnum fixnum --> integer))
+(: bitwise-field-rotate (integer fixnum fixnum fixnum --> integer))
+(: integer->list (integer #!optional boolean --> (list-of fixnum)))
+(: list->integer (list --> integer))
 
 ;observes sign - does sign extend
@@ -99 +142 @@
           (loop (*logical-shift-right n w) (cons (bitwise-and n mask) ns)) ) ) ) ) )
 
+(define (bitwise-abs n) (if (negative? n) (bitwise-not n) n))
+
 (define *uword-size* (foreign-type-size "C_uword"))
 
@@ -112 +157 @@
 
 (define (bitwise-count n)
-  (if (fixnum? n) (uword-bitwise-count n)
-    (foldl
-      (lambda (c i) (+ c (uword-bitwise-count i)))
-      0
-      (bitwise-split n (* 8 *uword-size*))) ) )
+  (let ((n (bitwise-abs n)))
+    (if (fixnum? n) (uword-bitwise-count n)
+      (foldl
+        (lambda (c i) (+ c (uword-bitwise-count i)))
+        0
+        (bitwise-split n (* 8 *uword-size*))) ) ) )
+
+(define (bitwise-merge mask n0 n1)
+  (bitwise-ior
+    (bitwise-and mask n0)
+    (bitwise-and (bitwise-not mask) n1)) )
+
+(define (bitwise-nth? index n)
+  (bit->boolean n index) )
+
+(define (bitwise-any? n1 n2)
+  (not (zero? (bitwise-and n1 n2))) )
+
+(define (bitwise-first-set n)
+  (sub1 (integer-length (bitwise-and n (- n)))) )
+
+(define (bitwise-reverse n k)
+  (do ((m (bitwise-abs n) (arithmetic-shift m -1))
+       (k (sub1 k) (sub1 k))
+       (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m))))
+      ((negative? k) (if (negative? n) (bitwise-not rvs) rvs))))
+
+(define (bitwise-rotate k count len)
+  (bitwise-field-rotate k count 0 len) )
+
+(define (bitwise-set-nth to index bool)
+  (if bool
+    (bitwise-ior to (arithmetic-shift 1 index))
+    (bitwise-and to (bitwise-not (arithmetic-shift 1 index))) ) )
+
+(define (bitwise-field n start end)
+  (bitwise-and
+    (bitwise-not (arithmetic-shift -1 (- end start)))
+          (arithmetic-shift-right n start)) )
+
+(define (bitwise-field-copy to from start end)
+  (bitwise-merge
+    (arithmetic-shift (bitwise-not (arithmetic-shift -1 (- end start))) start)
+    (arithmetic-shift from start)
+    to) )
+
+(define (bitwise-field-reverse n start end)
+  (let* (
+    (width (- end start))
+    (mask (bitwise-mask width))
+    (zn (bitwise-and mask (arithmetic-shift-right n start))) )
+    (bitwise-ior
+      (arithmetic-shift (bitwise-reverse zn width) start)
+            (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )
+
+(define (bitwise-field-rotate n count start end)
+  (let* (
+    (width (- end start))
+    (count (modulo count width))
+    (mask (bitwise-mask width))
+    (zn (bitwise-and mask (arithmetic-shift-right n start))) )
+    (bitwise-ior
+      (arithmetic-shift
+        (bitwise-ior
+          (bitwise-and mask (arithmetic-shift zn count))
+          (arithmetic-shift zn (- count width)))
+        start)
+            (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )
+
+(define (integer->list k #!optional len)
+  (if (not len)
+    (do ((k k (arithmetic-shift k -1))
+         (lst '() (cons (add1 k) lst)) )
+        ((<= k 0) lst))
+    (do ((idx (sub1 len) (sub1 idx))
+         (k k (arithmetic-shift k -1))
+         (lst '() (cons (add1 k) lst)))
+        ((negative? idx) lst)) ) )
+
+(define (list->integer bools)
+  (do ((bs bools (cdr bs))
+       (acc 0 (+ acc acc (if (car bs) 1 0))))
+      ((null? bs) acc)) )
 
 ) ;bitwise-utils

release/5/bitwise-utils/trunk/tests/bitwise-utils-test.scm

@@ -58 +58 @@
 
 (test 29 (bitwise-count #xb0000000000000000000000000110000deadbeef))
-(test 73 (bitwise-count #x-b0000000000000000000000000110000deadbeef))
+(test 28 (bitwise-count #x-b0000000000000000000000000110000deadbeef))
 
 ;;;