1;;;
2;;;  srfi-60 - integers as bits
3;;;
4;;;  Since most procedures are already supported as builtins, this
5;;;  module only provides a thin wrapper to cover the complete srfi-60 spec.
6
7(define-module srfi-60
8  (use gauche.sequence)
9  (use srfi-42)
10  (export logand bitwise-and
11          logior bitwise-ior
12          logxor bitwise-xor
13          lognot bitwise-not
14          bitwise-if bitwise-merge
15          logtest any-bits-set?
16          logcount bit-count
17          integer-length
18          log2-binary-factors first-set-bit
19          logbit? bit-set?
20          copy-bit
21          bit-field
22          copy-bit-field
23          ash arithmetic-shift
24          rotate-bit-field
25          reverse-bit-field
26          integer->list
27          list->integer
28          booleans->integer))
29(select-module srfi-60)
30
31;;;
32;;; Bitwise operators
33;;;
34
35;; logand, logior, logxor, lognot, logtest - defined in gauche
36(define-inline bitwise-and logand)
37(define-inline bitwise-ior logior)
38(define-inline bitwise-xor logxor)
39(define-inline bitwise-not lognot)
40
41(define (bitwise-if mask n0 n1)
42  (logior (logand mask n0) (logand (lognot mask) n1)))
43(define bitwise-merge bitwise-if)
44
45(define-inline any-bits-set? logtest)
46
47;;;
48;;; Integer properties
49;;;
50
51;; logcount - defined in gauche
52(define-inline bit-count logcount)
53
54;; these two are the same as built-in twos-exponent-factor
55(define-inline log2-binary-factors twos-exponent-factor)
56(define-inline first-set-bit twos-exponent-factor)
57
58;;;
59;;; Bit within word
60;;;
61
62;; logbit?, copy-bit - defined in gauche
63(define-inline bit-set? logbit?)
64
65;;;
66;;; Field of bits
67;;;
68
69;; bit-field, copy-bit-field, ash - defined in gauche
70(define-inline arithmetic-shift ash)
71
72(define (rotate-bit-field n count start end)
73  (if (or (>= start end) (= count 0))
74    n                                   ; trivial path
75    (let* ([mask (logxor (- (expt 2 end) 1) (- (expt 2 start) 1))]
76           [target (logand mask n)]
77           [xcount (mod count (- end start))])
78      (logior (logand (lognot mask) n)
79              (logand mask
80                      (logior (ash target xcount)
81                              (ash target (- (- (- end start) xcount)))))))))
82
83(define (reverse-bit-field n start end)
84  (if (>= start end)
85    n                                   ; trivial path
86    (let1 mask (logxor (- (expt 2 end) 1) (- (expt 2 start) 1))
87      (let loop ([m (logand n (lognot mask))]
88                 [i start]
89                 [j (- end 1)])
90        (if (= i end)
91          m
92          (loop (copy-bit j m (logbit? i n)) (+ i 1) (- j 1)))))))
93
94;;;
95;;; Bits as booleans
96;;;
97
98(define (integer->list n :optional (len (integer-length n)))
99  (list-ec (: i (- len 1) -1 -1) (logbit? i n)))
100
101(define (list->integer lis)
102  (cond [(null? lis) 0]
103        [(<= (length lis) (integer-length (greatest-fixnum)))
104         ;; fixnum range - it's faster to calculate intermediate results
105         (fold (^(bit v) (+ v v (if bit 1 0))) 0 lis)]
106        [else
107         ;; bignum range - it's faster to create list of integers and merge
108         (apply logior
109                (fold-with-index (^(i bit ns) (if bit (cons (expt 2 i) ns) ns))
110                                 '() (reverse lis)))]))
111
112(define (booleans->integer . lis) (list->integer lis))
113
114
115