Commit | Line | Data |
---|---|---|
b01818d7 JG |
1 | ;;; fixnums.scm --- The R6RS fixnums arithmetic library |
2 | ||
a1c9ecf0 | 3 | ;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. |
b01818d7 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 fixnums (6)) | |
21 | (export fixnum? | |
22 | ||
23 | fixnum-width | |
24 | least-fixnum | |
25 | greatest-fixnum | |
26 | ||
27 | fx=? | |
28 | fx>? | |
29 | fx<? | |
30 | fx>=? | |
31 | fx<=? | |
32 | ||
33 | fxzero? | |
34 | fxpositive? | |
35 | fxnegative? | |
36 | fxodd? | |
37 | fxeven? | |
38 | ||
39 | fxmax | |
40 | fxmin | |
41 | ||
42 | fx+ | |
43 | fx* | |
44 | fx- | |
45 | ||
46 | fxdiv-and-mod | |
47 | fxdiv | |
48 | fxmod | |
49 | fxdiv0-and-mod0 | |
50 | fxdiv0 | |
51 | fxmod0 | |
52 | ||
53 | fx+/carry | |
54 | fx-/carry | |
55 | fx*/carry | |
56 | ||
8794d769 | 57 | fxnot |
b01818d7 JG |
58 | fxand |
59 | fxior | |
60 | fxxor | |
61 | fxif | |
62 | ||
63 | fxbit-count | |
64 | fxlength | |
65 | fxfirst-bit-set | |
66 | fxbit-set? | |
67 | fxcopy-bit | |
68 | fxbit-field | |
69 | fxcopy-bit-field | |
70 | ||
71 | fxarithmetic-shift | |
72 | fxarithmetic-shift-left | |
73 | fxarithmetic-shift-right | |
74 | ||
75 | fxrotate-bit-field | |
76 | fxreverse-bit-field) | |
8794d769 JG |
77 | (import (only (guile) ash |
78 | cons* | |
b1e13fb5 | 79 | define-inlinable |
8794d769 JG |
80 | inexact->exact |
81 | logand | |
82 | logbit? | |
83 | logcount | |
84 | logior | |
85 | lognot | |
86 | logxor | |
87 | most-positive-fixnum | |
b1e13fb5 AR |
88 | most-negative-fixnum |
89 | object-address) | |
b01818d7 JG |
90 | (ice-9 optargs) |
91 | (rnrs base (6)) | |
78d1be4a | 92 | (rnrs control (6)) |
b01818d7 JG |
93 | (rnrs arithmetic bitwise (6)) |
94 | (rnrs conditions (6)) | |
8794d769 JG |
95 | (rnrs exceptions (6)) |
96 | (rnrs lists (6))) | |
b01818d7 | 97 | |
8794d769 | 98 | (define fixnum-width |
23988e8c | 99 | (let ((w (inexact->exact (round (/ (log (+ most-positive-fixnum 1)) (log 2)))))) |
8794d769 JG |
100 | (lambda () w))) |
101 | ||
102 | (define (greatest-fixnum) most-positive-fixnum) | |
103 | (define (least-fixnum) most-negative-fixnum) | |
b1e13fb5 | 104 | |
9d6a151f AW |
105 | (define (fixnum? obj) |
106 | (not (= 0 (logand 2 (object-address obj))))) | |
107 | ||
108 | (define-inlinable (inline-fixnum? obj) | |
b1e13fb5 | 109 | (not (= 0 (logand 2 (object-address obj))))) |
b01818d7 | 110 | |
78d1be4a AR |
111 | (define-syntax assert-fixnum |
112 | (syntax-rules () | |
113 | ((_ arg ...) | |
9d6a151f | 114 | (or (and (inline-fixnum? arg) ...) |
78d1be4a AR |
115 | (raise (make-assertion-violation)))))) |
116 | ||
117 | (define (assert-fixnums args) | |
9d6a151f | 118 | (or (for-all inline-fixnum? args) (raise (make-assertion-violation)))) |
b01818d7 | 119 | |
78d1be4a AR |
120 | (define-syntax define-fxop* |
121 | (syntax-rules () | |
122 | ((_ name op) | |
123 | (define name | |
124 | (case-lambda | |
125 | ((x y) | |
126 | (assert-fixnum x y) | |
127 | (op x y)) | |
128 | (args | |
129 | (assert-fixnums args) | |
130 | (apply op args))))))) | |
131 | ||
132 | ;; All these predicates don't check their arguments for fixnum-ness, | |
133 | ;; as this doesn't seem to be strictly required by R6RS. | |
134 | ||
135 | (define fx=? =) | |
136 | (define fx>? >) | |
137 | (define fx<? <) | |
138 | (define fx>=? >=) | |
139 | (define fx<=? <=) | |
140 | ||
141 | (define fxzero? zero?) | |
142 | (define fxpositive? positive?) | |
143 | (define fxnegative? negative?) | |
144 | (define fxodd? odd?) | |
145 | (define fxeven? even?) | |
146 | ||
147 | (define-fxop* fxmax max) | |
148 | (define-fxop* fxmin min) | |
149 | ||
b01818d7 | 150 | (define (fx+ fx1 fx2) |
8794d769 JG |
151 | (assert-fixnum fx1 fx2) |
152 | (let ((r (+ fx1 fx2))) | |
9d6a151f AW |
153 | (or (inline-fixnum? r) |
154 | (raise (make-implementation-restriction-violation))) | |
8794d769 | 155 | r)) |
b01818d7 JG |
156 | |
157 | (define (fx* fx1 fx2) | |
8794d769 JG |
158 | (assert-fixnum fx1 fx2) |
159 | (let ((r (* fx1 fx2))) | |
9d6a151f AW |
160 | (or (inline-fixnum? r) |
161 | (raise (make-implementation-restriction-violation))) | |
8794d769 | 162 | r)) |
b01818d7 JG |
163 | |
164 | (define* (fx- fx1 #:optional fx2) | |
165 | (assert-fixnum fx1) | |
166 | (if fx2 | |
167 | (begin | |
168 | (assert-fixnum fx2) | |
8794d769 | 169 | (let ((r (- fx1 fx2))) |
9d6a151f | 170 | (or (inline-fixnum? r) (raise (make-assertion-violation))) |
8794d769 JG |
171 | r)) |
172 | (let ((r (- fx1))) | |
9d6a151f | 173 | (or (inline-fixnum? r) (raise (make-assertion-violation))) |
8794d769 JG |
174 | r))) |
175 | ||
176 | (define (fxdiv fx1 fx2) | |
177 | (assert-fixnum fx1 fx2) | |
ff62c168 | 178 | (div fx1 fx2)) |
b01818d7 | 179 | |
8794d769 JG |
180 | (define (fxmod fx1 fx2) |
181 | (assert-fixnum fx1 fx2) | |
ff62c168 | 182 | (mod fx1 fx2)) |
b01818d7 JG |
183 | |
184 | (define (fxdiv-and-mod fx1 fx2) | |
185 | (assert-fixnum fx1 fx2) | |
8794d769 | 186 | (div-and-mod fx1 fx2)) |
b01818d7 JG |
187 | |
188 | (define (fxdiv0 fx1 fx2) | |
189 | (assert-fixnum fx1 fx2) | |
ff62c168 | 190 | (div0 fx1 fx2)) |
b01818d7 JG |
191 | |
192 | (define (fxmod0 fx1 fx2) | |
193 | (assert-fixnum fx1 fx2) | |
ff62c168 | 194 | (mod0 fx1 fx2)) |
b01818d7 JG |
195 | |
196 | (define (fxdiv0-and-mod0 fx1 fx2) | |
197 | (assert-fixnum fx1 fx2) | |
ff62c168 | 198 | (div0-and-mod0 fx1 fx2)) |
b01818d7 JG |
199 | |
200 | (define (fx+/carry fx1 fx2 fx3) | |
201 | (assert-fixnum fx1 fx2 fx3) | |
202 | (let* ((s (+ fx1 fx2 fx3)) | |
ff62c168 MW |
203 | (s0 (mod0 s (expt 2 (fixnum-width)))) |
204 | (s1 (div0 s (expt 2 (fixnum-width))))) | |
b01818d7 JG |
205 | (values s0 s1))) |
206 | ||
207 | (define (fx-/carry fx1 fx2 fx3) | |
208 | (assert-fixnum fx1 fx2 fx3) | |
209 | (let* ((d (- fx1 fx2 fx3)) | |
210 | (d0 (mod0 d (expt 2 (fixnum-width)))) | |
211 | (d1 (div0 d (expt 2 (fixnum-width))))) | |
212 | (values d0 d1))) | |
213 | ||
214 | (define (fx*/carry fx1 fx2 fx3) | |
215 | (assert-fixnum fx1 fx2 fx3) | |
216 | (let* ((s (+ (* fx1 fx2) fx3)) | |
217 | (s0 (mod0 s (expt 2 (fixnum-width)))) | |
218 | (s1 (div0 s (expt 2 (fixnum-width))))) | |
219 | (values s0 s1))) | |
220 | ||
221 | (define (fxnot fx) (assert-fixnum fx) (lognot fx)) | |
78d1be4a AR |
222 | (define-fxop* fxand logand) |
223 | (define-fxop* fxior logior) | |
224 | (define-fxop* fxxor logxor) | |
b01818d7 JG |
225 | |
226 | (define (fxif fx1 fx2 fx3) | |
227 | (assert-fixnum fx1 fx2 fx3) | |
8794d769 | 228 | (bitwise-if fx1 fx2 fx3)) |
b01818d7 | 229 | |
a1c9ecf0 MW |
230 | (define (fxbit-count fx) |
231 | (assert-fixnum fx) | |
232 | (if (negative? fx) | |
233 | (bitwise-not (logcount fx)) | |
234 | (logcount fx))) | |
235 | ||
b01818d7 JG |
236 | (define (fxlength fx) (assert-fixnum fx) (bitwise-length fx)) |
237 | (define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx)) | |
8794d769 | 238 | (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1)) |
b01818d7 JG |
239 | |
240 | (define (fxcopy-bit fx1 fx2 fx3) | |
241 | (assert-fixnum fx1 fx2 fx3) | |
242 | (bitwise-copy-bit fx1 fx2 fx3)) | |
243 | ||
244 | (define (fxbit-field fx1 fx2 fx3) | |
245 | (assert-fixnum fx1 fx2 fx3) | |
246 | (bitwise-bit-field fx1 fx2 fx3)) | |
247 | ||
248 | (define (fxcopy-bit-field fx1 fx2 fx3 fx4) | |
249 | (assert-fixnum fx1 fx2 fx3 fx4) | |
250 | (bitwise-copy-bit-field fx1 fx2 fx3 fx4)) | |
251 | ||
252 | (define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2)) | |
253 | (define fxarithmetic-shift-left fxarithmetic-shift) | |
254 | ||
255 | (define (fxarithmetic-shift-right fx1 fx2) | |
8794d769 | 256 | (assert-fixnum fx1 fx2) (ash fx1 (- fx2))) |
b01818d7 JG |
257 | |
258 | (define (fxrotate-bit-field fx1 fx2 fx3 fx4) | |
259 | (assert-fixnum fx1 fx2 fx3 fx4) | |
260 | (bitwise-rotate-bit-field fx1 fx2 fx3 fx4)) | |
261 | ||
262 | (define (fxreverse-bit-field fx1 fx2 fx3) | |
263 | (assert-fixnum fx1 fx2 fx3) | |
264 | (bitwise-reverse-bit-field fx1 fx2 fx3)) | |
265 | ||
266 | ) |