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

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

fix bitwise-split @ 0 return

File size: 3.2 KB
Line 
1;;;; bitwise-utils.scm  -*- Scheme -*-
2;;;; Kon Lovett, Apr '20
3
4;;;; Issues
5;;
6
7#>
8/* Number of 1 bits */
9static unsigned int
10C_uword_bits( C_uword n )
11{
12# define TWO( c )       ( ((C_uword) 1u) << (c))
13# define MASK( c )      (((C_uword) -1) / (TWO( TWO( c ) ) + 1u))
14# define COUNT( x, c )  ((x) & MASK( c )) + (((x) >> (TWO( c ))) & MASK( c ))
15
16  if (0 == n) return (unsigned int) 0;
17
18        n = COUNT( n, 0 );
19        n = COUNT( n, 1 );
20        n = COUNT( n, 2 );
21        n = COUNT( n, 3 );
22        n = COUNT( n, 4 );
23# ifdef C_SIXTY_FOUR
24        n = COUNT( n, 5 );
25# endif
26
27        return (unsigned int) n;
28
29# undef COUNT
30# undef MASK
31# undef TWO
32}
33<#
34
35(module bitwise-utils
36
37(;export
38  arithmetic-shift-left arithmetic-shift-right
39  logical-shift-left logical-shift-right
40  bitwise-mask
41  bitwise-join
42  bitwise-split
43  bitwise-count)
44
45(import scheme)
46(import (only (chicken base) fixnum? foldl cut))
47(import (chicken type))
48(import (chicken foreign))
49(import (only (chicken bitwise)
50  integer-length arithmetic-shift
51  bitwise-not bitwise-and bitwise-ior))
52
53;;
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 fixnum --> integer))
60(: bitwise-join (integer #!rest integer --> integer))
61(: bitwise-split (integer fixnum --> (list-of integer)))
62(: bitwise-count (integer --> fixnum))
63
64;observes sign - does sign extend
65(define arithmetic-shift-left arithmetic-shift)
66(define (arithmetic-shift-right n w) (arithmetic-shift n (- w)))
67
68;5 #t => +0...011111
69;5 #f => -1...100000
70(define (bitwise-mask b #!optional (on? #t))
71  (if (zero? b) 0
72    (let ((res (arithmetic-shift-left -1 b)))
73      (if on? (bitwise-not res) res) ) ) )
74
75(define (*logical-shift-right n w)
76  (bitwise-and (arithmetic-shift-right n w) (bitwise-mask (- (integer-length n) w))) )
77
78;preserves sign - doesn't sign extend
79(define logical-shift-left arithmetic-shift-left)
80(define (logical-shift-right n w)
81  (if (zero? w) n
82    (let ((res (*logical-shift-right (abs n) w)))
83      (if (negative? n) (- res) res) ) ) )
84
85(define (*bitwise-join a b)
86  (bitwise-ior (logical-shift-left a (integer-length b)) b) )
87
88;#b10 #b0000001 #b101 => #b101101
89(define (bitwise-join n . ns) (foldl (cut *bitwise-join <> <>) n ns))
90
91;babcdef 2 => ba bc de f
92;0 2 => '()
93;123 0 => '()
94(define (bitwise-split n w)
95  (if (or (zero? n) (zero? w)) `(,n)
96    (let ((neg? (negative? n)) (mask (bitwise-mask w)))
97      (let loop ((n (abs n)) (ns '()))
98        (if (zero? n) (if neg? (map - ns) ns)
99          (loop (*logical-shift-right n w) (cons (bitwise-and n mask) ns)) ) ) ) ) )
100
101(define *uword-size* (foreign-type-size "C_uword"))
102
103(cond-expand
104  (64bit
105    (define uword-bitwise-count
106      (foreign-lambda* unsigned-int ((integer64 n))
107        "return( C_uword_bits( (C_uword) n ) );")) )
108  (else ;32bit
109    (define uword-bitwise-count
110      (foreign-lambda* unsigned-int ((integer32 n))
111        "return( C_uword_bits( (C_uword) n ) );")) ) )
112
113(define (bitwise-count n)
114  (if (fixnum? n) (uword-bitwise-count n)
115    (foldl
116      (lambda (c i) (+ c (uword-bitwise-count i)))
117      0
118      (bitwise-split n (* 8 *uword-size*))) ) )
119
120) ;bitwise-utils
Note: See TracBrowser for help on using the repository browser.