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)