source: project/release/5/bitwise-utils/tags/1.1.3/bitwise-utils.scm @ 38927

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

add 64bit uword-bitwise-count

File size: 7.6 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(module bitwise-utils
28
29(;export
30  arithmetic-shift-left arithmetic-shift-right
31  logical-shift-left logical-shift-right
32  bitwise-mask
33  bitwise-join
34  bitwise-split
35  bitwise-count
36  bitwise-merge
37  bitwise-any? bitwise-nth? bitwise-first-set bitwise-set-nth
38  bitwise-reverse bitwise-rotate
39  bitwise-field bitwise-field-copy bitwise-field-reverse bitwise-field-rotate
40  integer->list list->integer)
41
42
43(import scheme)
44(import (only (chicken base) declare sub1 add1 fixnum? foldl cut))
45(import (chicken type))
46(import (chicken foreign))
47(import (only (chicken bitwise)
48  integer-length arithmetic-shift bit->boolean
49  bitwise-not bitwise-and bitwise-ior))
50
51;;
52
53;FIXME bitwise-split more like string-chop then string-split
54
55(: arithmetic-shift-left (integer fixnum --> integer))
56(: arithmetic-shift-right (integer fixnum --> integer))
57(: logical-shift-left (integer fixnum --> integer))
58(: logical-shift-right (integer fixnum --> integer))
59(: bitwise-mask (fixnum #!optional boolean --> integer))
60(: bitwise-join (integer #!rest integer --> integer))
61(: bitwise-split (integer fixnum --> (list-of integer)))
62(: bitwise-count (integer --> fixnum))
63(: bitwise-merge (integer integer integer --> integer))
64(: bitwise-nth? (integer fixnum --> boolean))
65(: bitwise-any? (integer integer --> boolean))
66(: bitwise-first-set (integer --> fixnum))
67(: bitwise-reverse (integer fixnum --> integer))
68(: bitwise-rotate (integer fixnum fixnum --> integer))
69(: bitwise-set-nth (integer fixnum boolean --> integer))
70(: bitwise-field (integer fixnum fixnum --> integer))
71(: bitwise-field-copy (integer integer fixnum fixnum --> integer))
72(: bitwise-field-reverse (integer fixnum fixnum --> integer))
73(: bitwise-field-rotate (integer fixnum fixnum fixnum --> integer))
74(: integer->list (integer #!optional boolean --> (list-of fixnum)))
75(: list->integer (list --> integer))
76
77;observes sign - does sign extend
78(define arithmetic-shift-left arithmetic-shift)
79(define (arithmetic-shift-right n w) (arithmetic-shift n (- w)))
80
81(define (bitwise-zeros b) (arithmetic-shift-left -1 b))
82
83(define (bitwise-ones b) (bitwise-not (bitwise-zeros b)))
84
85(define (bitwise-abs n) (if (negative? n) (bitwise-not n) n))
86
87(define (bitwise-drop-right n w)
88  (bitwise-and (arithmetic-shift-right n w) (bitwise-ones (- (integer-length n) w))) )
89
90(define (bitwise-cons a b)
91  (bitwise-ior (logical-shift-left a (integer-length b)) b) )
92
93;5 #t => +0...011111
94;5 #f => -1...100000
95(define (bitwise-mask b #!optional (on? #t))
96  (if on? (bitwise-ones b)
97    (bitwise-zeros b) ) )
98
99;preserves sign - doesn't sign extend
100(define logical-shift-left arithmetic-shift-left)
101(define (logical-shift-right n w)
102  (if (zero? w) n
103    (let ((res (bitwise-drop-right (abs n) w)))
104      (if (negative? n) (- res) res) ) ) )
105
106;#b10 #b0000001 #b101 => #b101101
107(define (bitwise-join n . ns)
108  (foldl (cut bitwise-cons <> <>) n ns) )
109
110;babcdef 2 => ba bc de f
111;0 2 => '()
112;123 0 => '()
113(define (bitwise-split n w)
114  (if (or (zero? n) (zero? w)) `(,n)
115    (let ((neg? (negative? n)) (mask (bitwise-ones w)))
116      (let loop ((n (abs n)) (ns '()))
117        (if (zero? n) (if neg? (map - ns) ns)
118          (loop (bitwise-drop-right n w) (cons (bitwise-and n mask) ns)) ) ) ) ) )
119
120(define *uword-size* (foreign-type-size "C_uword"))
121
122#>
123#define TWO( c )       ( ((C_uword) 1u) << (c))
124#define MASK( c )      (((C_uword) -1) / (TWO( TWO( c ) ) + 1u))
125#define COUNT( x, c )  ((x) & MASK( c )) + (((x) >> (TWO( c ))) & MASK( c ))
126<#
127
128(cond-expand
129  (64bit
130    (define uword-bitwise-count
131      (foreign-lambda* unsigned-int ((integer64 n)) "
132        if (0 == n) C_return( (unsigned int) 0 );
133        n = COUNT( n, 0 );
134        n = COUNT( n, 1 );
135        n = COUNT( n, 2 );
136        n = COUNT( n, 3 );
137        n = COUNT( n, 4 );
138        C_return( (unsigned int) COUNT( n, 5 ) );")) )
139  (else ;32bit
140    (define uword-bitwise-count
141      (foreign-lambda* unsigned-int ((integer32 n)) "
142        if (0 == n) C_return( (unsigned int) 0 );
143        n = COUNT( n, 0 );
144        n = COUNT( n, 1 );
145        n = COUNT( n, 2 );
146        n = COUNT( n, 3 );
147        C_return( (unsigned int) COUNT( n, 4 ) );")) ) )
148
149#|
150#>
151#undef COUNT
152#undef MASK
153#undef TWO
154<#
155|#
156
157(define (integer->uwords n) (bitwise-split n (* 8 *uword-size*)))
158
159(define (add-uword-bits c n) (+ c (uword-bitwise-count n)))
160
161(define (bitwise-count n)
162  (let ((n (bitwise-abs n)))
163    (if (fixnum? n) (uword-bitwise-count n)
164      (foldl add-uword-bits 0 (integer->uwords n)) ) ) )
165
166(define (bitwise-merge mask n0 n1)
167  (bitwise-ior
168    (bitwise-and mask n0)
169    (bitwise-and (bitwise-not mask) n1)) )
170
171(define (bitwise-nth? index n)
172  (bit->boolean n index) )
173
174(define (bitwise-any? n1 n2)
175  (not (zero? (bitwise-and n1 n2))) )
176
177(define (bitwise-first-set n)
178  (sub1 (integer-length (bitwise-and n (- n)))) )
179
180(define (bitwise-reverse n k)
181  (do ((m (bitwise-abs n) (arithmetic-shift m -1))
182       (k (sub1 k) (sub1 k))
183       (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m))))
184      ((negative? k) (if (negative? n) (bitwise-not rvs) rvs))))
185
186(define (bitwise-rotate k count len)
187  (bitwise-field-rotate k count 0 len) )
188
189(define (bitwise-set-nth to index bool)
190  (if bool
191    (bitwise-ior to (arithmetic-shift 1 index))
192    (bitwise-and to (bitwise-not (arithmetic-shift 1 index))) ) )
193
194(define (bitwise-field n start end)
195  (bitwise-and
196    (bitwise-not (arithmetic-shift -1 (- end start)))
197          (arithmetic-shift-right n start)) )
198
199(define (bitwise-field-copy to from start end)
200  (bitwise-merge
201    (arithmetic-shift (bitwise-not (arithmetic-shift -1 (- end start))) start)
202    (arithmetic-shift from start)
203    to) )
204
205(define (bitwise-field-reverse n start end)
206  (let* (
207    (width (- end start))
208    (mask (bitwise-ones width))
209    (zn (bitwise-and mask (arithmetic-shift-right n start))) )
210    (bitwise-ior
211      (arithmetic-shift (bitwise-reverse zn width) start)
212            (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )
213
214(define (bitwise-field-rotate n count start end)
215  (let* (
216    (width (- end start))
217    (count (modulo count width))
218    (mask (bitwise-ones width))
219    (zn (bitwise-and mask (arithmetic-shift-right n start))) )
220    (bitwise-ior
221      (arithmetic-shift
222        (bitwise-ior
223          (bitwise-and mask (arithmetic-shift zn count))
224          (arithmetic-shift zn (- count width)))
225        start)
226            (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )
227
228(define (integer->list k #!optional len)
229  (if (not len)
230    (do ((k k (arithmetic-shift k -1))
231         (lst '() (cons (add1 k) lst)) )
232        ((<= k 0) lst))
233    (do ((idx (sub1 len) (sub1 idx))
234         (k k (arithmetic-shift k -1))
235         (lst '() (cons (add1 k) lst)))
236        ((negative? idx) lst)) ) )
237
238(define (list->integer bools)
239  (do ((bs bools (cdr bs))
240       (acc 0 (+ acc acc (if (car bs) 1 0))))
241      ((null? bs) acc)) )
242
243) ;bitwise-utils
Note: See TracBrowser for help on using the repository browser.