File: float.lisp

package info (click to toggle)
cl-nibbles 20250305.gitc1ecd02-2
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 224 kB
  • sloc: lisp: 2,104; makefile: 2
file content (57 lines) | stat: -rw-r--r-- 2,792 bytes parent folder | download
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
;;;; float.lisp -- convert between IEEE floating point numbers and bits

(cl:in-package :nibbles)

(defun make-single-float (bits)
  (let ((exponent-bits (ldb (byte 8 23) bits))
        (significand-bits (ldb (byte 23 0) bits)))
    (when (= exponent-bits 255)
      (error (if (zerop significand-bits)
                 "floating point infinities are not supported"
                 "floating point NaNs are not supported")))
    #+clisp
    (when (and (zerop exponent-bits) (plusp significand-bits))
      (error "subnormal floating point numbers are not supported"))
    (let ((sign (if (zerop (ldb (byte 1 31) bits)) 1f0 -1f0))
          (significand (logior significand-bits (if (zerop exponent-bits) 0 (ash 1 23))))
          (exponent (if (zerop exponent-bits) -126 (- exponent-bits 127))))
      (* sign (scale-float (float significand 1f0) (- exponent 23))))))

(defun make-double-float (high low)
  (let ((exponent-bits (ldb (byte 11 20) high))
        (significand-bits (logior low (ash (ldb (byte 20 0) high) 32))))
    (when (= exponent-bits 2047)
      (error (if (zerop significand-bits)
                 "floating point infinities are not supported"
                 "floating point NaNs are not supported")))
    #+clisp
    (when (and (zerop exponent-bits) (plusp significand-bits))
      (error "subnormal floating point numbers are not supported"))
    (let ((sign (if (zerop (ldb (byte 1 31) high)) 1d0 -1d0))
          (significand (logior significand-bits (if (zerop exponent-bits) 0 (ash 1 52))))
          (exponent (if (zerop exponent-bits) -1022 (- exponent-bits 1023))))
      (* sign (scale-float (float significand 1d0) (- exponent 52))))))

(defun single-float-bits (float)
  (multiple-value-bind (significand exponent sign)
      (decode-float float)
    (let ((sign-bit (if (plusp sign) 0 1))
          (exponent-bits (if (zerop significand) 0 (+ exponent 127 -1)))
          (significand-bits (floor (* #.(expt 2f0 24) significand))))
      (when (<= exponent-bits 0)
        (setf significand-bits (ash significand-bits (1- exponent-bits)))
        (setf exponent-bits 0))
      (logior (ash sign-bit 31) (ash exponent-bits 23) (ldb (byte 23 0) significand-bits)))))

(defun double-float-bits (float)
  (multiple-value-bind (significand exponent sign)
      (decode-float float)
    (let ((sign-bit (if (plusp sign) 0 1))
          (exponent-bits (if (zerop significand) 0 (+ exponent 1023 -1)))
          (significand-bits (floor (* #.(expt 2d0 53) significand))))
      (when (<= exponent-bits 0)
        (setf significand-bits (ash significand-bits (1- exponent-bits)))
        (setf exponent-bits 0))
      (values
       (logior (ash sign-bit 31) (ash exponent-bits 20) (ldb (byte 20 32) significand-bits))
       (ldb (byte 32 0) significand-bits)))))