1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
;; encode-decode-float.lisp
;; Copyright 2007 by Robert Dodier
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License.
;; This program has NO WARRANTY, not even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;; These functions encode integers into 64 bit IEEE 754 floats
;; and decode 64 bit floats into 64 bit integers.
;; These functions cannot handle any other size of float.
;;
;; Encode float-64 to integer: SMASH-FLOAT-64-INTO-INTEGER
;; Decode integer to float-64: CONSTRUCT-FLOAT-64-FROM-INTEGER
;;
;; Write float-64 to output stream: WRITE-FLOAT-64
;; Read float-64 from input stream: READ-FLOAT-64
;; Read an unsigned integer (of any size) from input stream: READ-UNSIGNED-INTEGER
;; Write an unsigned integer (of any size) to output stream: WRITE-UNSIGNED-INTEGER
;; Set assumed external byte order for input and output: DEFINE-EXTERNAL-BYTE-ORDER
(in-package :maxima)
(defun smash-float-into-integer (x)
(multiple-value-bind
(significand exponent sign)
(integer-decode-float x)
;; This logic cannot be guaranteed to work -- there is no necessary
;; correlation between IEEE 754 and CL floats. Oh well.
(if (or (typep x 'double-float) (typep x 'long-float))
(smash-decoded-float-64-into-integer significand exponent sign)
(smash-decoded-float-32-into-integer significand exponent sign))))
(defun smash-decoded-float-32-into-integer (significand exponent sign)
(if (= significand 0)
0
(dpb
(if (> sign 0) 0 1)
(byte 1 (+ 23 8))
(dpb
(+ exponent 127 23)
(byte 8 23)
(ldb
(byte 23 0)
significand)))))
(defun smash-decoded-float-64-into-integer (significand exponent sign)
(if (= significand 0)
0
(dpb
(if (> sign 0) 0 1)
(byte 1 (+ 52 11))
(dpb
(+ exponent 1023 52)
(byte 11 52)
(ldb
(byte 52 0)
significand)))))
(defun construct-float-64-from-integer (x)
(multiple-value-bind
(significand exponent sign)
(extract-smashed-float-64-from-integer x)
(* sign (scale-float (float significand 1d0) exponent))))
(defun extract-smashed-float-64-from-integer (x)
(if (eql x 0)
(values 0 0 0)
(let
((significand (dpb x (byte 52 0) #x10000000000000))
(exponent (- (ldb (byte 11 52) x) 1023 52))
(sign (if (eql (ldb (byte 1 63) x) 0) 1 -1)))
(values significand exponent sign))))
;; Stream input and output
(defun write-float (x s)
(write-unsigned-integer (smash-float-into-integer x) (size-in-bytes x) s))
(defun size-in-bytes (x)
(if (or (typep x 'double-float) (typep x 'long-float)) 8 4)) ;; AUGHHHH!! THIS IS TERRIBLE!
(defun read-float-64 (s)
(let ((x (read-unsigned-integer 8 s)))
(if (eq x 'eof) 'eof (construct-float-64-from-integer x))))
;; READ-UNSIGNED-INTEGER, WRITE-UNSIGNED-INTEGER, and associated
;; byte order stuff adapted from read-bytes-standalone.lisp,
;; by Martin Raspaud and Robert Strandh,
;; which was released under terms of GNU GPL v2 or later.
(deftype external-byte-order ()
"Defines the legal values for *EXTERNAL-BYTE-ORDER*."
'(member :msb :lsb))
(defvar *external-byte-order* :msb
"*EXTERNAL-BYTE-ORDER* must be either :msb or :lsb")
(defun define-external-byte-order (x)
(check-type x external-byte-order)
(setf *external-byte-order* x))
(defun read-unsigned-integer (nb-bytes s)
"Read an unsigned integer of size NB-BYTES bytes from input stream S."
(if (zerop nb-bytes) 0
(let (bytes (y 0))
(dotimes (i nb-bytes)
(let ((x (read-byte s nil 'eof)))
(if (eq x 'eof)
(return-from read-unsigned-integer 'eof)
(setq bytes (nconc bytes (list x))))))
(case *external-byte-order*
(:lsb
(mapc #'(lambda (x) (setq y (+ x (ash y 8)))) (nreverse bytes)))
(:msb
(mapc #'(lambda (x) (setq y (+ x (ash y 8)))) bytes)))
y)))
(defun write-unsigned-integer (quantity nb-bytes s)
"Write an unsigned integer of size NB-BYTES bytes to output stream S."
(case *external-byte-order*
(:lsb
(unless (zerop nb-bytes)
(write-byte (logand quantity #xff) s)
(write-unsigned-integer
(ash quantity -8)
(1- nb-bytes)
s)))
(:msb
(unless (zerop nb-bytes)
(write-unsigned-integer
(ash quantity -8)
(1- nb-bytes)
s)
(write-byte (logand quantity #xff) s)))))
|
