- Timestamp:
- 04/08/20 18:38:26 (10 months ago)
- Location:
- release/5/bitwise-utils/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
release/5/bitwise-utils/trunk/bitwise-utils.egg
r38593 r38599 3 3 4 4 ((synopsis "Bitwise utilities") 5 (version "1. 0.1")5 (version "1.1.0") 6 6 (category data) 7 7 (author "[[kon lovett]]") -
release/5/bitwise-utils/trunk/bitwise-utils.scm
r38593 r38599 1 1 ;;;; bitwise-utils.scm -*- Scheme -*- 2 2 ;;;; Kon Lovett, Apr '20 3 4 ;portions 5 6 ;;;; "logical.scm", bit access and operations for integers for Scheme 7 ;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer 8 ; 9 ;Permission to copy this software, to modify it, to redistribute it, 10 ;to distribute modified versions, and to use it for any purpose is 11 ;granted, subject to the following restrictions and understandings. 12 ; 13 ;1. Any copy made of this software must include this copyright notice 14 ;in full. 15 ; 16 ;2. I have made no warranty or representation that the operation of 17 ;this software will be error-free, and I am under no obligation to 18 ;provide any services, by way of maintenance, update, or otherwise. 19 ; 20 ;3. In conjunction with products arising from the use of this 21 ;material, there shall be no use of my name in any advertising, 22 ;promotional, or sales literature without prior written consent in 23 ;each case. 3 24 4 25 ;;;; Issues … … 41 62 bitwise-join 42 63 bitwise-split 43 bitwise-count) 64 bitwise-count 65 bitwise-merge 66 bitwise-nth? 67 bitwise-any? 68 bitwise-first-set 69 bitwise-reverse 70 bitwise-set-nth 71 bitwise-field bitwise-field-copy bitwise-field-reverse bitwise-field-rotate 72 integer->list list->integer) 73 44 74 45 75 (import scheme) 46 (import (only (chicken base) fixnum? foldl cut))76 (import (only (chicken base) sub1 add1 fixnum? foldl cut)) 47 77 (import (chicken type)) 48 78 (import (chicken foreign)) 49 79 (import (only (chicken bitwise) 50 integer-length arithmetic-shift 80 integer-length arithmetic-shift bit->boolean 51 81 bitwise-not bitwise-and bitwise-ior)) 52 82 … … 61 91 (: bitwise-split (integer fixnum --> (list-of integer))) 62 92 (: bitwise-count (integer --> fixnum)) 93 (: bitwise-merge (integer integer integer --> integer)) 94 (: bitwise-nth? (integer fixnum --> boolean)) 95 (: bitwise-any? (integer integer --> boolean)) 96 (: bitwise-first-set (integer --> fixnum)) 97 (: bitwise-reverse (integer fixnum --> integer)) 98 (: bitwise-rotate (integer fixnum fixnum --> integer)) 99 (: bitwise-set-nth (integer fixnum boolean --> integer)) 100 (: bitwise-field (integer fixnum fixnum --> integer)) 101 (: bitwise-field-copy (integer integer fixnum fixnum --> integer)) 102 (: bitwise-field-reverse (integer fixnum fixnum --> integer)) 103 (: bitwise-field-rotate (integer fixnum fixnum fixnum --> integer)) 104 (: integer->list (integer #!optional boolean --> (list-of fixnum))) 105 (: list->integer (list --> integer)) 63 106 64 107 ;observes sign - does sign extend … … 99 142 (loop (*logical-shift-right n w) (cons (bitwise-and n mask) ns)) ) ) ) ) ) 100 143 144 (define (bitwise-abs n) (if (negative? n) (bitwise-not n) n)) 145 101 146 (define *uword-size* (foreign-type-size "C_uword")) 102 147 … … 112 157 113 158 (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*))) ) ) 159 (let ((n (bitwise-abs n))) 160 (if (fixnum? n) (uword-bitwise-count n) 161 (foldl 162 (lambda (c i) (+ c (uword-bitwise-count i))) 163 0 164 (bitwise-split n (* 8 *uword-size*))) ) ) ) 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-mask 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-mask 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)) ) 119 242 120 243 ) ;bitwise-utils -
release/5/bitwise-utils/trunk/tests/bitwise-utils-test.scm
r38593 r38599 58 58 59 59 (test 29 (bitwise-count #xb0000000000000000000000000110000deadbeef)) 60 (test 73(bitwise-count #x-b0000000000000000000000000110000deadbeef))60 (test 28 (bitwise-count #x-b0000000000000000000000000110000deadbeef)) 61 61 62 62 ;;;
Note: See TracChangeset
for help on using the changeset viewer.