Update to quaviver:triple-float and add underflow detection

code/reader/additional-conditions.lisp

@@ -268,6 +268,13 @@
    (%mantissa :initarg :mantissa :reader mantissa)
    (%exponent :initarg :exponent :reader exponent)))
 
+(define-condition underflow-in-float (stream-position-reader-error
+                                      floating-point-underflow
+                                      float-format-condition)
+  ((%sign :initarg :sign :reader sign)
+   (%mantissa :initarg :mantissa :reader mantissa)
+   (%exponent :initarg :exponent :reader exponent)))
+
 ;;; Conditions related to block comments
 
 (define-condition unterminated-block-comment (missing-delimiter)

code/reader/messages-english.lisp

@@ -361,6 +361,18 @@
             'cl:*read-default-float-format*
             (float-format condition)))
 
+  (define-reporter ((condition underflow-in-float) stream)
+    (format stream "~@<A floating point underflow occurred when attempting to ~
+                    represent ~D * ~D * 10^~D as a ~A.~@:>"
+                   #+maybe " Failed operation was ~
+                    (~A~{~^ ~A~}).~@:>"
+            (sign condition)
+            (mantissa condition)
+            (exponent condition)
+            (float-format condition)
+            #+maybe (arithmetic-error-operation condition)
+            #+maybe (arithmetic-error-operands condition)))
+
   (define-reporter ((condition overflow-in-float) stream)
     (format stream "~@<A floating point overflow occurred when attempting to ~
                     represent ~D * ~D * 10^~D as a ~A.~@:>"

code/reader/package.lisp

@@ -221,6 +221,7 @@
    #:invalid-radix
    #:invalid-default-float-format
    #:overflow-in-float
+   #:underflow-in-float
 
    #:unterminated-block-comment
 

code/reader/tokens.lisp

@@ -222,9 +222,28 @@
                                           0)
                                       decimal-exponent)))
                      (handler-case
-                      (quaviver:integer-float
+                      (quaviver:triple-float
                        (load-time-value (make-instance 'quaviver/liebler:client)) ; TODO: temporary
                        type 10 significand exponent sign)
+                       (floating-point-underflow (condition)
+                         (let ((length (+ (length (format nil "~D~:[~;E~:[~;+~]~2:*~D~]"
+                                                          (* sign significand) (when exponentp (exponent)) exponent-sign)) ; TODO: don't call it again
+                                          (if (zerop decimal-exponent) 0 1) ; TODO not accurate
+                                          )))
+                           ;; The condition report might print the objects passed as
+                           ;; `:operands' which is fine since we pass truncated values.
+                           (%recoverable-reader-error
+                            input-stream 'underflow-in-float
+                            :position-offset (- length)                       ; `stream-position-condition'
+                            :operation (arithmetic-error-operation condition) ; `arithmetic-error'
+                            :operands (arithmetic-error-operands condition)   ; `arithmetic-error'
+                            :float-format type                                ; `float-format-condition'
+                            :sign sign                                        ; `underflow-in-float'
+                            :mantissa significand                             ; `underflow-in-float'
+                            :exponent exponent                                ; `underflow-in-float'
+                            :report 'use-replacement-float-format ; TODO report
+                            )
+                           (coerce 0 type)))
                        (floating-point-overflow (condition)
                          (let ((length (+ (length (format nil "~D~:[~;E~:[~;+~]~2:*~D~]"
                                                           (* sign significand) (when exponentp (exponent)) exponent-sign)) ; TODO: don't call it again
@@ -243,8 +262,7 @@
                             :exponent exponent                                ; `overflow-in-float'
                             :report 'use-replacement-float-format ; TODO report
                             )
-                           ;; TODO: most extreme value instead?
-                           (coerce 1.0 type))))))))
+                           (quaviver:triple-float nil type 2 0 :infinity sign))))))))
           (macrolet ((next-cond ((char-var &optional return-symbol-if-eoi
                                                      (colon-go-symbol t))
                                  &body clauses)

test/reader/tokens.lisp

@@ -406,11 +406,30 @@
           '(("1.0" () 10 :upcase eclector.reader:invalid-default-float-format 3 0)
             ("1e0" () 10 :upcase eclector.reader:invalid-default-float-format 1 1)))))
 
+(test interpret-token.default/floating-point-underflow
+  "Make sure that too large exponents signal a UNDERFLOW-IN-FLOAT condition."
+  (mapc #'do-interpret-token-test-case
+        '(("1e-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10)
+          ("1s-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10)
+          ("1f-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10)
+          ("1d-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10)
+          ("1l-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 10)
+          ("-1e-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11)
+          ("-1s-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11)
+          ("-1f-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11)
+          ("-1d-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11)
+          ("-1l-1000000" () 10 :upcase eclector.reader:underflow-in-float 0 11))))
+
 (test interpret-token.default/floating-point-overflow
   "Make sure that too large exponents signal a OVERFLOW-IN-FLOAT condition."
   (mapc #'do-interpret-token-test-case
         '(("1e1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9)
+          ("1s1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9)
           ("1f1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9)
           ("1d1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9)
-          ("1d+1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10)
-          ("-1d+1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10))))
+          ("1l1000000" () 10 :upcase eclector.reader:overflow-in-float 0 9)
+          ("-1e1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10)
+          ("-1s1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10)
+          ("-1f1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10)
+          ("-1d1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10)
+          ("-1l1000000" () 10 :upcase eclector.reader:overflow-in-float 0 10))))