quaviver, liebler: improve underflow/overflow detection

s-expressionists · Aug 18, 2024 · 444793d · 444793d
1 parent 3603360
commit 444793d
Show file tree

Hide file tree

Showing 2 changed files with 49 additions and 32 deletions.
diff --git a/code/liebler/implementation.lisp b/code/liebler/implementation.lisp
@@ -14,40 +14,49 @@
       `(locally
            (declare #+(or)(type (unsigned-byte ,word-size)
                           ,significand-var)
-                    (type (or quaviver:exponent-word keyword) ,exponent-var)
                     (type fixnum ,sign-var)
                     (optimize speed))
-         (if (or (keywordp ,exponent-var)
-                 (zerop ,significand-var))
-             ,(quaviver:primitive-triple-float-form float-type significand-var exponent-var sign-var)
-             (let* ((shift (- ,significand-size (integer-length ,significand-var)))
-                    (k (- (quaviver.math:floor-log-expt 2 10 ,exponent-var) -1 shift)))
-               (declare (type quaviver:exponent-word k shift))
-               ;; The following overflow and underflow checks are not
-               ;; strict checks. Stricter checks will happen in
-               ;; triple-float/2. These are here to protect the expt10
-               ;; table lookup from an out of bounds error.
-               (cond ((> k ,(+ max-exponent
-                               (quaviver.math:ceiling-log-expt 2 10 1)))
-                      (quaviver.condition:floating-point-overflow
-                       'quaviver:triple-float
-                       ,client ',float-type 10 ,significand-var ,exponent-var ,sign-var))
-                     ((< k ,(- min-exponent
-                               (quaviver.math:ceiling-log-expt 2 10 1)))
-                      (quaviver.condition:floating-point-underflow
-                       'quaviver:triple-float
-                       ,client ',float-type 10 ,significand-var ,exponent-var ,sign-var))
-                     (t
-                      (setf ,significand-var (quaviver.math:round-to-odd
-                                              ,arithmetic-size
-                                              (ash ,significand-var (+ shift ,extra))
-                                              (quaviver.math:expt ,arithmetic-size 10
-                                                                  (- ,exponent-var)))
-                            shift (- ,significand-size (integer-length ,significand-var)))
-                      ,(quaviver:primitive-triple-float-form float-type
-                                                             `(round ,significand-var (ash 1 (- shift)))
-                                                             `(- k shift ,extra)
-                                                             sign-var)))))))))
+         (cond ((or (keywordp ,exponent-var)
+                    (zerop ,significand-var))
+                ,(quaviver:primitive-triple-float-form float-type significand-var exponent-var sign-var))
+               ((not (typep ,exponent-var 'quaviver:exponent-word))
+                (if (minusp ,exponent-var)
+                    (quaviver.condition:floating-point-underflow
+                     'triple-float
+                     ,significand-var ,exponent-var ,sign-var)
+                    (quaviver.condition:floating-point-overflow
+                     'triple-float
+                     ,significand-var ,exponent-var ,sign-var)))
+               (t
+                (let* ((shift (- ,significand-size (integer-length ,significand-var)))
+                       (k (- (quaviver.math:floor-log-expt 2 10 ,exponent-var) -1 shift)))
+                  (declare (type fixnum k)
+                           (type quaviver:exponent-word shift))
+                  ;; The following overflow and underflow checks are not
+                  ;; strict checks. Stricter checks will happen in
+                  ;; triple-float/2. These are here to protect the expt10
+                  ;; table lookup from an out of bounds error.
+                  (cond ((> k ,(+ max-exponent
+                                  (quaviver.math:ceiling-log-expt 2 10 1)))
+                         (quaviver.condition:floating-point-overflow
+                          'quaviver:triple-float
+                          ,client ',float-type 10 ,significand-var ,exponent-var ,sign-var))
+                        ((< k ,(- min-exponent
+                                  (quaviver.math:ceiling-log-expt 2 10 1)))
+                         (quaviver.condition:floating-point-underflow
+                          'quaviver:triple-float
+                          ,client ',float-type 10 ,significand-var ,exponent-var ,sign-var))
+                        (t
+                         (setf ,significand-var (quaviver.math:round-to-odd
+                                                 ,arithmetic-size
+                                                 (ash ,significand-var (+ shift ,extra))
+                                                 (quaviver.math:expt ,arithmetic-size 10
+                                                                     (- ,exponent-var)))
+                               shift (- ,significand-size (integer-length ,significand-var)))
+                         ,(quaviver:primitive-triple-float-form float-type
+                                                                `(round ,significand-var (ash 1 (- shift)))
+                                                                `(- k shift ,extra)
+                                                                sign-var))))))))))
 
 #+quaviver/short-float
 (defmethod quaviver:triple-float

diff --git a/code/primitive-triple-float-form.lisp b/code/primitive-triple-float-form.lisp
@@ -50,6 +50,14 @@
                    (setf (ldb ,nan-payload-byte-form ,bits-var)
                          (if (zerop ,significand-var) 1 ,significand-var)))))
                ((zerop ,significand-var))
+               ((not (typep ,exponent-var 'exponent-word))
+                (if (minusp ,exponent-var)
+                    (quaviver.condition:floating-point-underflow
+                     'triple-float
+                     ,significand-var ,exponent-var ,sign-var)
+                    (quaviver.condition:floating-point-overflow
+                     'triple-float
+                     ,significand-var ,exponent-var ,sign-var)))
                (t
                 (let ((shift (- ,significand-size
                                 (integer-length ,significand-var))))