UNFINISHED Handle floating point overflow in float literals

code/reader/additional-conditions.lisp

@@ -192,7 +192,7 @@
    (%found-character :initarg :found-character
                      :reader found-character)))
 
-;;; Conditions related to SHARPSIGN-DOT
+;;; Conditions related to function literals
 
 (define-condition end-of-input-after-sharpsign-single-quote (end-of-file
                                                              incomplete-construct)
@@ -254,9 +254,19 @@
 (define-condition invalid-radix (stream-position-reader-error)
   ((%radix :initarg :radix :reader radix)))
 
-(define-condition invalid-default-float-format (stream-position-reader-error)
-  ((%exponent-marker :initarg :exponent-marker :reader exponent-marker)
-   (%float-format :initarg :float-format :reader float-format)))
+(define-condition float-format-condition (condition)
+  ((%float-format :initarg :float-format :reader float-format)))
+
+(define-condition invalid-default-float-format (stream-position-reader-error
+                                                float-format-condition)
+  ((%exponent-marker :initarg :exponent-marker :reader exponent-marker)))
+
+(define-condition overflow-in-float (stream-position-reader-error
+                                     floating-point-overflow
+                                     float-format-condition)
+  ((%sign :initarg :sign :reader sign)
+   (%mantissa :initarg :mantissa :reader mantissa)
+   (%exponent :initarg :exponent :reader exponent)))
 
 ;;; Conditions related to block comments
 

code/reader/generic-functions.lisp

@@ -141,17 +141,52 @@
 
 (define-kind number-kind (literal-kind) ())
 
+;;; Taken from SBCL code
+;;; Truncate EXPONENT if it's too large for a float.
+(defun truncate-exponent (exponent mantissa)
+  ;; Work with base-2 logarithms to avoid conversions to floats, and
+  ;; convert to base-10 conservatively at the end.  Use the least
+  ;; positive float, because denormalized exponent can be larger than
+  ;; normalized.
+  (let* ((max-exponent-bits (+ sb-vm:double-float-digits
+                               sb-vm:double-float-bias))
+         (mantissa-bits     (integer-length mantissa)))
+    (if (minusp exponent)
+        (max exponent (ceiling (- (+ max-exponent-bits mantissa-bits))
+                               #.(cl:floor (cl:log 10 2))))
+        (min exponent (floor (- max-exponent-bits mantissa-bits)
+                             #.(cl:floor (cl:log 10 2)))))))
+
 (define-kind float-kind (number-kind) ())
 (defmethod make-literal ((client t) (kind float-kind)
-                         &key type sign decimal-mantissa
+                         &key stream ; TODO pass stream as required parameter for source information and error reporting?
+                              type sign decimal-mantissa
                               exponent-sign (exponent nil exponentp)
                               decimal-exponent)
-  (let ((magnitude (* decimal-mantissa
-                      (expt 10 (- (if exponentp
-                                      (* exponent-sign exponent)
-                                      0)
-                                  decimal-exponent)))))
-    (* sign (coerce magnitude type))))
+  (let* ((exponent*  (-  (if exponentp
+                            (* exponent-sign exponent)
+                            0)
+                        decimal-exponent))
+         (exponent** (truncate-exponent exponent* decimal-mantissa))
+         (magnitude (* decimal-mantissa (expt 10 exponent**))))
+    (handler-case
+        (* sign (coerce magnitude type))
+      (floating-point-overflow ()
+        (let ((length (+ (length (format nil "~D~@[E~D~]"
+                                         decimal-mantissa exponent))
+                         (if (zerop decimal-exponent) 0 1) ; TODO not accurate
+                         )))
+          (%recoverable-reader-error
+           stream 'overflow-in-float
+           :position-offset (- length)
+           :operation 'coerce           ; arithmetic-error
+           :operands (list magnitude type)
+           :sign sign                   ; overflow-in-float
+           :mantissa decimal-mantissa
+           :exponent exponent
+           :float-format type           ; float-format-condition
+           :report 'use-replacement-float-format ; TODO report
+           ))))))
 
 ;;; TODO separate file?
 (define-kind rational-kind (number-kind) ())

code/reader/messages-english.lisp

@@ -361,6 +361,14 @@
             'cl:*read-default-float-format*
             (float-format 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.~@:>"
+            (sign condition)
+            (mantissa condition)
+            (exponent condition)
+            (float-format condition)))
+
 ;;; Conditions related to block comments
 
   (define-reporter ((condition unterminated-block-comment) stream)

code/reader/tokens.lisp

@@ -218,14 +218,14 @@
                         :report 'use-replacement-float-format))
                      (setf type 'single-float))
                    (if exponentp
-                       (make-literal client float-kind
+                       (make-literal client float-kind :stream input-stream ; HACK pass stream as required argument?
                                      :type type
                                      :sign sign
                                      :decimal-mantissa (decimal-mantissa)
                                      :exponent-sign exponent-sign
                                      :exponent (exponent)
                                      :decimal-exponent decimal-exponent)
-                       (make-literal client float-kind
+                       (make-literal client float-kind :stream input-stream
                                      :type type
                                      :sign sign
                                      :decimal-mantissa (decimal-mantissa)

test/reader/tokens.lisp

@@ -405,3 +405,10 @@
     (mapc #'do-interpret-token-test-case
           '(("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-overflow
+  "Make sure that too large exponents signal a FLOATING-POINT-OVERFLOW."
+  (mapc #'do-interpret-token-test-case
+        '(("1e1000000" () 10 :upcase eclector.reader::overflow-in-float 0 9) ; TODO export
+          ("1f1000000" () 10 :upcase eclector.reader::overflow-in-float 0 9)
+          ("1d1000000" () 10 :upcase eclector.reader::overflow-in-float 0 9))))

test/reader/utilities.lisp

@@ -5,7 +5,6 @@
 
 (test convert-according-to-readtable-case/smoke
   "Smoke test for the CONVERT-ACCORDING-TO-READTABLE-CASE function."
-
   (mapc (lambda (foo)
           (destructuring-bind (token escape-ranges case expected) foo
             (let ((token (copy-seq token))