Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/patches/sbcl-20200811.lisp

KindCoveredAll%
expression100125 80.0
branch916 56.3
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; handle 0/1 conversion
2
 
3
 (in-package :sb-kernel)
4
 
5
 (defun float-ratio (x format)
6
   (let* ((signed-num (numerator x))
7
          (plusp (plusp signed-num))
8
          (num (if plusp signed-num (- signed-num)))
9
          (den (denominator x))
10
          (digits (float-format-digits format))
11
          (scale 0))
12
     (declare (fixnum digits scale))
13
     (when (= den 1)
14
       (return-from float-ratio
15
         (ecase format
16
           (single-float (float signed-num 1.0s0))
17
           (double-float (float signed-num 1.0d0)))))
18
     ;; Strip any trailing zeros from the denominator and move it into the scale
19
     ;; factor (to minimize the size of the operands.)
20
     (let ((den-twos (1- (integer-length (logxor den (1- den))))))
21
       (declare (fixnum den-twos))
22
       (decf scale den-twos)
23
       (setq den (ash den (- den-twos))))
24
     ;; Guess how much we need to scale by from the magnitudes of the numerator
25
     ;; and denominator. We want one extra bit for a guard bit.
26
     (let* ((num-len (integer-length num))
27
            (den-len (integer-length den))
28
            (delta (- den-len num-len))
29
            (shift (1+ (the fixnum (+ delta digits))))
30
            (shifted-num (ash num shift)))
31
       (declare (fixnum delta shift))
32
       (decf scale delta)
33
       (labels ((float-and-scale (bits)
34
                  (let* ((bits (ash bits -1))
35
                         (len (integer-length bits)))
36
                    (cond ((> len digits)
37
                           (aver (= len (the fixnum (1+ digits))))
38
                           (scale-float (floatit (ash bits -1)) (1+ scale)))
39
                          (t
40
                           (scale-float (floatit bits) scale)))))
41
                (floatit (bits)
42
                  (let ((sign (if plusp 0 1)))
43
                    (case format
44
                      (single-float
45
                       (single-from-bits sign sb-vm:single-float-bias bits))
46
                      (double-float
47
                       (double-from-bits sign sb-vm:double-float-bias bits))
48
                      #+long-float
49
                      (long-float
50
                       (long-from-bits sign sb-vm:long-float-bias bits))))))
51
         (loop
52
           (multiple-value-bind (fraction-and-guard rem)
53
               (truncate shifted-num den)
54
             (let ((extra (- (integer-length fraction-and-guard) digits)))
55
               (declare (fixnum extra))
56
               (cond ((/= extra 1)
57
                      (aver (> extra 1)))
58
                     ((oddp fraction-and-guard)
59
                      (return
60
                       (if (zerop rem)
61
                           (float-and-scale
62
                            (if (zerop (logand fraction-and-guard 2))
63
                                fraction-and-guard
64
                                (1+ fraction-and-guard)))
65
                           (float-and-scale (1+ fraction-and-guard)))))
66
                     (t
67
                      (return (float-and-scale fraction-and-guard)))))
68
             (setq shifted-num (ash shifted-num -1))
69
             (incf scale)))))))