Raymond Toy pushed to branch issue-275b-signal-float-underflow at cmucl / cmucl
Commits:
-
059069f8
by Raymond Toy at 2024-03-24T23:16:11+00:00
-
ad88cf63
by Raymond Toy at 2024-03-24T23:16:13+00:00
-
e2c9eeea
by Raymond Toy at 2024-03-25T14:33:02+00:00
-
8ed3d1d3
by Raymond Toy at 2024-03-25T14:33:07+00:00
-
23f449e4
by Raymond Toy at 2024-03-26T07:46:47-07:00
-
488cbe98
by Raymond Toy at 2024-03-26T07:47:46-07:00
3 changed files:
Changes:
| ... | ... | @@ -2076,7 +2076,9 @@ When annotations are present, invoke them at the right positions." |
| 2076 | 2076 | (c:sc-case pprint-sc-case)
|
| 2077 | 2077 | (c:define-assembly-routine pprint-define-assembly)
|
| 2078 | 2078 | (c:deftransform pprint-defun)
|
| 2079 | - (c:defoptimizer pprint-defun)))
|
|
| 2079 | + (c:defoptimizer pprint-defun)
|
|
| 2080 | + (ext:with-float-traps-masked pprint-with-like)
|
|
| 2081 | + (ext:with-float-traps-enabled pprint-with-like)))
|
|
| 2080 | 2082 | |
| 2081 | 2083 | (defun pprint-init ()
|
| 2082 | 2084 | (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
|
| ... | ... | @@ -1868,17 +1868,20 @@ the end of the stream." |
| 1868 | 1868 | float-format (read-buffer-to-string)))))))
|
| 1869 | 1869 | |
| 1870 | 1870 | ;; Otherwise the number might fit, so we carefully compute the result.
|
| 1871 | - (handler-case
|
|
| 1872 | - (let* ((ratio (/ (* (expt 10 exponent) number)
|
|
| 1873 | - divisor))
|
|
| 1874 | - (result (coerce ratio float-format)))
|
|
| 1875 | - (when (and (zerop result) (not (zerop number)))
|
|
| 1876 | - ;; The number we've read is so small that it gets
|
|
| 1877 | - ;; converted to 0.0, but is not actually zero. Signal an
|
|
| 1878 | - ;; error. See CLHS 2.3.1.1.
|
|
| 1879 | - (error "Underflow"))
|
|
| 1880 | - 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 _"Underflow"))
|
|
| 1881 | + result))
|
|
| 1881 | 1882 | (floating-point-underflow ()
|
| 1883 | + ;; Resignal the underflow, but allow the user to continue with
|
|
| 1884 | + ;; 0.
|
|
| 1882 | 1885 | (let ((zero (coerce 0 float-format)))
|
| 1883 | 1886 | (restart-case
|
| 1884 | 1887 | (error 'floating-point-underflow)
|
| 1 | +;; Tests for pprinter
|
|
| 2 | + |
|
| 3 | +(defpackage :pprint-tests
|
|
| 4 | + (:use :cl :lisp-unit))
|
|
| 5 | + |
|
| 6 | +(in-package "PPRINT-TESTS")
|
|
| 7 | + |
|
| 8 | +(define-test pprint.with-float-traps-masked
|
|
| 9 | + (:tag :issues)
|
|
| 10 | + (assert-equal
|
|
| 11 | +"
|
|
| 12 | +(WITH-FLOAT-TRAPS-MASKED (:UNDERFLOW)
|
|
| 13 | + (PRINT \"Hello\"))"
|
|
| 14 | + (with-output-to-string (s)
|
|
| 15 | + (pprint '(ext:with-float-traps-masked (:underflow)
|
|
| 16 | + (print "Hello"))
|
|
| 17 | + s))))
|
|
| 18 | + |
|
| 19 | +(define-test pprint.with-float-traps-enabled
|
|
| 20 | + (:tag :issues)
|
|
| 21 | + (assert-equal
|
|
| 22 | +"
|
|
| 23 | +(WITH-FLOAT-TRAPS-ENABLED (:UNDERFLOW)
|
|
| 24 | + (PRINT \"Hello\"))"
|
|
| 25 | + (with-output-to-string (s)
|
|
| 26 | + (pprint '(ext:with-float-traps-enabled (:underflow)
|
|
| 27 | + (print "Hello"))
|
|
| 28 | + s)))) |