1;;;
2;;; srfi-151 - Bitwise operations
3;;;
4;;;   Copyright (c) 2017-2020  Shiro Kawai  <shiro@acm.org>
5;;;
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34(define-module srfi-151
35  (use srfi-1)
36  (use srfi-60)
37  (use srfi-133)
38  (use gauche.generator)
39  (export bitwise-not                   ; srfi-60
40          bitwise-and                   ; srfi-60
41          bitwise-ior                   ; srfi-60
42          bitwise-xor                   ; srfi-60
43          bitwise-eqv
44          bitwise-nand  bitwise-nor
45          bitwise-andc1 bitwise-andc2
46          bitwise-orc1  bitwise-orc2
47
48          arithmetic-shift              ; srfi-60
49          bit-count                     ; builtin
50          integer-length                ; builtin
51
52          bitwise-if                    ; srfi-60
53          bit-set?                      ; builtin
54          copy-bit                      ; builtin
55          bit-swap
56          any-bit-set?
57          every-bit-set?
58          first-set-bit                 ; builtin
59
60          bit-field                     ; builtin
61          bit-field-any?
62          bit-field-every?
63          bit-field-clear
64          bit-field-set
65          bit-field-replace
66          bit-field-replace-same
67          bit-field-rotate
68          bit-field-reverse
69
70          bits->list
71          list->bits
72          bits->vector
73          vector->bits
74          bits
75          bitwise-fold
76          bitwise-for-each
77          bitwise-unfold
78          make-bitwise-generator))
79(select-module srfi-151)
80
81(define (%bitwise-eqv-2 a b) (lognot (logxor a b)))
82
83(define bitwise-eqv
84  (case-lambda
85    [() -1]
86    [(a) a]
87    [(a b) (%bitwise-eqv-2 a b)]
88    [(a b . args) (apply bitwise-eqv (%bitwise-eqv-2 a b) args)]))
89
90;; TODO: These can be a lot more efficiently implemented natively, and
91;; eventually, we'd rather optimize expressons like (lognot (logand a b))
92;; into built-in bitwise-nand etc.
93(define (bitwise-nand a b)  (lognot (logand a b)))
94(define (bitwise-nor a b)   (lognot (logior a b)))
95(define (bitwise-andc1 a b) (logand (lognot a) b))
96(define (bitwise-andc2 a b) (logand a (lognot b)))
97(define (bitwise-orc1 a b)  (logior (lognot a) b))
98(define (bitwise-orc2 a b)  (logior a (lognot b)))
99
100(define (bit-swap index1 index2 n)
101  (let ([a (bit-set? index1 n)]
102        [b (bit-set? index2 n)])
103    (copy-bit index1 (copy-bit index2 n a) b)))
104
105(define (any-bit-set? test-bits n)   (not (zero? (logand test-bits n))))
106(define (every-bit-set? test-bits n) (= (logand test-bits n) test-bits))
107
108(define (bit-field-any? n start end) (not (zero? (bit-field n start end))))
109(define (bit-field-every? n start end) (zero? (bit-field (lognot n) start end)))
110
111(define (bit-field-clear n start end) (copy-bit-field n 0 start end))
112(define (bit-field-set n start end)   (copy-bit-field n -1 start end))
113
114(define bit-field-replace copy-bit-field)
115
116(define (bit-field-replace-same dst src start end)
117  (copy-bit-field dst (bit-field src start end) start end))
118
119(define bit-field-rotate rotate-bit-field) ;srfi-60
120(define bit-field-reverse reverse-bit-field) ;srfi-60
121
122(define (bits->list n . opts)
123  (assume (not (negative? n)))
124  (reverse (apply integer->list n opts)))
125
126(define (bits->vector n :optional len)
127  (assume (not (negative? n)))
128  (vector-unfold (cut bit-set? <> n)
129                 (if (undefined? len) (integer-length n) len)))
130
131(define (list->bits bs)   (list->integer (reverse bs)))
132(define (vector->bits bs) (list->integer (reverse-vector->list bs)))
133(define (bits . bs) (list->bits bs))
134
135(define (bitwise-fold proc seed n)
136  (define len (integer-length n))
137  (do ([len len (- len 1)]
138       [n   n   (ash n -1)]
139       [seed seed (proc (odd? n) seed)])
140      [(<= len 0) seed]))
141
142(define (bitwise-for-each proc n)
143  (bitwise-fold (^[b _] (proc b)) 0 n))
144
145(define (bitwise-unfold p f g seed)
146  (do ([seed seed (g seed)]
147       [i    0    (+ i 1)]
148       [r    0    (copy-bit i r (f seed))])
149      [(p seed) r]))
150
151;; Unlike bits->generator in gauche.generator, this one is infinite.
152(define (make-bitwise-generator n)
153  (^[] (begin0 (odd? n) (set! n (ash n -1)))))
154
155
156
157