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))))