floating point overflow work

s-expressionists · Jun 30, 2024 · 7767cc0 · 7767cc0
1 parent edf21b8
commit 7767cc0
Show file tree

Hide file tree

Showing 3 changed files with 31 additions and 9 deletions.
diff --git a/code/reader/messages-english.lisp b/code/reader/messages-english.lisp
@@ -363,14 +363,15 @@
 
   (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. Failed operation was ~
+                    represent ~D * ~D * 10^~D as a ~A.~@:>"
+                   #+maybe " Failed operation was ~
                     (~A~{~^ ~A~}).~@:>"
             (sign condition)
             (mantissa condition)
             (exponent condition)
             (float-format condition)
-            (arithmetic-error-operation condition)
-            (arithmetic-error-operands condition)))
+            #+maybe (arithmetic-error-operation condition)
+            #+maybe (arithmetic-error-operands condition)))
 
 ;;; Conditions related to block comments
 

diff --git a/code/reader/tokens.lisp b/code/reader/tokens.lisp
@@ -170,7 +170,7 @@
            (escape-range (first remaining-escape-ranges))
            (sign 1)
            (decimal-exponent 0)
-           (exponent-sign 1)
+           (exponent-sign nil)
            (exponent-marker nil)
            (position-package-marker-1 nil)
            (position-package-marker-2 nil)
@@ -218,12 +218,33 @@
                      (setf type 'single-float))
                    (let ((significand (decimal-mantissa))
                          (exponent (- (if exponentp
-                                          (* exponent-sign (exponent))
+                                          (* (or exponent-sign 1) (exponent))
                                           0)
                                       decimal-exponent)))
-                    (quaviver:integer-float
-                     (load-time-value (make-instance 'quaviver/jaffer:client)) ; TODO: temporary
-                     type 10 significand exponent sign)))))
+                     (handler-case
+                      (quaviver:integer-float
+                       (load-time-value (make-instance 'quaviver/liebler:client)) ; TODO: temporary
+                       type 10 significand exponent sign)
+                       (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
+                                          (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 'overflow-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                                        ; `overflow-in-float'
+                            :mantissa significand                             ; `overflow-in-float'
+                            :exponent exponent                                ; `overflow-in-float'
+                            :report 'use-replacement-float-format ; TODO report
+                            )
+                           ;; TODO: most extreme value instead?
+                           (coerce 1.0 type))))))))
           (macrolet ((next-cond ((char-var &optional return-symbol-if-eoi
                                                      (colon-go-symbol t))
                                  &body clauses)

diff --git a/eclector.asd b/eclector.asd
@@ -8,7 +8,7 @@
   :version     (:read-file-form "data/version-string.sexp")
   :depends-on  ("alexandria"
                 "closer-mop"
-                "quaviver/jaffer"
+                "quaviver/liebler"
                 "acclimation")
 
   :components  ((:module "base"