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 Fix #287: Clean up make-float-aux

- - - - - ad88cf63 by Raymond Toy at 2024-03-24T23:16:13+00:00 Merge branch 'issue-287-clean-up-make-float-aux' into 'master'

Fix #287: Clean up make-float-aux

Closes #287

See merge request cmucl/cmucl!196 - - - - - e2c9eeea by Raymond Toy at 2024-03-25T14:33:02+00:00 Fix #290: Neatly pprint with-float-traps-masked and friends

- - - - - 8ed3d1d3 by Raymond Toy at 2024-03-25T14:33:07+00:00 Merge branch 'issue-290-pprint-with-float-traps' into 'master'

Fix #290: Neatly pprint with-float-traps-masked and friends

Closes #290

See merge request cmucl/cmucl!199 - - - - - 23f449e4 by Raymond Toy at 2024-03-26T07:46:47-07:00 Merge branch 'master' into issue-275b-signal-float-underflow

- - - - - 488cbe98 by Raymond Toy at 2024-03-26T07:47:46-07:00 Add a comment about continuing with 0

- - - - -

3 changed files:

- src/code/pprint.lisp - src/code/reader.lisp - + tests/pprint.lisp

Changes:

===================================== src/code/pprint.lisp ===================================== @@ -2076,7 +2076,9 @@ When annotations are present, invoke them at the right positions." (c:sc-case pprint-sc-case) (c:define-assembly-routine pprint-define-assembly) (c:deftransform pprint-defun) - (c:defoptimizer pprint-defun))) + (c:defoptimizer pprint-defun) + (ext:with-float-traps-masked pprint-with-like) + (ext:with-float-traps-enabled pprint-with-like)))

(defun pprint-init () (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))

===================================== src/code/reader.lisp ===================================== @@ -1868,17 +1868,20 @@ the end of the stream." float-format (read-buffer-to-string)))))))

;; Otherwise the number might fit, so we carefully compute the result. - (handler-case - (let* ((ratio (/ (* (expt 10 exponent) number) - divisor)) - (result (coerce ratio float-format))) - (when (and (zerop result) (not (zerop number))) - ;; The number we've read is so small that it gets - ;; converted to 0.0, but is not actually zero. Signal an - ;; error. See CLHS 2.3.1.1. - (error "Underflow")) - result) + (handler-case + (with-float-traps-masked (:underflow) + (let* ((ratio (/ (* (expt 10 exponent) number) + divisor)) + (result (coerce ratio float-format))) + (when (and (zerop result) (not (zerop number))) + ;; The number we've read is so small that it gets + ;; converted to 0.0, but is not actually zero. Signal an + ;; error. See CLHS 2.3.1.1. + (error _"Underflow")) + result)) (floating-point-underflow () + ;; Resignal the underflow, but allow the user to continue with + ;; 0. (let ((zero (coerce 0 float-format))) (restart-case (error 'floating-point-underflow)

===================================== tests/pprint.lisp ===================================== @@ -0,0 +1,28 @@ +;; Tests for pprinter + +(defpackage :pprint-tests + (:use :cl :lisp-unit)) + +(in-package "PPRINT-TESTS") + +(define-test pprint.with-float-traps-masked + (:tag :issues) + (assert-equal +" +(WITH-FLOAT-TRAPS-MASKED (:UNDERFLOW) + (PRINT "Hello"))" + (with-output-to-string (s) + (pprint '(ext:with-float-traps-masked (:underflow) + (print "Hello")) + s)))) + +(define-test pprint.with-float-traps-enabled + (:tag :issues) + (assert-equal +" +(WITH-FLOAT-TRAPS-ENABLED (:UNDERFLOW) + (PRINT "Hello"))" + (with-output-to-string (s) + (pprint '(ext:with-float-traps-enabled (:underflow) + (print "Hello")) + s))))

View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/45532060060f711842edbfb...