various: add recoverable overflow and underflow

code/condition/utility.lisp

@@ -1,11 +1,36 @@
 (in-package #:quaviver.condition)
 
-(defun floating-point-overflow (operation &rest operands)
-  (error 'cl:floating-point-overflow
-         :operation operation
-         :operands operands))
+(defun floating-point-underflow (float-type sign operation &rest operands)
+  (restart-case
+      (error 'cl:floating-point-underflow
+             :operation operation
+             :operands operands)
+    (recover ()
+      :report (lambda (stream)
+                (format stream "Recover using ~:[negative~;positive~] zero as the value."
+                        (plusp sign)))
+      (quaviver:triple-float nil float-type 2 0 0 sign))))
 
-(defun floating-point-underflow (operation &rest operands)
-  (error 'cl:floating-point-underflow
-         :operation operation
-         :operands operands))
+(defun floating-point-overflow (float-type sign operation &rest operands)
+  (restart-case
+      (error 'cl:floating-point-overflow
+             :operation operation
+             :operands operands)
+    (recover ()
+      :report (lambda (stream)
+                (format stream
+                        #+clisp "Recover using the most ~:[negative~;positive~] floating point as the value."
+                        #-clisp "Recover using ~:[negative~;positive~] infinity as the value."
+                        (plusp sign)))
+      #+clisp (if (minusp sign)
+                  (ecase float-type
+                    (short-float most-negative-short-float)
+                    (single-float most-negative-single-float)
+                    (double-float most-negative-double-float)
+                    (long-float most-negative-long-float))
+                  (ecase float-type
+                    (short-float most-positive-short-float)
+                    (single-float most-positive-single-float)
+                    (double-float most-positive-double-float)
+                    (long-float most-positive-long-float)))
+      #-clisp (quaviver:triple-float nil float-type 2 0 :infinity sign))))

code/jaffer/implementation.lisp

@@ -23,14 +23,14 @@
            (cond ((> q ,(+ max-exponent
                            (quaviver.math:ceiling-log-expt 2 10 1)))
                   (quaviver.condition:floating-point-overflow
-                   'quaviver:triple-float
-                   ,client ',float-type 10
+                   ',float-type ,sign-var
+                   'quaviver:triple-float ,client ',float-type 10
                    ,significand ,exponent ,sign))
                  ((< q ,(- min-exponent
                            (quaviver.math:ceiling-log-expt 2 10 1)))
                   (quaviver.condition:floating-point-underflow
-                   'quaviver:triple-float
-                   ,client ',float-type 10
+                   ',float-type ,sign-var
+                   'quaviver:triple-float ,client ',float-type 10
                    ,significand ,exponent ,sign))
                  ((minusp ,exponent)
                   (let* ((scale (expt 5 (- ,exponent)))

code/liebler/implementation.lisp

@@ -21,11 +21,13 @@
                 ,(quaviver:primitive-triple-float-form float-type significand-var exponent-var sign-var))
                ((< ,exponent-var ,(- (expt 2 21)))
                 (quaviver.condition:floating-point-underflow
-                 'triple-float
+                 ',float-type ,sign-var
+                 'quaviver:triple-float ,client ',float-type 10
                  ,significand-var ,exponent-var ,sign-var))
                ((> ,exponent-var ,(1- (expt 2 21)))
                 (quaviver.condition:floating-point-overflow
-                 'triple-float
+                 ',float-type ,sign-var
+                 'quaviver:triple-float ,client ',float-type 10
                  ,significand-var ,exponent-var ,sign-var))
                (t
                 (let* ((shift (- ,significand-size (integer-length ,significand-var)))
@@ -39,13 +41,15 @@
                   (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))
+                          ',float-type ,sign-var
+                          '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))
+                          ',float-type ,sign-var
+                          'quaviver:triple-float ,client ',float-type 10
+                           ,significand-var ,exponent-var ,sign-var))
                         (t
                          (setf ,significand-var (quaviver.math:round-to-odd
                                                  ,arithmetic-size

code/packages.lisp

@@ -84,4 +84,5 @@
            #:invalid-character-error
            #:invalid-leading-zeros-error
            #:invalid-property-error
-           #:missing-digits-error))
+           #:missing-digits-error
+           #:recover))

code/primitive-triple-float-form.lisp

@@ -52,11 +52,13 @@
                ((zerop ,significand-var))
                ((< ,exponent-var ,(- (expt 2 21)))
                 (quaviver.condition:floating-point-underflow
-                 'triple-float
+                 ',float-type ,sign-var
+                 'triple-float nil ',float-type 2
                  ,significand-var ,exponent-var ,sign-var))
                ((> ,exponent-var ,(1- (expt 2 21)))
                 (quaviver.condition:floating-point-overflow
-                 'triple-float
+                 ',float-type ,sign-var
+                 'triple-float nil ',float-type 2
                  ,significand-var ,exponent-var ,sign-var))
                (t
                 (let ((shift (- ,significand-size
@@ -65,11 +67,13 @@
                   (decf ,exponent-var shift))
                 (cond ((< ,exponent-var ,min-exponent)
                        (quaviver.condition:floating-point-underflow
-                        'triple-float
+                        ',float-type ,sign-var
+                        'triple-float nil ',float-type 2
                         ,significand-var ,exponent-var ,sign-var))
                       ((> ,exponent-var ,max-exponent)
                        (quaviver.condition:floating-point-overflow
-                        'triple-float
+                        ',float-type ,sign-var
+                        'triple-float nil ',float-type 2
                         ,significand-var ,exponent-var ,sign-var))
                       (t
                        (incf ,exponent-var ,exponent-bias)