Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
-
7543b720
by Raymond Toy at 2024-04-02T08:10:23-07:00
-
bf417b47
by Raymond Toy at 2024-04-02T08:33:30-07:00
-
e32034e0
by Raymond Toy at 2024-04-02T08:33:52-07:00
-
6ba75434
by Carl Shapiro at 2024-04-07T23:19:27+00:00
-
0e716eab
by Raymond Toy at 2024-04-07T17:02:55-07:00
-
6181fd24
by Raymond Toy at 2024-04-08T05:52:20-07:00
-
659c41bc
by Raymond Toy at 2024-04-08T05:58:05-07:00
-
07a1669b
by Raymond Toy at 2024-04-08T06:05:43-07:00
-
a46a530e
by Raymond Toy at 2024-04-08T14:00:18+00:00
4 changed files:
Changes:
| ... | ... | @@ -1591,7 +1591,8 @@ |
| 1591 | 1591 | "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"
|
| 1592 | 1592 | "FLOAT-SIGNALING-NAN-P"
|
| 1593 | 1593 | "WITH-FLOAT-TRAPS-MASKED"
|
| 1594 | - "WITH-FLOAT-TRAPS-ENABLED")
|
|
| 1594 | + "WITH-FLOAT-TRAPS-ENABLED"
|
|
| 1595 | + "WITH-FLOAT-ROUNDING-MODE")
|
|
| 1595 | 1596 | ;; More float extensions
|
| 1596 | 1597 | #+double-double
|
| 1597 | 1598 | (:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT"
|
| ... | ... | @@ -27,7 +27,8 @@ |
| 27 | 27 | decode-floating-point-modes
|
| 28 | 28 | encode-floating-point-modes
|
| 29 | 29 | with-float-traps-masked
|
| 30 | - with-float-traps-enabled))
|
|
| 30 | + with-float-traps-enabled
|
|
| 31 | + with-float-rounding-mode))
|
|
| 31 | 32 | (in-package "VM")
|
| 32 | 33 | |
| 33 | 34 | (eval-when (compile load eval)
|
| ... | ... | @@ -495,3 +496,34 @@ |
| 495 | 496 | accrued exceptions are cleared at the start of the body to support
|
| 496 | 497 | their testing within, and restored on exit."))
|
| 497 | 498 | |
| 499 | +(defmacro with-float-rounding-mode ((rounding-mode) &body body)
|
|
| 500 | + _N"Execute BODY with the floating-point rounding mode set to
|
|
| 501 | + ROUNDING-MODE. ROUNDING-MODE must be a one:
|
|
| 502 | + |
|
| 503 | + :NEAREST
|
|
| 504 | + the default mode of round to nearest even.
|
|
| 505 | + :ZERO
|
|
| 506 | + round numbers down towards zero. Positive numbers round down
|
|
| 507 | + and negative numbers round up.
|
|
| 508 | + :POSITIVE-INFINITY
|
|
| 509 | + round numbers up towards positive infinity.
|
|
| 510 | + :NEGATIVE-INFINITY
|
|
| 511 | + round numbers down towards negative infinity.
|
|
| 512 | + |
|
| 513 | + These are the same as the possible values for the rounding mode in
|
|
| 514 | + SET-FLOATING-POINT-MODES.
|
|
| 515 | + |
|
| 516 | + Only the rounding mode is restored on exit; other floating-point
|
|
| 517 | + modes are not modified."
|
|
| 518 | + (let ((old-mode (gensym "OLD-MODE-"))
|
|
| 519 | + (new-mode (gensym "NEW-MODE-")))
|
|
| 520 | + `(let ((,old-mode (ldb float-rounding-mode (floating-point-modes)))
|
|
| 521 | + (,new-mode (cdr (assoc ,rounding-mode rounding-mode-alist))))
|
|
| 522 | + (unwind-protect
|
|
| 523 | + (progn
|
|
| 524 | + (setf (floating-point-modes)
|
|
| 525 | + (dpb ,new-mode float-rounding-mode (floating-point-modes)))
|
|
| 526 | + ,@body)
|
|
| 527 | + ;; Restore just the rounding mode to the original value.
|
|
| 528 | + (setf (floating-point-modes)
|
|
| 529 | + (dpb ,old-mode float-rounding-mode (floating-point-modes))))))) |
| ... | ... | @@ -4868,6 +4868,28 @@ msgid "" |
| 4868 | 4868 | " their testing within, and restored on exit."
|
| 4869 | 4869 | msgstr ""
|
| 4870 | 4870 | |
| 4871 | +#: src/code/float-trap.lisp
|
|
| 4872 | +msgid ""
|
|
| 4873 | +"Execute BODY with the floating-point rounding mode set to\n"
|
|
| 4874 | +" ROUNDING-MODE. ROUNDING-MODE must be a one:\n"
|
|
| 4875 | +"\n"
|
|
| 4876 | +" :NEAREST\n"
|
|
| 4877 | +" the default mode of round to nearest even.\n"
|
|
| 4878 | +" :ZERO\n"
|
|
| 4879 | +" round numbers down towards zero. Positive numbers round down\n"
|
|
| 4880 | +" and negative numbers round up.\n"
|
|
| 4881 | +" :POSITIVE-INFINITY\n"
|
|
| 4882 | +" round numbers up towards positive infinity.\n"
|
|
| 4883 | +" :NEGATIVE-INFINITY\n"
|
|
| 4884 | +" round numbers down towards negative infinity.\n"
|
|
| 4885 | +"\n"
|
|
| 4886 | +" These are the same as the possible values for the rounding mode in\n"
|
|
| 4887 | +" SET-FLOATING-POINT-MODES.\n"
|
|
| 4888 | +"\n"
|
|
| 4889 | +" Only the rounding mode is restored on exit; other floating-point\n"
|
|
| 4890 | +" modes are not modified."
|
|
| 4891 | +msgstr ""
|
|
| 4892 | + |
|
| 4871 | 4893 | #: src/code/float.lisp
|
| 4872 | 4894 | msgid "Return true if the float X is denormalized."
|
| 4873 | 4895 | msgstr ""
|
| ... | ... | @@ -212,3 +212,38 @@ |
| 212 | 212 | ;; most-positive-double-float. And a really big single-float.
|
| 213 | 213 | (assert-error 'reader-error (read-from-string "1.8d308"))
|
| 214 | 214 | (assert-error 'reader-error (read-from-string "1d999999999")))
|
| 215 | + |
|
| 216 | +(defun rounding-test (x)
|
|
| 217 | + (declare (double-float x)
|
|
| 218 | + (optimize (speed 3)))
|
|
| 219 | + (* x (/ 1d0 x)))
|
|
| 220 | + |
|
| 221 | +(define-test rounding-mode.nearest
|
|
| 222 | + (:tag :issues)
|
|
| 223 | + (ext:with-float-rounding-mode (:nearest)
|
|
| 224 | + (assert-equal 1d0 (rounding-test 3d0))))
|
|
| 225 | + |
|
| 226 | +(define-test rounding-mode.zero.1
|
|
| 227 | + (:tag :issues)
|
|
| 228 | + (ext:with-float-rounding-mode (:zero)
|
|
| 229 | + (assert-equal 0.9999999999999999d0
|
|
| 230 | + (rounding-test 3d0))))
|
|
| 231 | + |
|
| 232 | +(define-test rounding-mode.zero.2
|
|
| 233 | + (:tag :issues)
|
|
| 234 | + (ext:with-float-rounding-mode (:zero)
|
|
| 235 | + (assert-equal 0.9999999999999999d0
|
|
| 236 | + (rounding-test -3d0))))
|
|
| 237 | + |
|
| 238 | +(define-test rounding-mode.positive-infinity
|
|
| 239 | + (:tag :issues)
|
|
| 240 | + (ext:with-float-rounding-mode (:positive-infinity)
|
|
| 241 | + (assert-equal 1.0000000000000002d0
|
|
| 242 | + (rounding-test 3d0))))
|
|
| 243 | + |
|
| 244 | +(define-test rounding-mode.negative-infinity
|
|
| 245 | + (:tag :issues)
|
|
| 246 | + (ext:with-float-rounding-mode (:negative-infinity)
|
|
| 247 | + (assert-equal 0.9999999999999999d0
|
|
| 248 | + (rounding-test 3d0))))
|
|
| 249 | + |