/[slib]/slib/bytenumb.scm
ViewVC logotype

Contents of /slib/bytenumb.scm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations) (download)
Fri Jan 18 03:20:33 2013 UTC (11 years, 2 months ago) by jaffer
Branch: MAIN
CVS Tags: slib-3b6, slib-3b7, slib-3b4, slib-3b5, slib-3c1, HEAD
Changes since 1.16: +1 -0 lines
(bytes->ieee-double): Added test case for DBL_MAX.

1 ;;; "bytenumb.scm" Byte integer and IEEE floating-point conversions.
2 ; Copyright (C) 2003 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 (require 'byte)
21 (require 'logical)
22
23 ;;@code{(require 'byte-number)}
24 ;;@ftindex byte-number
25
26 ;;@noindent
27 ;;The multi-byte sequences produced and used by numeric conversion
28 ;;routines are always big-endian. Endianness can be changed during
29 ;;reading and writing bytes using @code{read-bytes} and
30 ;;@code{write-bytes} @xref{Byte, read-bytes}.
31 ;;
32 ;;@noindent
33 ;;The sign of the length argument to bytes/integer conversion
34 ;;procedures determines the signedness of the number.
35
36 ;;@body
37 ;;Converts the first @code{(abs @var{n})} bytes of big-endian @1 array
38 ;;to an integer. If @2 is negative then the integer coded by the
39 ;;bytes are treated as two's-complement (can be negative).
40 ;;
41 ;;@example
42 ;;(bytes->integer (bytes 0 0 0 15) -4) @result{} 15
43 ;;(bytes->integer (bytes 0 0 0 15) 4) @result{} 15
44 ;;(bytes->integer (bytes 255 255 255 255) -4) @result{} -1
45 ;;(bytes->integer (bytes 255 255 255 255) 4) @result{} 4294967295
46 ;;(bytes->integer (bytes 128 0 0 0) -4) @result{} -2147483648
47 ;;(bytes->integer (bytes 128 0 0 0) 4) @result{} 2147483648
48 ;;@end example
49 (define (bytes->integer bytes n)
50 (define cnt (abs n))
51 (cond ((zero? n) 0)
52 ((and (negative? n) (> (byte-ref bytes 0) 127))
53 (do ((lng (- 255 (byte-ref bytes 0))
54 (+ (- 255 (byte-ref bytes idx)) (* 256 lng)))
55 (idx 1 (+ 1 idx)))
56 ((>= idx cnt) (- -1 lng))))
57 (else
58 (do ((lng (byte-ref bytes 0)
59 (+ (byte-ref bytes idx) (* 256 lng)))
60 (idx 1 (+ 1 idx)))
61 ((>= idx cnt) lng)))))
62
63 ;;@body
64 ;;Converts the integer @1 to a byte-array of @code{(abs @var{n})}
65 ;;bytes. If @1 and @2 are both negative, then the bytes in the
66 ;;returned array are coded two's-complement.
67 ;;
68 ;;@example
69 ;;(bytes->list (integer->bytes 15 -4)) @result{} (0 0 0 15)
70 ;;(bytes->list (integer->bytes 15 4)) @result{} (0 0 0 15)
71 ;;(bytes->list (integer->bytes -1 -4)) @result{} (255 255 255 255)
72 ;;(bytes->list (integer->bytes 4294967295 4)) @result{} (255 255 255 255)
73 ;;(bytes->list (integer->bytes -2147483648 -4)) @result{} (128 0 0 0)
74 ;;(bytes->list (integer->bytes 2147483648 4)) @result{} (128 0 0 0)
75 ;;@end example
76 (define (integer->bytes n len)
77 (define bytes (make-bytes (abs len)))
78 (cond ((and (negative? n) (negative? len))
79 (do ((idx (+ -1 (abs len)) (+ -1 idx))
80 (res (- -1 n) (quotient res 256)))
81 ((negative? idx) bytes)
82 (byte-set! bytes idx (- 255 (modulo res 256)))))
83 (else
84 (do ((idx (+ -1 (abs len)) (+ -1 idx))
85 (res n (quotient res 256)))
86 ((negative? idx) bytes)
87 (byte-set! bytes idx (modulo res 256))))))
88
89 ;;@body
90 ;;@1 must be a 4-element byte-array. @0 calculates and returns the
91 ;;value of @1 interpreted as a big-endian IEEE 4-byte (32-bit) number.
92 (define (bytes->ieee-float bytes)
93 (define zero (or (string->number "0.0") 0))
94 (define one (or (string->number "1.0") 1))
95 (define len (bytes-length bytes))
96 (define S (logbit? 7 (byte-ref bytes 0)))
97 (define E (+ (ash (logand #x7F (byte-ref bytes 0)) 1)
98 (ash (logand #x80 (byte-ref bytes 1)) -7)))
99 (if (not (eqv? 4 len))
100 (slib:error 'bytes->ieee-float 'wrong 'length len))
101 (do ((F (byte-ref bytes (+ -1 len))
102 (+ (byte-ref bytes idx) (/ F 256)))
103 (idx (+ -2 len) (+ -1 idx)))
104 ((<= idx 1)
105 (set! F (/ (+ (logand #x7F (byte-ref bytes 1)) (/ F 256)) 128))
106 (cond ((< 0 E 255) (* (if S (- one) one) (expt 2 (- E 127)) (+ 1 F)))
107 ((zero? E)
108 (if (zero? F)
109 (if S (- zero) zero)
110 (* (if S (- one) one) (expt 2 -126) F)))
111 ;; E must be 255
112 ((not (zero? F)) (/ zero zero))
113 (else (/ (if S (- one) one) zero))))))
114
115 ;; S EEEEEEE E FFFFFFF FFFFFFFF FFFFFFFF
116 ;; ========= ========= ======== ========
117 ;; 0 1 8 9 31
118
119 ;;@example
120 ;;(bytes->ieee-float (bytes 0 0 0 0)) @result{} 0.0
121 ;;(bytes->ieee-float (bytes #x80 0 0 0)) @result{} -0.0
122 ;;(bytes->ieee-float (bytes #x40 0 0 0)) @result{} 2.0
123 ;;(bytes->ieee-float (bytes #x40 #xd0 0 0)) @result{} 6.5
124 ;;(bytes->ieee-float (bytes #xc0 #xd0 0 0)) @result{} -6.5
125 ;;
126 ;;(bytes->ieee-float (bytes 0 #x80 0 0)) @result{} 11.754943508222875e-39
127 ;;(bytes->ieee-float (bytes 0 #x40 0 0)) @result{} 5.877471754111437e-39
128 ;;(bytes->ieee-float (bytes 0 0 0 1)) @result{} 1.401298464324817e-45
129 ;;
130 ;;(bytes->ieee-float (bytes #xff #x80 0 0)) @result{} -inf.0
131 ;;(bytes->ieee-float (bytes #x7f #x80 0 0)) @result{} +inf.0
132 ;;(bytes->ieee-float (bytes #x7f #x80 0 1)) @result{} 0/0
133 ;;(bytes->ieee-float (bytes #x7f #xc0 0 0)) @result{} 0/0
134 ;;@end example
135
136 ;;@body
137 ;;@1 must be a 8-element byte-array. @0 calculates and returns the
138 ;;value of @1 interpreted as a big-endian IEEE 8-byte (64-bit) number.
139 (define (bytes->ieee-double bytes)
140 (define zero (or (string->number "0.0") 0))
141 (define one (or (string->number "1.0") 1))
142 (define len (bytes-length bytes))
143 (define S (logbit? 7 (byte-ref bytes 0)))
144 (define E (+ (ash (logand #x7F (byte-ref bytes 0)) 4)
145 (ash (logand #xF0 (byte-ref bytes 1)) -4)))
146 (if (not (eqv? 8 len))
147 (slib:error 'bytes->ieee-double 'wrong 'length len))
148 (do ((F (byte-ref bytes (+ -1 len))
149 (+ (byte-ref bytes idx) (/ F 256)))
150 (idx (+ -2 len) (+ -1 idx)))
151 ((<= idx 1)
152 (set! F (/ (+ (logand #x0F (byte-ref bytes 1)) (/ F 256)) 16))
153 (cond ((< 0 E 2047) (* (if S (- one) one) (expt 2 (- E 1023)) (+ 1 F)))
154 ((zero? E)
155 (if (zero? F)
156 (if S (- zero) zero)
157 (* (if S (- one) one) (expt 2 -1022) F)))
158 ;; E must be 2047
159 ((not (zero? F)) (/ zero zero))
160 (else (/ (if S (- one) one) zero))))))
161
162 ;; S EEEEEEE EEEE FFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF FFFFFFFF
163 ;; ========= ========= ======== ======== ======== ======== ======== ========
164 ;; 0 1 11 12 63
165
166 ;;@example
167 ;;(bytes->ieee-double (bytes 0 0 0 0 0 0 0 0)) @result{} 0.0
168 ;;(bytes->ieee-double (bytes #x80 0 0 0 0 0 0 0)) @result{} -0.0
169 ;;(bytes->ieee-double (bytes #x40 0 0 0 0 0 0 0)) @result{} 2.0
170 ;;(bytes->ieee-double (bytes #x40 #x1A 0 0 0 0 0 0)) @result{} 6.5
171 ;;(bytes->ieee-double (bytes #xC0 #x1A 0 0 0 0 0 0)) @result{} -6.5
172 ;;
173 ;;(bytes->ieee-double (bytes 0 8 0 0 0 0 0 0)) @result{} 11.125369292536006e-309
174 ;;(bytes->ieee-double (bytes 0 4 0 0 0 0 0 0)) @result{} 5.562684646268003e-309
175 ;;(bytes->ieee-double (bytes 0 0 0 0 0 0 0 1)) @result{} 4.0e-324
176 ;;
177 ;;(bytes->ieee-double (list->bytes '(127 239 255 255 255 255 255 255))) 179.76931348623157e306
178 ;;(bytes->ieee-double (bytes #xFF #xF0 0 0 0 0 0 0)) @result{} -inf.0
179 ;;(bytes->ieee-double (bytes #x7F #xF0 0 0 0 0 0 0)) @result{} +inf.0
180 ;;(bytes->ieee-double (bytes #x7F #xF8 0 0 0 0 0 0)) @result{} 0/0
181 ;;@end example
182
183 ;;@args x
184 ;;Returns a 4-element byte-array encoding the IEEE single-precision
185 ;;floating-point of @1.
186 (define ieee-float->bytes
187 (let ((exactify (if (provided? 'inexact) inexact->exact identity)))
188 (lambda (flt)
189 (define byts (make-bytes 4 0))
190 (define S (and (real? flt) (negative? (if (zero? flt) (/ flt) flt))))
191 (define (scale flt scl)
192 (cond ((zero? scl) (out (/ flt 2) scl))
193 ((>= flt 16)
194 (let ((flt/16 (/ flt 16)))
195 (cond ((= flt/16 flt)
196 (byte-set! byts 0 (if S #xFF #x7F))
197 (byte-set! byts 1 #x80)
198 byts)
199 (else (scale flt/16 (+ scl 4))))))
200 ((>= flt 2) (scale (/ flt 2) (+ scl 1)))
201 ((and (>= scl 4)
202 (< (* 16 flt) 1)) (scale (* flt 16) (+ scl -4)))
203 ((< flt 1) (scale (* flt 2) (+ scl -1)))
204 (else (out (+ -1 flt) scl))))
205 (define (out flt scl)
206 (do ((flt (* 128 flt) (* 256 (- flt val)))
207 (val (exactify (floor (* 128 flt)))
208 (exactify (floor (* 256 (- flt val)))))
209 (idx 1 (+ 1 idx)))
210 ((> idx 3)
211 (byte-set! byts 1 (bitwise-if #x80 (ash scl 7) (byte-ref byts 1)))
212 (byte-set! byts 0 (+ (if S 128 0) (ash scl -1)))
213 byts)
214 (byte-set! byts idx val)))
215 (set! flt (magnitude flt))
216 (cond ((zero? flt) (if S (byte-set! byts 0 #x80)) byts)
217 ((or (not (real? flt))
218 (not (= flt flt)))
219 (byte-set! byts 0 (if S #xFF #x7F))
220 (byte-set! byts 1 #xC0)
221 byts)
222 (else (scale flt 127))))))
223 ;;@example
224 ;;(bytes->list (ieee-float->bytes 0.0)) @result{} (0 0 0 0)
225 ;;(bytes->list (ieee-float->bytes -0.0)) @result{} (128 0 0 0)
226 ;;(bytes->list (ieee-float->bytes 2.0)) @result{} (64 0 0 0)
227 ;;(bytes->list (ieee-float->bytes 6.5)) @result{} (64 208 0 0)
228 ;;(bytes->list (ieee-float->bytes -6.5)) @result{} (192 208 0 0)
229 ;;
230 ;;(bytes->list (ieee-float->bytes 11.754943508222875e-39)) @result{} ( 0 128 0 0)
231 ;;(bytes->list (ieee-float->bytes 5.877471754111438e-39)) @result{} ( 0 64 0 0)
232 ;;(bytes->list (ieee-float->bytes 1.401298464324817e-45)) @result{} ( 0 0 0 1)
233 ;;
234 ;;(bytes->list (ieee-float->bytes -inf.0)) @result{} (255 128 0 0)
235 ;;(bytes->list (ieee-float->bytes +inf.0)) @result{} (127 128 0 0)
236 ;;(bytes->list (ieee-float->bytes 0/0)) @result{} (127 192 0 0)
237 ;;@end example
238
239
240 ;;@args x
241 ;;Returns a 8-element byte-array encoding the IEEE double-precision
242 ;;floating-point of @1.
243 (define ieee-double->bytes
244 (let ((exactify (if (provided? 'inexact) inexact->exact identity)))
245 (lambda (flt)
246 (define byts (make-bytes 8 0))
247 (define S (and (real? flt) (negative? (if (zero? flt) (/ flt) flt))))
248 (define (scale flt scl)
249 (cond ((zero? scl) (out (/ flt 2) scl))
250 ((>= flt 16)
251 (let ((flt/16 (/ flt 16)))
252 (cond ((= flt/16 flt)
253 (byte-set! byts 0 (if S #xFF #x7F))
254 (byte-set! byts 1 #xF0)
255 byts)
256 (else (scale flt/16 (+ scl 4))))))
257 ((>= flt 2) (scale (/ flt 2) (+ scl 1)))
258 ((and (>= scl 4)
259 (< (* 16 flt) 1)) (scale (* flt 16) (+ scl -4)))
260 ((< flt 1) (scale (* flt 2) (+ scl -1)))
261 (else (out (+ -1 flt) scl))))
262 (define (out flt scl)
263 (do ((flt (* 16 flt) (* 256 (- flt val)))
264 (val (exactify (floor (* 16 flt)))
265 (exactify (floor (* 256 (- flt val)))))
266 (idx 1 (+ 1 idx)))
267 ((> idx 7)
268 (byte-set! byts 1 (bitwise-if #xF0 (ash scl 4) (byte-ref byts 1)))
269 (byte-set! byts 0 (+ (if S 128 0) (ash scl -4)))
270 byts)
271 (byte-set! byts idx val)))
272 (set! flt (magnitude flt))
273 (cond ((zero? flt) (if S (byte-set! byts 0 #x80)) byts)
274 ((or (not (real? flt))
275 (not (= flt flt)))
276 (byte-set! byts 0 #x7F)
277 (byte-set! byts 1 #xF8)
278 byts)
279 (else (scale flt 1023))))))
280 ;;@example
281 ;;(bytes->list (ieee-double->bytes 0.0)) @result{} (0 0 0 0 0 0 0 0)
282 ;;(bytes->list (ieee-double->bytes -0.0)) @result{} (128 0 0 0 0 0 0 0)
283 ;;(bytes->list (ieee-double->bytes 2.0)) @result{} (64 0 0 0 0 0 0 0)
284 ;;(bytes->list (ieee-double->bytes 6.5)) @result{} (64 26 0 0 0 0 0 0)
285 ;;(bytes->list (ieee-double->bytes -6.5)) @result{} (192 26 0 0 0 0 0 0)
286 ;;
287 ;;(bytes->list (ieee-double->bytes 11.125369292536006e-309))
288 ;; @result{} ( 0 8 0 0 0 0 0 0)
289 ;;(bytes->list (ieee-double->bytes 5.562684646268003e-309))
290 ;; @result{} ( 0 4 0 0 0 0 0 0)
291 ;;(bytes->list (ieee-double->bytes 4.0e-324))
292 ;; @result{} ( 0 0 0 0 0 0 0 1)
293 ;;
294 ;;(bytes->list (ieee-double->bytes -inf.0)) @result{} (255 240 0 0 0 0 0 0)
295 ;;(bytes->list (ieee-double->bytes +inf.0)) @result{} (127 240 0 0 0 0 0 0)
296 ;;(bytes->list (ieee-double->bytes 0/0)) @result{} (127 248 0 0 0 0 0 0)
297 ;;@end example
298
299 ;;@subsubheading Byte Collation Order
300 ;;
301 ;;@noindent
302 ;;The @code{string<?} ordering of big-endian byte-array
303 ;;representations of fixed and IEEE floating-point numbers agrees with
304 ;;the numerical ordering only when those numbers are non-negative.
305 ;;
306 ;;@noindent
307 ;;Straighforward modification of these formats can extend the
308 ;;byte-collating order to work for their entire ranges. This
309 ;;agreement enables the full range of numbers as keys in
310 ;;@dfn{indexed-sequential-access-method} databases.
311
312 ;;@body
313 ;;Modifies sign bit of @1 so that @code{string<?} ordering of
314 ;;two's-complement byte-vectors matches numerical order. @0 returns
315 ;;@1 and is its own functional inverse.
316 (define (integer-byte-collate! byte-vector)
317 (byte-set! byte-vector 0 (logxor #x80 (byte-ref byte-vector 0)))
318 byte-vector)
319
320 ;;@body
321 ;;Returns copy of @1 with sign bit modified so that @code{string<?}
322 ;;ordering of two's-complement byte-vectors matches numerical order.
323 ;;@0 is its own functional inverse.
324 (define (integer-byte-collate byte-vector)
325 (integer-byte-collate! (bytes-copy byte-vector)))
326
327 ;;@body
328 ;;Modifies @1 so that @code{string<?} ordering of IEEE floating-point
329 ;;byte-vectors matches numerical order. @0 returns @1.
330 (define (ieee-byte-collate! byte-vector)
331 (cond ((logtest #x80 (byte-ref byte-vector 0))
332 (do ((idx (+ -1 (bytes-length byte-vector)) (+ -1 idx)))
333 ((negative? idx))
334 (byte-set! byte-vector idx
335 (logxor #xFF (byte-ref byte-vector idx)))))
336 (else
337 (byte-set! byte-vector 0 (logxor #x80 (byte-ref byte-vector 0)))))
338 byte-vector)
339 ;;@body
340 ;;Given @1 modified by @code{ieee-byte-collate!}, reverses the @1
341 ;;modifications.
342 (define (ieee-byte-decollate! byte-vector)
343 (cond ((not (logtest #x80 (byte-ref byte-vector 0)))
344 (do ((idx (+ -1 (bytes-length byte-vector)) (+ -1 idx)))
345 ((negative? idx))
346 (byte-set! byte-vector idx
347 (logxor #xFF (byte-ref byte-vector idx)))))
348 (else
349 (byte-set! byte-vector 0 (logxor #x80 (byte-ref byte-vector 0)))))
350 byte-vector)
351
352 ;;@body
353 ;;Returns copy of @1 encoded so that @code{string<?} ordering of IEEE
354 ;;floating-point byte-vectors matches numerical order.
355 (define (ieee-byte-collate byte-vector)
356 (ieee-byte-collate! (bytes-copy byte-vector)))
357 ;;@body
358 ;;Given @1 returned by @code{ieee-byte-collate}, reverses the @1
359 ;;modifications.
360 (define (ieee-byte-decollate byte-vector)
361 (ieee-byte-decollate! (bytes-copy byte-vector)))

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26