1.0.48.6: %SIMPLE-EVAL and backtraces
[sbcl.git] / src / code / early-float.lisp
1 ;;;; This file contains the definitions of float-specific number
2 ;;;; support (other than irrational stuff, which is in irrat.) There is
3 ;;;; code in here that assumes there are only two float formats: IEEE
4 ;;;; single and double. (LONG-FLOAT support has been added, but bugs
5 ;;;; may still remain due to old code which assumes this dichotomy.)
6
7 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; more information.
9 ;;;;
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
15
16 (in-package "SB!KERNEL")
17 \f
18 ;;;; utilities
19
20 (eval-when (:compile-toplevel :load-toplevel :execute)
21
22 ;;; These functions let us create floats from bits with the
23 ;;; significand uniformly represented as an integer. This is less
24 ;;; efficient for double floats, but is more convenient when making
25 ;;; special values, etc.
26 (defun single-from-bits (sign exp sig)
27   (declare (type bit sign) (type (unsigned-byte 24) sig)
28            (type (unsigned-byte 8) exp))
29   (make-single-float
30    (dpb exp sb!vm:single-float-exponent-byte
31         (dpb sig sb!vm:single-float-significand-byte
32              (if (zerop sign) 0 -1)))))
33 (defun double-from-bits (sign exp sig)
34   (declare (type bit sign) (type (unsigned-byte 53) sig)
35            (type (unsigned-byte 11) exp))
36   (make-double-float (dpb exp sb!vm:double-float-exponent-byte
37                           (dpb (ash sig -32)
38                                sb!vm:double-float-significand-byte
39                                (if (zerop sign) 0 -1)))
40                      (ldb (byte 32 0) sig)))
41 #!+(and long-float x86)
42 (defun long-from-bits (sign exp sig)
43   (declare (type bit sign) (type (unsigned-byte 64) sig)
44            (type (unsigned-byte 15) exp))
45   (make-long-float (logior (ash sign 15) exp)
46                    (ldb (byte 32 32) sig)
47                    (ldb (byte 32 0) sig)))
48
49 ) ; EVAL-WHEN
50 \f
51 ;;;; float parameters
52
53 (defconstant least-positive-single-float (single-from-bits 0 0 1))
54 (defconstant least-positive-short-float (single-from-bits 0 0 1))
55 (defconstant least-negative-single-float (single-from-bits 1 0 1))
56 (defconstant least-negative-short-float (single-from-bits 1 0 1))
57 (defconstant least-positive-double-float (double-from-bits 0 0 1))
58 #!-long-float
59 (defconstant least-positive-long-float (double-from-bits 0 0 1))
60 #!+(and long-float x86)
61 (defconstant least-positive-long-float (long-from-bits 0 0 1))
62 (defconstant least-negative-double-float (double-from-bits 1 0 1))
63 #!-long-float
64 (defconstant least-negative-long-float (double-from-bits 1 0 1))
65 #!+(and long-float x86)
66 (defconstant least-negative-long-float (long-from-bits 1 0 1))
67
68 (defconstant least-positive-normalized-single-float
69   (single-from-bits 0 sb!vm:single-float-normal-exponent-min 0))
70 (defconstant least-positive-normalized-short-float
71   least-positive-normalized-single-float)
72 (defconstant least-negative-normalized-single-float
73   (single-from-bits 1 sb!vm:single-float-normal-exponent-min 0))
74 (defconstant least-negative-normalized-short-float
75   least-negative-normalized-single-float)
76 (defconstant least-positive-normalized-double-float
77   (double-from-bits 0 sb!vm:double-float-normal-exponent-min 0))
78 #!-long-float
79 (defconstant least-positive-normalized-long-float
80   least-positive-normalized-double-float)
81 #!+(and long-float x86)
82 (defconstant least-positive-normalized-long-float
83   (long-from-bits 0 sb!vm:long-float-normal-exponent-min
84                   (ash sb!vm:long-float-hidden-bit 32)))
85 (defconstant least-negative-normalized-double-float
86   (double-from-bits 1 sb!vm:double-float-normal-exponent-min 0))
87 #!-long-float
88 (defconstant least-negative-normalized-long-float
89   least-negative-normalized-double-float)
90 #!+(and long-float x86)
91 (defconstant least-negative-normalized-long-float
92   (long-from-bits 1 sb!vm:long-float-normal-exponent-min
93                   (ash sb!vm:long-float-hidden-bit 32)))
94
95 (defconstant most-positive-single-float
96   (single-from-bits 0 sb!vm:single-float-normal-exponent-max
97                     (ldb sb!vm:single-float-significand-byte -1)))
98 (defconstant most-positive-short-float most-positive-single-float)
99 (defconstant most-negative-single-float
100   (single-from-bits 1 sb!vm:single-float-normal-exponent-max
101                     (ldb sb!vm:single-float-significand-byte -1)))
102 (defconstant most-negative-short-float most-negative-single-float)
103 (defconstant most-positive-double-float
104   (double-from-bits 0 sb!vm:double-float-normal-exponent-max
105                     (ldb (byte sb!vm:double-float-digits 0) -1)))
106
107 (defconstant most-positive-long-float most-positive-double-float)
108
109 (defconstant most-negative-double-float
110   (double-from-bits 1 sb!vm:double-float-normal-exponent-max
111                     (ldb (byte sb!vm:double-float-digits 0) -1)))
112 (defconstant most-negative-long-float most-negative-double-float)
113
114 ;;; We don't want to do these DEFCONSTANTs at cross-compilation time,
115 ;;; because the cross-compilation host might not support floating
116 ;;; point infinities. Putting them inside a LET removes
117 ;;; toplevel-formness, so that any EVAL-WHEN trickiness in the
118 ;;; DEFCONSTANT forms is suppressed.
119 ;;;
120 ;;; Note that it might be worth performing a similar MAKE-LOAD-FORM
121 ;;; trick as with -0.0 (see the UNPORTABLE-FLOAT structure).  CSR,
122 ;;; 2004-03-09
123 (let ()
124 (defconstant single-float-positive-infinity
125   (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0))
126 (defconstant short-float-positive-infinity
127   (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0))
128 (defconstant single-float-negative-infinity
129   (single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0))
130 (defconstant short-float-negative-infinity
131   (single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0))
132 (defconstant double-float-positive-infinity
133   (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
134 #!+(not long-float)
135 (defconstant long-float-positive-infinity
136   (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
137 #!+(and long-float x86)
138 (defconstant long-float-positive-infinity
139   (long-from-bits 0 (1+ sb!vm:long-float-normal-exponent-max)
140                   (ash sb!vm:long-float-hidden-bit 32)))
141 (defconstant double-float-negative-infinity
142   (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0))
143 #!+(not long-float)
144 (defconstant long-float-negative-infinity
145   (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0))
146 #!+(and long-float x86)
147 (defconstant long-float-negative-infinity
148   (long-from-bits 1 (1+ sb!vm:long-float-normal-exponent-max)
149                   (ash sb!vm:long-float-hidden-bit 32)))
150 ) ; LET-to-suppress-possible-EVAL-WHENs
151
152 (defconstant single-float-epsilon
153   (single-from-bits 0 (- sb!vm:single-float-bias
154                          (1- sb!vm:single-float-digits)) 1))
155 (defconstant short-float-epsilon single-float-epsilon)
156 (defconstant single-float-negative-epsilon
157   (single-from-bits 0 (- sb!vm:single-float-bias sb!vm:single-float-digits) 1))
158 (defconstant short-float-negative-epsilon single-float-negative-epsilon)
159 (defconstant double-float-epsilon
160   (double-from-bits 0 (- sb!vm:double-float-bias
161                          (1- sb!vm:double-float-digits)) 1))
162 #!-long-float
163 (defconstant long-float-epsilon double-float-epsilon)
164 #!+(and long-float x86)
165 (defconstant long-float-epsilon
166   (long-from-bits 0 (- sb!vm:long-float-bias (1- sb!vm:long-float-digits))
167                   (+ 1 (ash sb!vm:long-float-hidden-bit 32))))
168 (defconstant double-float-negative-epsilon
169   (double-from-bits 0 (- sb!vm:double-float-bias sb!vm:double-float-digits) 1))
170 #!-long-float
171 (defconstant long-float-negative-epsilon double-float-negative-epsilon)
172 #!+(and long-float x86)
173 (defconstant long-float-negative-epsilon
174   (long-from-bits 0 (- sb!vm:long-float-bias sb!vm:long-float-digits)
175                   (+ 1 (ash sb!vm:long-float-hidden-bit 32))))