Commit | Line | Data |
---|---|---|
2a435f1f JG |
1 | ;;; bitwise.scm --- The R6RS bitwise arithmetic operations library |
2 | ||
1f4f2a12 | 3 | ;; Copyright (C) 2010, 2013 Free Software Foundation, Inc. |
2a435f1f JG |
4 | ;; |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 3 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library is distributed in the hope that it will be useful, | |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | \f | |
19 | ||
20 | (library (rnrs arithmetic bitwise (6)) | |
21 | (export bitwise-not | |
22 | ||
23 | bitwise-and | |
24 | bitwise-ior | |
25 | bitwise-xor | |
26 | ||
27 | bitwise-if | |
28 | bitwise-bit-count | |
29 | bitwise-length | |
30 | ||
31 | bitwise-first-bit-set | |
32 | bitwise-bit-set? | |
33 | bitwise-copy-bit | |
34 | bitwise-bit-field | |
35 | bitwise-copy-bit-field | |
36 | ||
37 | bitwise-arithmetic-shift | |
38 | bitwise-arithmetic-shift-left | |
39 | bitwise-arithmetic-shift-right | |
40 | bitwise-rotate-bit-field | |
41 | bitwise-reverse-bit-field) | |
42 | (import (rnrs base (6)) | |
aa439b39 | 43 | (rnrs control (6)) |
2a435f1f JG |
44 | (rename (only (guile) lognot |
45 | logand | |
46 | logior | |
47 | logxor | |
48 | logcount | |
aa439b39 JG |
49 | logbit? |
50 | modulo | |
2a435f1f JG |
51 | ash) |
52 | (lognot bitwise-not) | |
53 | (logand bitwise-and) | |
54 | (logior bitwise-ior) | |
55 | (logxor bitwise-xor) | |
2a435f1f JG |
56 | (ash bitwise-arithmetic-shift))) |
57 | ||
e8f32997 MW |
58 | (define (bitwise-bit-count ei) |
59 | (if (negative? ei) | |
60 | (bitwise-not (logcount ei)) | |
61 | (logcount ei))) | |
62 | ||
2a435f1f JG |
63 | (define (bitwise-if ei1 ei2 ei3) |
64 | (bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3))) | |
65 | ||
66 | (define (bitwise-length ei) | |
67 | (do ((result 0 (+ result 1)) | |
68 | (bits (if (negative? ei) (bitwise-not ei) ei) | |
69 | (bitwise-arithmetic-shift bits -1))) | |
70 | ((zero? bits) | |
71 | result))) | |
72 | ||
73 | (define (bitwise-first-bit-set ei) | |
74 | (define (bitwise-first-bit-set-inner bits count) | |
75 | (cond ((zero? bits) -1) | |
76 | ((logbit? 0 bits) count) | |
77 | (else (bitwise-first-bit-set-inner | |
78 | (bitwise-arithmetic-shift bits -1) (+ count 1))))) | |
79 | (bitwise-first-bit-set-inner ei 0)) | |
80 | ||
81 | (define (bitwise-bit-set? ei1 ei2) (logbit? ei2 ei1)) | |
82 | ||
83 | (define (bitwise-copy-bit ei1 ei2 ei3) | |
84 | (bitwise-if (bitwise-arithmetic-shift-left 1 ei2) | |
85 | (bitwise-arithmetic-shift-left ei3 ei2) | |
86 | ei1)) | |
87 | ||
88 | (define (bitwise-bit-field ei1 ei2 ei3) | |
89 | (bitwise-arithmetic-shift-right | |
90 | (bitwise-and ei1 (bitwise-not (bitwise-arithmetic-shift-left -1 ei3))) | |
91 | ei2)) | |
92 | ||
93 | (define (bitwise-copy-bit-field ei1 ei2 ei3 ei4) | |
94 | (bitwise-if (bitwise-and (bitwise-arithmetic-shift-left -1 ei2) | |
95 | (bitwise-not | |
96 | (bitwise-arithmetic-shift-left -1 ei3))) | |
97 | (bitwise-arithmetic-shift-left ei4 ei2) | |
98 | ei1)) | |
99 | ||
100 | (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift) | |
101 | (define (bitwise-arithmetic-shift-right ei1 ei2) | |
102 | (bitwise-arithmetic-shift ei1 (- ei2))) | |
103 | ||
104 | (define (bitwise-rotate-bit-field ei1 ei2 ei3 ei4) | |
105 | (let ((width (- ei3 ei2))) | |
106 | (if (positive? width) | |
107 | (let ((field (bitwise-bit-field ei1 ei2 ei3)) | |
108 | (count (modulo ei4 width))) | |
109 | (bitwise-copy-bit-field | |
110 | ei1 ei2 ei3 | |
111 | (bitwise-ior (bitwise-arithmetic-shift-left field count) | |
112 | (bitwise-arithmetic-shift-right | |
113 | field (- width count))))) | |
114 | ei1))) | |
115 | ||
116 | (define (bitwise-reverse-bit-field ei1 ei2 ei3) | |
117 | (define (reverse-bit-field-recursive n1 n2 len) | |
118 | (if (> len 0) | |
119 | (reverse-bit-field-recursive | |
120 | (bitwise-arithmetic-shift-right n1 1) | |
121 | (bitwise-copy-bit (bitwise-arithmetic-shift-left n2 1) 0 n1) | |
122 | (- len 1)) | |
123 | n2)) | |
124 | (let ((width (- ei3 ei2))) | |
125 | (if (positive? width) | |
126 | (let ((field (bitwise-bit-field ei1 ei2 ei3))) | |
127 | (bitwise-copy-bit-field | |
128 | ei1 ei2 ei3 (reverse-bit-field-recursive field 0 width))) | |
129 | ei1)))) |