source: project/release/5/bitwise-utils/trunk/bitwise-utils.scm @ 38602

Last change on this file since 38602 was 38602, checked in by Kon Lovett, 6 months ago

fix bitwise-mask type, add bitwise-rotate

File size: 7.4 KB
Line 
1;;;; bitwise-utils.scm  -*- Scheme -*-
2;;;; Kon Lovett, Apr '20
3
4;;;; Issues
5;;
6;; - Portions from C4 srfi-60
7
8;;;; "logical.scm", bit access and operations for integers for Scheme
9;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
10;
11;Permission to copy this software, to modify it, to redistribute it,
12;to distribute modified versions, and to use it for any purpose is
13;granted, subject to the following restrictions and understandings.
14;
15;1.  Any copy made of this software must include this copyright notice
16;in full.
17;
18;2.  I have made no warranty or representation that the operation of
19;this software will be error-free, and I am under no obligation to
20;provide any services, by way of maintenance, update, or otherwise.
21;
22;3.  In conjunction with products arising from the use of this
23;material, there shall be no use of my name in any advertising,
24;promotional, or sales literature without prior written consent in
25;each case.
26
27#>
28/* Number of 1 bits */
29static unsigned int
30C_uword_bits( C_uword n )
31{
32# define TWO( c )       ( ((C_uword) 1u) << (c))
33# define MASK( c )      (((C_uword) -1) / (TWO( TWO( c ) ) + 1u))
34# define COUNT( x, c )  ((x) & MASK( c )) + (((x) >> (TWO( c ))) & MASK( c ))
35
36  if (0 == n) return (unsigned int) 0;
37
38        n = COUNT( n, 0 );
39        n = COUNT( n, 1 );
40        n = COUNT( n, 2 );
41        n = COUNT( n, 3 );
42        n = COUNT( n, 4 );
43# ifdef C_SIXTY_FOUR
44        n = COUNT( n, 5 );
45# endif
46
47        return (unsigned int) n;
48
49# undef COUNT
50# undef MASK
51# undef TWO
52}
53<#
54
55(module bitwise-utils
56
57(;export
58  arithmetic-shift-left arithmetic-shift-right
59  logical-shift-left logical-shift-right
60  bitwise-mask
61  bitwise-join
62  bitwise-split
63  bitwise-count
64  bitwise-merge
65  bitwise-any? bitwise-nth? bitwise-first-set bitwise-set-nth
66  bitwise-reverse bitwise-rotate
67  bitwise-field bitwise-field-copy bitwise-field-reverse bitwise-field-rotate
68  integer->list list->integer)
69
70
71(import scheme)
72(import (only (chicken base) sub1 add1 fixnum? foldl cut))
73(import (chicken type))
74(import (chicken foreign))
75(import (only (chicken bitwise)
76  integer-length arithmetic-shift bit->boolean
77  bitwise-not bitwise-and bitwise-ior))
78
79;;
80
81(: arithmetic-shift-left (integer fixnum --> integer))
82(: arithmetic-shift-right (integer fixnum --> integer))
83(: logical-shift-left (integer fixnum --> integer))
84(: logical-shift-right (integer fixnum --> integer))
85(: bitwise-mask (fixnum #!optional boolean --> integer))
86(: bitwise-join (integer #!rest integer --> integer))
87(: bitwise-split (integer fixnum --> (list-of integer)))
88(: bitwise-count (integer --> fixnum))
89(: bitwise-merge (integer integer integer --> integer))
90(: bitwise-nth? (integer fixnum --> boolean))
91(: bitwise-any? (integer integer --> boolean))
92(: bitwise-first-set (integer --> fixnum))
93(: bitwise-reverse (integer fixnum --> integer))
94(: bitwise-rotate (integer fixnum fixnum --> integer))
95(: bitwise-set-nth (integer fixnum boolean --> integer))
96(: bitwise-field (integer fixnum fixnum --> integer))
97(: bitwise-field-copy (integer integer fixnum fixnum --> integer))
98(: bitwise-field-reverse (integer fixnum fixnum --> integer))
99(: bitwise-field-rotate (integer fixnum fixnum fixnum --> integer))
100(: integer->list (integer #!optional boolean --> (list-of fixnum)))
101(: list->integer (list --> integer))
102
103;observes sign - does sign extend
104(define arithmetic-shift-left arithmetic-shift)
105(define (arithmetic-shift-right n w) (arithmetic-shift n (- w)))
106
107;5 #t => +0...011111
108;5 #f => -1...100000
109(define (bitwise-mask b #!optional (on? #t))
110  (if (zero? b) 0
111    (let ((res (arithmetic-shift-left -1 b)))
112      (if on? (bitwise-not res) res) ) ) )
113
114(define (*logical-shift-right n w)
115  (bitwise-and (arithmetic-shift-right n w) (bitwise-mask (- (integer-length n) w))) )
116
117;preserves sign - doesn't sign extend
118(define logical-shift-left arithmetic-shift-left)
119(define (logical-shift-right n w)
120  (if (zero? w) n
121    (let ((res (*logical-shift-right (abs n) w)))
122      (if (negative? n) (- res) res) ) ) )
123
124(define (*bitwise-join a b)
125  (bitwise-ior (logical-shift-left a (integer-length b)) b) )
126
127;#b10 #b0000001 #b101 => #b101101
128(define (bitwise-join n . ns) (foldl (cut *bitwise-join <> <>) n ns))
129
130;babcdef 2 => ba bc de f
131;0 2 => '()
132;123 0 => '()
133(define (bitwise-split n w)
134  (if (or (zero? n) (zero? w)) `(,n)
135    (let ((neg? (negative? n)) (mask (bitwise-mask w)))
136      (let loop ((n (abs n)) (ns '()))
137        (if (zero? n) (if neg? (map - ns) ns)
138          (loop (*logical-shift-right n w) (cons (bitwise-and n mask) ns)) ) ) ) ) )
139
140(define (bitwise-abs n) (if (negative? n) (bitwise-not n) n))
141
142(define *uword-size* (foreign-type-size "C_uword"))
143
144(cond-expand
145  (64bit
146    (define uword-bitwise-count
147      (foreign-lambda* unsigned-int ((integer64 n))
148        "return( C_uword_bits( (C_uword) n ) );")) )
149  (else ;32bit
150    (define uword-bitwise-count
151      (foreign-lambda* unsigned-int ((integer32 n))
152        "return( C_uword_bits( (C_uword) n ) );")) ) )
153
154(define (bitwise-count n)
155  (let ((n (bitwise-abs n)))
156    (if (fixnum? n) (uword-bitwise-count n)
157      (foldl
158        (lambda (c i) (+ c (uword-bitwise-count i)))
159        0
160        (bitwise-split n (* 8 *uword-size*))) ) ) )
161
162(define (bitwise-merge mask n0 n1)
163  (bitwise-ior
164    (bitwise-and mask n0)
165    (bitwise-and (bitwise-not mask) n1)) )
166
167(define (bitwise-nth? index n)
168  (bit->boolean n index) )
169
170(define (bitwise-any? n1 n2)
171  (not (zero? (bitwise-and n1 n2))) )
172
173(define (bitwise-first-set n)
174  (sub1 (integer-length (bitwise-and n (- n)))) )
175
176(define (bitwise-reverse n k)
177  (do ((m (bitwise-abs n) (arithmetic-shift m -1))
178       (k (sub1 k) (sub1 k))
179       (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m))))
180      ((negative? k) (if (negative? n) (bitwise-not rvs) rvs))))
181
182(define (bitwise-rotate k count len)
183  (bitwise-field-rotate k count 0 len) )
184
185(define (bitwise-set-nth to index bool)
186  (if bool
187    (bitwise-ior to (arithmetic-shift 1 index))
188    (bitwise-and to (bitwise-not (arithmetic-shift 1 index))) ) )
189
190(define (bitwise-field n start end)
191  (bitwise-and
192    (bitwise-not (arithmetic-shift -1 (- end start)))
193          (arithmetic-shift-right n start)) )
194
195(define (bitwise-field-copy to from start end)
196  (bitwise-merge
197    (arithmetic-shift (bitwise-not (arithmetic-shift -1 (- end start))) start)
198    (arithmetic-shift from start)
199    to) )
200
201(define (bitwise-field-reverse n start end)
202  (let* (
203    (width (- end start))
204    (mask (bitwise-mask width))
205    (zn (bitwise-and mask (arithmetic-shift-right n start))) )
206    (bitwise-ior
207      (arithmetic-shift (bitwise-reverse zn width) start)
208            (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )
209
210(define (bitwise-field-rotate n count start end)
211  (let* (
212    (width (- end start))
213    (count (modulo count width))
214    (mask (bitwise-mask width))
215    (zn (bitwise-and mask (arithmetic-shift-right n start))) )
216    (bitwise-ior
217      (arithmetic-shift
218        (bitwise-ior
219          (bitwise-and mask (arithmetic-shift zn count))
220          (arithmetic-shift zn (- count width)))
221        start)
222            (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )
223
224(define (integer->list k #!optional len)
225  (if (not len)
226    (do ((k k (arithmetic-shift k -1))
227         (lst '() (cons (add1 k) lst)) )
228        ((<= k 0) lst))
229    (do ((idx (sub1 len) (sub1 idx))
230         (k k (arithmetic-shift k -1))
231         (lst '() (cons (add1 k) lst)))
232        ((negative? idx) lst)) ) )
233
234(define (list->integer bools)
235  (do ((bs bools (cdr bs))
236       (acc 0 (+ acc acc (if (car bs) 1 0))))
237      ((null? bs) acc)) )
238
239) ;bitwise-utils
Note: See TracBrowser for help on using the repository browser.