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