| ... |
... |
@@ -35,119 +35,161 @@ |
|
35
|
35
|
"")))
|
|
36
|
36
|
|
|
37
|
37
|
(defun write-hex-float-double (x stream)
|
|
38
|
|
- "Print a single-float or double-float in hex format onto STREAM."
|
|
39
|
|
- ;; Float type and mantissa width are derived from the type of X.
|
|
|
38
|
+ "Print a single- or double-float in hex format onto STREAM.
|
|
|
39
|
+ Float type and mantissa width are derived from the type of X."
|
|
40
|
40
|
(multiple-value-bind (mantissa-bits suffix-char min-c-exp)
|
|
41
|
41
|
(etypecase x
|
|
42
|
|
- (single-float (values 23 #\f -126))
|
|
43
|
|
- (double-float (values 52 nil -1022)))
|
|
|
42
|
+ (single-float (values (1- (float-digits 1f0)) #\f (- vm:single-float-bias)))
|
|
|
43
|
+ (double-float (values (1- (float-digits 1d0)) nil (- vm:double-float-bias))))
|
|
|
44
|
+ ;; Print the sign, but not for NaN since float-sign is unreliable there.
|
|
44
|
45
|
(when (and (not (float-nan-p x)) (minusp (float-sign x)))
|
|
45
|
46
|
(write-char #\- stream))
|
|
46
|
47
|
(let ((x (abs x)))
|
|
47
|
48
|
(cond
|
|
48
|
49
|
((float-nan-p x)
|
|
49
|
50
|
(write-string "0x0.0p+nan" stream)
|
|
50
|
|
- (when suffix-char
|
|
51
|
|
- (write-char suffix-char stream)))
|
|
|
51
|
+ (when suffix-char (write-char suffix-char stream)))
|
|
52
|
52
|
|
|
53
|
53
|
((float-infinity-p x)
|
|
54
|
54
|
(write-string "0x1.0p+inf" stream)
|
|
55
|
|
- (when suffix-char
|
|
56
|
|
- (write-char suffix-char stream)))
|
|
|
55
|
+ (when suffix-char (write-char suffix-char stream)))
|
|
57
|
56
|
|
|
58
|
57
|
((zerop x)
|
|
59
|
58
|
(write-string "0x0p+0" stream)
|
|
60
|
|
- (when suffix-char
|
|
61
|
|
- (write-char suffix-char stream)))
|
|
|
59
|
+ (when suffix-char (write-char suffix-char stream)))
|
|
62
|
60
|
|
|
63
|
61
|
(t
|
|
|
62
|
+ ;; integer-decode-float returns (significand exponent sign) where
|
|
|
63
|
+ ;; x = significand * 2^exponent. The significand has mantissa-bits+1
|
|
|
64
|
+ ;; bits for normal numbers (including the implicit leading 1 bit) and
|
|
|
65
|
+ ;; fewer for denormals, which CMUCL normalizes so that the significand
|
|
|
66
|
+ ;; always has exactly mantissa-bits+1 bits, adjusting the exponent
|
|
|
67
|
+ ;; accordingly.
|
|
64
|
68
|
(multiple-value-bind (significand exponent sign)
|
|
65
|
69
|
(integer-decode-float x)
|
|
66
|
70
|
(declare (ignore sign))
|
|
|
71
|
+ ;; c-exp is the C-style binary exponent, i.e. the exponent of the
|
|
|
72
|
+ ;; leading 1 bit. For a normal number with a (mantissa-bits+1)-bit
|
|
|
73
|
+ ;; significand, c-exp = exponent + mantissa-bits.
|
|
67
|
74
|
(let* ((c-exp (+ exponent mantissa-bits))
|
|
|
75
|
+ ;; A number is denormal if its c-exp is below the minimum
|
|
|
76
|
+ ;; normal exponent. We cannot detect this by checking the
|
|
|
77
|
+ ;; significand bit width because CMUCL normalizes denormals.
|
|
68
|
78
|
(denormalp (< c-exp min-c-exp))
|
|
|
79
|
+ ;; We print the fraction in hex, rounding up the number of
|
|
|
80
|
+ ;; mantissa bits to a multiple of 4.
|
|
69
|
81
|
(hex-digits (ceiling mantissa-bits 4))
|
|
|
82
|
+ ;; frac-shift aligns the mantissa-bits fraction bits to the
|
|
|
83
|
+ ;; hex-digits*4 grid.
|
|
70
|
84
|
(frac-shift (- (* 4 hex-digits) mantissa-bits))
|
|
|
85
|
+ ;; For a normal number, mask off the implicit leading 1 bit
|
|
|
86
|
+ ;; to get just the fraction, then shift to align to hex grid.
|
|
|
87
|
+ ;; For a denormal, the leading bit is 0 so there is nothing
|
|
|
88
|
+ ;; to mask; instead shift right to account for the reduced
|
|
|
89
|
+ ;; exponent.
|
|
71
|
90
|
(frac (if denormalp
|
|
72
|
91
|
(ash significand
|
|
73
|
92
|
(+ (- c-exp min-c-exp) frac-shift))
|
|
74
|
93
|
(ash (logand significand
|
|
75
|
94
|
(1- (ash 1 mantissa-bits)))
|
|
76
|
95
|
frac-shift)))
|
|
|
96
|
+ ;; Denormals are printed with exponent min-c-exp and a
|
|
|
97
|
+ ;; leading 0 digit rather than 1.
|
|
77
|
98
|
(out-exp (if denormalp min-c-exp c-exp))
|
|
78
|
99
|
(frac-str (trim-trailing-zeros
|
|
79
|
|
- (format nil "~v,'0X" hex-digits frac))))
|
|
|
100
|
+ (format nil "~v,'0X" hex-digits frac))))
|
|
80
|
101
|
(write-string "0x" stream)
|
|
81
|
|
- (write-char (if denormalp #\0 #\1)
|
|
82
|
|
- stream)
|
|
|
102
|
+ (write-char (if denormalp #\0 #\1) stream)
|
|
83
|
103
|
(unless (zerop (length frac-str))
|
|
84
|
104
|
(write-char #\. stream)
|
|
85
|
105
|
(write-string frac-str stream))
|
|
86
|
106
|
(write-char #\p stream)
|
|
87
|
|
- (when (>= out-exp 0)
|
|
88
|
|
- (write-char #\+ stream))
|
|
|
107
|
+ (when (>= out-exp 0) (write-char #\+ stream))
|
|
89
|
108
|
(format stream "~D" out-exp)
|
|
90
|
|
- (when suffix-char
|
|
91
|
|
- (write-char suffix-char stream)))))))
|
|
|
109
|
+ (when suffix-char (write-char suffix-char stream)))))))
|
|
92
|
110
|
(values)))
|
|
93
|
111
|
|
|
94
|
112
|
#+double-double
|
|
95
|
113
|
(defun write-hex-float-double-double (x stream)
|
|
96
|
|
- "Print a double-double-float in hex format onto STREAM."
|
|
97
|
|
- ;; Reconstructs the full significand from hi and lo components using
|
|
98
|
|
- ;; exact integer arithmetic before formatting."
|
|
|
114
|
+ "Print a double-double-float in hex format onto STREAM.
|
|
|
115
|
+ Reconstructs the full significand from hi and lo components
|
|
|
116
|
+ using exact integer arithmetic before formatting."
|
|
99
|
117
|
(let* ((hi (kernel:double-double-hi x))
|
|
100
|
|
- (lo (kernel:double-double-lo x))
|
|
101
|
|
- (hi (abs hi)))
|
|
102
|
|
- (when (minusp (float-sign (kernel:double-double-hi x)))
|
|
|
118
|
+ (lo (kernel:double-double-lo x)))
|
|
|
119
|
+ ;; Print the sign, but not for NaN since float-sign is unreliable there.
|
|
|
120
|
+ (when (and (not (float-nan-p x)) (minusp (float-sign hi)))
|
|
103
|
121
|
(write-char #\- stream))
|
|
104
|
|
- (cond
|
|
105
|
|
- ((zerop hi)
|
|
106
|
|
- (write-string "0x0p+0w" stream))
|
|
107
|
|
- (t
|
|
108
|
|
- (multiple-value-bind (sig-hi exp-hi sign-hi)
|
|
109
|
|
- (integer-decode-float hi)
|
|
110
|
|
- (declare (ignore sign-hi))
|
|
111
|
|
- (multiple-value-bind (sig-lo exp-lo sign-lo)
|
|
112
|
|
- (integer-decode-float lo)
|
|
113
|
|
- (let* ((signed-sig-lo (* sign-lo sig-lo))
|
|
114
|
|
- (combined-sig (if (zerop lo)
|
|
115
|
|
- sig-hi
|
|
116
|
|
- (+ (ash sig-hi (- exp-hi exp-lo))
|
|
117
|
|
- signed-sig-lo)))
|
|
118
|
|
- (combined-exp (if (zerop lo) exp-hi exp-lo))
|
|
119
|
|
- (total-bits (integer-length combined-sig))
|
|
120
|
|
- (c-exp (+ combined-exp total-bits -1))
|
|
121
|
|
- (min-c-exp -1022)
|
|
122
|
|
- (denormalp (< c-exp min-c-exp))
|
|
123
|
|
- (raw-frac-bits (if (zerop lo)
|
|
124
|
|
- 52
|
|
125
|
|
- (+ (- exp-hi exp-lo)
|
|
126
|
|
- 52)))
|
|
127
|
|
- (frac-bits (* 4 (ceiling raw-frac-bits 4)))
|
|
128
|
|
- (hex-digits (/ frac-bits 4))
|
|
129
|
|
- (shift (if denormalp
|
|
130
|
|
- (+ (- frac-bits (1- total-bits))
|
|
131
|
|
- (- c-exp min-c-exp))
|
|
132
|
|
- (- frac-bits (1- total-bits))))
|
|
133
|
|
- (frac (if denormalp
|
|
134
|
|
- (ash combined-sig shift)
|
|
135
|
|
- (logand (ash combined-sig shift)
|
|
136
|
|
- (1- (ash 1 frac-bits)))))
|
|
137
|
|
- (out-exp (if denormalp min-c-exp c-exp))
|
|
138
|
|
- (frac-str (trim-trailing-zeros
|
|
139
|
|
- (format nil "~v,'0X" hex-digits frac))))
|
|
140
|
|
- (write-string "0x" stream)
|
|
141
|
|
- (write-char (if denormalp #\0 #\1) stream)
|
|
142
|
|
- (unless (zerop (length frac-str))
|
|
143
|
|
- (write-char #\. stream)
|
|
144
|
|
- (write-string frac-str stream))
|
|
145
|
|
- (write-char #\p stream)
|
|
146
|
|
- (when (>= out-exp 0)
|
|
147
|
|
- (write-char #\+ stream))
|
|
148
|
|
- (format stream "~D" out-exp)
|
|
149
|
|
- (write-char #\w stream))))))
|
|
150
|
|
- (values)))
|
|
|
122
|
+ (let ((hi (abs hi)))
|
|
|
123
|
+ (cond
|
|
|
124
|
+ ((float-nan-p x)
|
|
|
125
|
+ (write-string "0x0.0p+nanw" stream))
|
|
|
126
|
+
|
|
|
127
|
+ ((float-infinity-p x)
|
|
|
128
|
+ (write-string "0x1.0p+infw" stream))
|
|
|
129
|
+
|
|
|
130
|
+ ((zerop hi)
|
|
|
131
|
+ (write-string "0x0p+0w" stream))
|
|
|
132
|
+
|
|
|
133
|
+ (t
|
|
|
134
|
+ (multiple-value-bind (sig-hi exp-hi sign-hi)
|
|
|
135
|
+ (integer-decode-float hi)
|
|
|
136
|
+ (declare (ignore sign-hi))
|
|
|
137
|
+ (multiple-value-bind (sig-lo exp-lo sign-lo)
|
|
|
138
|
+ (integer-decode-float lo)
|
|
|
139
|
+ (let* ((double-mant-bits (1- (float-digits 1d0)))
|
|
|
140
|
+ (min-c-exp (- vm:double-float-bias))
|
|
|
141
|
+ ;; Preserve the sign of lo when combining with hi.
|
|
|
142
|
+ (signed-sig-lo (* sign-lo sig-lo))
|
|
|
143
|
+ ;; Reconstruct the full integer significand by shifting
|
|
|
144
|
+ ;; sig-hi up to align with sig-lo's exponent, then adding.
|
|
|
145
|
+ ;; If lo is zero there is nothing to add.
|
|
|
146
|
+ (combined-sig (if (zerop lo)
|
|
|
147
|
+ sig-hi
|
|
|
148
|
+ (+ (ash sig-hi (- exp-hi exp-lo))
|
|
|
149
|
+ signed-sig-lo)))
|
|
|
150
|
+ ;; The combined significand is at the scale of lo's exponent
|
|
|
151
|
+ ;; (or hi's if lo is zero).
|
|
|
152
|
+ (combined-exp (if (zerop lo) exp-hi exp-lo))
|
|
|
153
|
+ (total-bits (integer-length combined-sig))
|
|
|
154
|
+ ;; c-exp is the exponent of the leading 1 bit, i.e. the
|
|
|
155
|
+ ;; C-style binary exponent.
|
|
|
156
|
+ (c-exp (+ combined-exp total-bits -1))
|
|
|
157
|
+ (denormalp (< c-exp min-c-exp))
|
|
|
158
|
+ ;; The number of fraction bits we need to print spans from
|
|
|
159
|
+ ;; the leading bit of hi down to the last bit of lo. When
|
|
|
160
|
+ ;; lo is zero we only need double-mant-bits fraction bits.
|
|
|
161
|
+ ;; We round up to a multiple of 4 for clean hex output.
|
|
|
162
|
+ (raw-frac-bits (if (zerop lo)
|
|
|
163
|
+ double-mant-bits
|
|
|
164
|
+ (+ (- exp-hi exp-lo) double-mant-bits)))
|
|
|
165
|
+ (frac-bits (* 4 (ceiling raw-frac-bits 4)))
|
|
|
166
|
+ (hex-digits (/ frac-bits 4))
|
|
|
167
|
+ ;; Shift the combined significand so the fraction bits are
|
|
|
168
|
+ ;; left-aligned in a frac-bits-wide field. For denormals,
|
|
|
169
|
+ ;; adjust the shift to account for the reduced exponent.
|
|
|
170
|
+ (shift (if denormalp
|
|
|
171
|
+ (+ (- frac-bits (1- total-bits))
|
|
|
172
|
+ (- c-exp min-c-exp))
|
|
|
173
|
+ (- frac-bits (1- total-bits))))
|
|
|
174
|
+ ;; For normal numbers mask off the leading 1 bit; for
|
|
|
175
|
+ ;; denormals the leading bit is already 0 so no mask needed.
|
|
|
176
|
+ (frac (if denormalp
|
|
|
177
|
+ (ash combined-sig shift)
|
|
|
178
|
+ (logand (ash combined-sig shift)
|
|
|
179
|
+ (1- (ash 1 frac-bits)))))
|
|
|
180
|
+ (out-exp (if denormalp min-c-exp c-exp))
|
|
|
181
|
+ (frac-str (trim-trailing-zeros
|
|
|
182
|
+ (format nil "~v,'0X" hex-digits frac))))
|
|
|
183
|
+ (write-string "0x" stream)
|
|
|
184
|
+ (write-char (if denormalp #\0 #\1) stream)
|
|
|
185
|
+ (unless (zerop (length frac-str))
|
|
|
186
|
+ (write-char #\. stream)
|
|
|
187
|
+ (write-string frac-str stream))
|
|
|
188
|
+ (write-char #\p stream)
|
|
|
189
|
+ (when (>= out-exp 0) (write-char #\+ stream))
|
|
|
190
|
+ (format stream "~D" out-exp)
|
|
|
191
|
+ (write-char #\w stream))))))
|
|
|
192
|
+ (values))))
|
|
151
|
193
|
|
|
152
|
194
|
;;; WRITE-HEX-FLOAT -- Public
|
|
153
|
195
|
;;;
|