Raymond Toy pushed to branch issue-275b-signal-float-underflow at cmucl / cmucl

Commits:

3 changed files:

Changes:

  • src/code/reader.lisp
    ... ... @@ -1832,67 +1832,70 @@ the end of the stream."
    1832 1832
       ;; throw an error immediately.  We don't need to be super accurate
    
    1833 1833
       ;; with the limits.  The rest of the code will handle it correctly,
    
    1834 1834
       ;; even if we're too small or too large.
    
    1835
    -  (unless (zerop number)
    
    1836
    -    (flet ((fast-log2 (n)
    
    1837
    -             ;;  For an integer, the integer-length is close enough to
    
    1838
    -             ;;  the log2 of the number.
    
    1839
    -             (integer-length n)))
    
    1840
    -      ;; log2(x) = log(number*10^exponent/divisor)
    
    1841
    -      ;;         = exponent*log2(10) + log2(number)-log2(divisor)
    
    1842
    -      (let ((log2-num (+ (* exponent #.(kernel::log2 10d0))
    
    1843
    -                         (fast-log2 number)
    
    1844
    -                         (- (fast-log2 divisor)))))
    
    1845
    -        (multiple-value-bind (log2-low log2-high)
    
    1846
    -            (ecase float-format
    
    1847
    -              ((short-float single-float)
    
    1848
    -               ;; Single-float exponents range is -149 to 127, but we
    
    1849
    -               ;; don't need to be super-accurate since we're
    
    1850
    -               ;; multiplying the values by 2.
    
    1851
    -               (values (* 2 (- vm:single-float-normal-exponent-min
    
    1852
    -                               vm:single-float-bias
    
    1853
    -                               vm:single-float-digits))
    
    1854
    -                       (* 2 (- vm:single-float-normal-exponent-max
    
    1855
    -                               vm:single-float-bias))))
    
    1856
    -              ((double-float long-float
    
    1857
    -                             #+double-double kernel:double-double-float)
    
    1858
    -               ;; Double-float exponent range is -1074 to -1023
    
    1859
    -               (values (* 2 (- vm:double-float-normal-exponent-min
    
    1860
    -                               vm:double-float-bias
    
    1861
    -                               vm:double-float-digits))
    
    1862
    -                       (* 2 (- vm:double-float-normal-exponent-max
    
    1863
    -                               vm:double-float-bias)))))
    
    1864
    -          (unless (< log2-low log2-num log2-high)
    
    1865
    -            ;; The number is definitely too large or too small to fit.
    
    1866
    -            ;; Signal an error.
    
    1867
    -            (%reader-error stream _"Number not representable as a ~S: ~S"
    
    1868
    -			   float-format (read-buffer-to-string)))))))
    
    1869
    -
    
    1870
    -  ;; Otherwise the number might fit, so we carefully compute the result.
    
    1871
    -  (handler-case
    
    1872
    -      (with-float-traps-masked (:underflow)
    
    1873
    -        (let* ((ratio (/ (* (expt 10 exponent) number)
    
    1874
    -                         divisor))
    
    1875
    -	       (result (coerce ratio float-format)))
    
    1876
    -	  (when (and (zerop result) (not (zerop number)))
    
    1877
    -	    ;; The number we've read is so small that it gets
    
    1878
    -	    ;; converted to 0.0, but is not actually zero.  Signal an
    
    1879
    -	    ;; error.  See CLHS 2.3.1.1.
    
    1880
    -            (error 'floating-point-underflow))
    
    1881
    -          result))
    
    1882
    -    (floating-point-underflow ()
    
    1883
    -      ;; Resignal a reader error, but allow the user to continue with
    
    1884
    -      ;; 0.
    
    1885
    -      (let ((zero (coerce 0 float-format)))
    
    1886
    -        (restart-case
    
    1887
    -            (%reader-error stream _"Floating point underflow when reading ~S: ~S"
    
    1888
    -                           float-format (read-buffer-to-string))
    
    1889
    -          (continue ()
    
    1890
    -            :report (lambda (stream)
    
    1891
    -                      (format stream "Return ~A" zero))
    
    1892
    -            zero))))
    
    1893
    -    (error ()
    
    1894
    -	   (%reader-error stream _"Number not representable as a ~S: ~S"
    
    1895
    -			  float-format (read-buffer-to-string)))))
    
    1835
    +  (flet ((handle-extreme-numbers ()
    
    1836
    +           (unless (zerop number)
    
    1837
    +             (flet ((fast-log2 (n)
    
    1838
    +                      ;;  For an integer, the integer-length is close enough to
    
    1839
    +                      ;;  the log2 of the number.
    
    1840
    +                      (integer-length n)))
    
    1841
    +               ;; log2(x) = log(number*10^exponent/divisor)
    
    1842
    +               ;;         = exponent*log2(10) + log2(number)-log2(divisor)
    
    1843
    +               (let ((log2-num (+ (* exponent #.(kernel::log2 10d0))
    
    1844
    +                                  (fast-log2 number)
    
    1845
    +                                  (- (fast-log2 divisor)))))
    
    1846
    +                 (multiple-value-bind (log2-low log2-high)
    
    1847
    +                     (ecase float-format
    
    1848
    +                       ((short-float single-float)
    
    1849
    +                        ;; Single-float exponents range is -149 to 127, but we
    
    1850
    +                        ;; don't need to be super-accurate since we're
    
    1851
    +                        ;; multiplying the values by 2.
    
    1852
    +                        (values (* 2 (- vm:single-float-normal-exponent-min
    
    1853
    +                                        vm:single-float-bias
    
    1854
    +                                        vm:single-float-digits))
    
    1855
    +                                (* 2 (- vm:single-float-normal-exponent-max
    
    1856
    +                                        vm:single-float-bias))))
    
    1857
    +                       ((double-float long-float
    
    1858
    +                                      #+double-double kernel:double-double-float)
    
    1859
    +                        ;; Double-float exponent range is -1074 to -1023
    
    1860
    +                        (values (* 2 (- vm:double-float-normal-exponent-min
    
    1861
    +                                        vm:double-float-bias
    
    1862
    +                                        vm:double-float-digits))
    
    1863
    +                                (* 2 (- vm:double-float-normal-exponent-max
    
    1864
    +                                        vm:double-float-bias)))))
    
    1865
    +                   (when (<= log2-num log2-low)
    
    1866
    +                     ;; Number is definitely too small; signal an underflow.
    
    1867
    +                     (error 'floating-point-underflow))
    
    1868
    +                   (when (>= log2-num log2-high)
    
    1869
    +                     ;; Number is definitely too large; signal an error
    
    1870
    +                     (error "Overflow"))))))))
    
    1871
    +
    
    1872
    +    ;; Otherwise the number might fit, so we carefully compute the result.
    
    1873
    +    (handler-case
    
    1874
    +        (with-float-traps-masked (:underflow)
    
    1875
    +          (handle-extreme-numbers)
    
    1876
    +          (let* ((ratio (/ (* (expt 10 exponent) number)
    
    1877
    +                           divisor))
    
    1878
    +	         (result (coerce ratio float-format)))
    
    1879
    +	    (when (and (zerop result) (not (zerop number)))
    
    1880
    +	      ;; The number we've read is so small that it gets
    
    1881
    +	      ;; converted to 0.0, but is not actually zero.  Signal an
    
    1882
    +	      ;; error.  See CLHS 2.3.1.1.
    
    1883
    +              (error 'floating-point-underflow))
    
    1884
    +            result))
    
    1885
    +      (floating-point-underflow ()
    
    1886
    +        ;; Resignal a reader error, but allow the user to continue with
    
    1887
    +        ;; 0.
    
    1888
    +        (let ((zero (coerce 0 float-format)))
    
    1889
    +          (restart-case
    
    1890
    +              (%reader-error stream _"Floating point underflow when reading ~S: ~S"
    
    1891
    +                             float-format (read-buffer-to-string))
    
    1892
    +            (continue ()
    
    1893
    +              :report (lambda (stream)
    
    1894
    +                        (format stream "Return ~A" zero))
    
    1895
    +              zero))))
    
    1896
    +      (error ()
    
    1897
    +	(%reader-error stream _"Number not representable as a ~S: ~S"
    
    1898
    +		       float-format (read-buffer-to-string))))))
    
    1896 1899
     
    
    1897 1900
     
    
    1898 1901
     (defun make-ratio (stream)
    

  • src/i18n/locale/cmucl.pot
    ... ... @@ -8750,11 +8750,11 @@ msgid "Internal error in floating point reader."
    8750 8750
     msgstr ""
    
    8751 8751
     
    
    8752 8752
     #: src/code/reader.lisp
    
    8753
    -msgid "Number not representable as a ~S: ~S"
    
    8753
    +msgid "Floating point underflow when reading ~S: ~S"
    
    8754 8754
     msgstr ""
    
    8755 8755
     
    
    8756 8756
     #: src/code/reader.lisp
    
    8757
    -msgid "Floating point underflow when reading ~S: ~S"
    
    8757
    +msgid "Number not representable as a ~S: ~S"
    
    8758 8758
     msgstr ""
    
    8759 8759
     
    
    8760 8760
     #: src/code/reader.lisp
    

  • tests/float.lisp
    ... ... @@ -247,3 +247,44 @@
    247 247
         (assert-equal 0.9999999999999999d0
    
    248 248
                       (rounding-test 3d0))))
    
    249 249
     
    
    250
    +(define-test reader.underflow-enabled
    
    251
    +    (:tag :issues)
    
    252
    +  ;; Test with FP underflow enabled, we can still read denormals
    
    253
    +  ;; without problem.  For this test we only care that we get a
    
    254
    +  ;; number, not the actual value.
    
    255
    +  (dolist (n (list least-positive-single-float
    
    256
    +                   least-positive-normalized-single-float
    
    257
    +                   (/ (+ least-positive-single-float
    
    258
    +                         least-positive-normalized-single-float)
    
    259
    +                      2)
    
    260
    +                   least-positive-double-float
    
    261
    +                   least-positive-normalized-double-float
    
    262
    +                   (/ (+ least-positive-double-float
    
    263
    +                         least-positive-normalized-double-float)
    
    264
    +                      2)
    
    265
    +                   ))
    
    266
    +    (assert-true (floatp
    
    267
    +                  (ext:with-float-traps-enabled (:underflow)
    
    268
    +                    (read-from-string (format nil "~A" n)))))))
    
    269
    +
    
    270
    +(define-test reader-restarts.underflow
    
    271
    +    (:tag :issues)
    
    272
    +  ;; Test that we get a restart when reading floating-point numbers
    
    273
    +  ;; that are too small to fit in a float.  Invoke the restart to
    
    274
    +  ;; return 0.  All the numbers must be less than half the
    
    275
    +  ;; leasst-positive float.
    
    276
    +  (dolist (item '(("1e-46" 0f0)
    
    277
    +                  ("1e-999" 0f0)
    
    278
    +                  ("1d-324" 0d0)
    
    279
    +                  ("1d-999" 0d0)))
    
    280
    +    (destructuring-bind (string expected-value)
    
    281
    +        item
    
    282
    +      (assert-equal expected-value
    
    283
    +                    (values (handler-bind
    
    284
    +                                ((reader-error
    
    285
    +                                   (lambda (c)
    
    286
    +                                     (declare (ignore c))
    
    287
    +                                     (invoke-restart 'lisp::continue))))
    
    288
    +                              (read-from-string string)))))))
    
    289
    +   
    
    290
    +