1;;;; "logical.scm", bit access and operations for integers for Scheme 2;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer 3; 4;Permission to copy this software, to modify it, to redistribute it, 5;to distribute modified versions, and to use it for any purpose is 6;granted, subject to the following restrictions and understandings. 7; 8;1. Any copy made of this software must include this copyright notice 9;in full. 10; 11;2. I have made no warranty or representation that the operation of 12;this software will be error-free, and I am under no obligation to 13;provide any services, by way of maintenance, update, or otherwise. 14; 15;3. In conjunction with products arising from the use of this 16;material, there shall be no use of my name in any advertising, 17;promotional, or sales literature without prior written consent in 18;each case. 19 20(define logical:boole-xor 21 '#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 22 #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14) 23 #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13) 24 #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12) 25 #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11) 26 #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10) 27 #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9) 28 #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) 29 #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7) 30 #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6) 31 #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5) 32 #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) 33 #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3) 34 #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) 35 #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1) 36 #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0))) 37 38(define logical:boole-and 39 '#(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 40 #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1) 41 #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2) 42 #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3) 43 #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4) 44 #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5) 45 #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6) 46 #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7) 47 #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8) 48 #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9) 49 #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10) 50 #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11) 51 #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12) 52 #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13) 53 #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14) 54 #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))) 55 56(define (logical:ash-4 x) 57 (if (negative? x) 58 (+ -1 (quotient (+ 1 x) 16)) 59 (quotient x 16))) 60 61(define (logical:reduce op4 ident) 62 (lambda args 63 (do ((res ident (op4 res (car rgs) 1 0)) 64 (rgs args (cdr rgs))) 65 ((null? rgs) res)))) 66 67;@ 68(define logand 69 (letrec 70 ((lgand 71 (lambda (n2 n1 scl acc) 72 (cond ((= n1 n2) (+ acc (* scl n1))) 73 ((zero? n2) acc) 74 ((zero? n1) acc) 75 (else (lgand (logical:ash-4 n2) 76 (logical:ash-4 n1) 77 (* 16 scl) 78 (+ (* (vector-ref (vector-ref logical:boole-and 79 (modulo n1 16)) 80 (modulo n2 16)) 81 scl) 82 acc))))))) 83 (logical:reduce lgand -1))) 84;@ 85(define logior 86 (letrec 87 ((lgior 88 (lambda (n2 n1 scl acc) 89 (cond ((= n1 n2) (+ acc (* scl n1))) 90 ((zero? n2) (+ acc (* scl n1))) 91 ((zero? n1) (+ acc (* scl n2))) 92 (else (lgior (logical:ash-4 n2) 93 (logical:ash-4 n1) 94 (* 16 scl) 95 (+ (* (- 15 (vector-ref 96 (vector-ref logical:boole-and 97 (- 15 (modulo n1 16))) 98 (- 15 (modulo n2 16)))) 99 scl) 100 acc))))))) 101 (logical:reduce lgior 0))) 102;@ 103(define logxor 104 (letrec 105 ((lgxor 106 (lambda (n2 n1 scl acc) 107 (cond ((= n1 n2) acc) 108 ((zero? n2) (+ acc (* scl n1))) 109 ((zero? n1) (+ acc (* scl n2))) 110 (else (lgxor (logical:ash-4 n2) 111 (logical:ash-4 n1) 112 (* 16 scl) 113 (+ (* (vector-ref (vector-ref logical:boole-xor 114 (modulo n1 16)) 115 (modulo n2 16)) 116 scl) 117 acc))))))) 118 (logical:reduce lgxor 0))) 119;@ 120(define (lognot n) (- -1 n)) 121;@ 122(define (logtest n1 n2) 123 (not (zero? (logand n1 n2)))) 124;@ 125(define (logbit? index n) 126 (logtest (expt 2 index) n)) 127;@ 128(define (copy-bit index to bool) 129 (if bool 130 (logior to (arithmetic-shift 1 index)) 131 (logand to (lognot (arithmetic-shift 1 index))))) 132;@ 133(define (bitwise-if mask n0 n1) 134 (logior (logand mask n0) 135 (logand (lognot mask) n1))) 136;@ 137(define (bit-field n start end) 138 (logand (lognot (ash -1 (- end start))) 139 (arithmetic-shift n (- start)))) 140;@ 141(define (copy-bit-field to from start end) 142 (bitwise-if (arithmetic-shift (lognot (ash -1 (- end start))) start) 143 (arithmetic-shift from start) 144 to)) 145;@ 146(define (rotate-bit-field n count start end) 147 (define width (- end start)) 148 (set! count (modulo count width)) 149 (let ((mask (lognot (ash -1 width)))) 150 (define zn (logand mask (arithmetic-shift n (- start)))) 151 (logior (arithmetic-shift 152 (logior (logand mask (arithmetic-shift zn count)) 153 (arithmetic-shift zn (- count width))) 154 start) 155 (logand (lognot (ash mask start)) n)))) 156;@ 157(define (arithmetic-shift n count) 158 (if (negative? count) 159 (let ((k (expt 2 (- count)))) 160 (if (negative? n) 161 (+ -1 (quotient (+ 1 n) k)) 162 (quotient n k))) 163 (* (expt 2 count) n))) 164;@ 165(define integer-length 166 (letrec ((intlen (lambda (n tot) 167 (case n 168 ((0 -1) (+ 0 tot)) 169 ((1 -2) (+ 1 tot)) 170 ((2 3 -3 -4) (+ 2 tot)) 171 ((4 5 6 7 -5 -6 -7 -8) (+ 3 tot)) 172 (else (intlen (logical:ash-4 n) (+ 4 tot))))))) 173 (lambda (n) (intlen n 0)))) 174;@ 175(define bitwise-bit-count 176 (letrec ((logcnt (lambda (n tot) 177 (if (zero? n) 178 tot 179 (logcnt (quotient n 16) 180 (+ (vector-ref 181 '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4) 182 (modulo n 16)) 183 tot)))))) 184 (lambda (n) 185 (cond ((negative? n) (lognot (logcnt (lognot n) 0))) 186 ((positive? n) (logcnt n 0)) 187 (else 0))))) 188;@ 189(define (logcount n) 190 (cond ((negative? n) (bitwise-bit-count (lognot n))) 191 (else (bitwise-bit-count n)))) 192;@ 193(define (log2-binary-factors n) 194 (+ -1 (integer-length (logand n (- n))))) 195 196(define (bit-reverse k n) 197 (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1)) 198 (k (+ -1 k) (+ -1 k)) 199 (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m)))) 200 ((negative? k) (if (negative? n) (lognot rvs) rvs)))) 201;@ 202(define (reverse-bit-field n start end) 203 (define width (- end start)) 204 (let ((mask (lognot (ash -1 width)))) 205 (define zn (logand mask (arithmetic-shift n (- start)))) 206 (logior (arithmetic-shift (bit-reverse width zn) start) 207 (logand (lognot (ash mask start)) n)))) 208;@ 209(define (integer->list k . len) 210 (if (negative? k) (slib:error 'integer->list 'negative? k)) 211 (if (null? len) 212 (do ((k k (arithmetic-shift k -1)) 213 (lst '() (cons (odd? k) lst))) 214 ((<= k 0) lst)) 215 (do ((idx (+ -1 (car len)) (+ -1 idx)) 216 (k k (arithmetic-shift k -1)) 217 (lst '() (cons (odd? k) lst))) 218 ((negative? idx) lst)))) 219;@ 220(define (list->integer bools) 221 (do ((bs bools (cdr bs)) 222 (acc 0 (+ acc acc (if (car bs) 1 0)))) 223 ((null? bs) acc))) 224(define (booleans->integer . bools) 225 (list->integer bools)) 226 227;;;;@ SRFI-60 aliases 228(define ash arithmetic-shift) 229(define bitwise-ior logior) 230(define bitwise-xor logxor) 231(define bitwise-and logand) 232(define bitwise-not lognot) 233(define bit-count logcount) 234(define bit-set? logbit?) 235(define any-bits-set? logtest) 236(define first-set-bit log2-binary-factors) 237(define bitwise-merge bitwise-if) 238(provide 'srfi-60) 239 240;;; Legacy 241;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len)) 242;;(define (logical:ones deg) (lognot (ash -1 deg))) 243;;(define integer-expt expt) ; legacy name 244