Raymond Toy pushed to branch master at cmucl / cmucl Commits: 7543b720 by Raymond Toy at 2024-04-02T08:10:23-07:00 Fix #298: Add with-float-rounding-mode macro Add `ext:with-float-rounding-mode` macro to set the FP rounding mode to be used when executing the body. - - - - - bf417b47 by Raymond Toy at 2024-04-02T08:33:30-07:00 Update cmucl.pot with new docstrings - - - - - e32034e0 by Raymond Toy at 2024-04-02T08:33:52-07:00 Add tests for with-float-rounding-mode Not 100% sure the expected results are right. They seem plausible, but I didn't actually analyze that the rounding is correct. - - - - - 6ba75434 by Carl Shapiro at 2024-04-07T23:19:27+00:00 Make variable names consistent. - - - - - 0e716eab by Raymond Toy at 2024-04-07T17:02:55-07:00 Fix typos caused by renaming We renamed `old-rounding-mode` to `old-mode`, but forgot to update all uses. - - - - - 6181fd24 by Raymond Toy at 2024-04-08T05:52:20-07:00 Fix up docstring for with-float-rounding-mode Mention that the allowed values are the same as the values for the rounding-mode in `set-floating-point-modes`. Change indentation of docstring slightly so that it prints nicely via `describe`. (Emacs doesn't indent the docstring by the right amount for `describe`.) - - - - - 659c41bc by Raymond Toy at 2024-04-08T05:58:05-07:00 Remove extra trailing space after period. - - - - - 07a1669b by Raymond Toy at 2024-04-08T06:05:43-07:00 Update cmucl.pot for changed docstring for with-float-rounding-mode. - - - - - a46a530e by Raymond Toy at 2024-04-08T14:00:18+00:00 Merge branch 'issue-298-with-float-rounding-mode' into 'master' Fix #298: Add with-float-rounding-mode macro Closes #298 See merge request cmucl/cmucl!205 - - - - - 4 changed files: - src/code/exports.lisp - src/code/float-trap.lisp - src/i18n/locale/cmucl.pot - tests/float.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -1591,7 +1591,8 @@ "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P" "FLOAT-SIGNALING-NAN-P" "WITH-FLOAT-TRAPS-MASKED" - "WITH-FLOAT-TRAPS-ENABLED") + "WITH-FLOAT-TRAPS-ENABLED" + "WITH-FLOAT-ROUNDING-MODE") ;; More float extensions #+double-double (:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT" ===================================== src/code/float-trap.lisp ===================================== @@ -27,7 +27,8 @@ decode-floating-point-modes encode-floating-point-modes with-float-traps-masked - with-float-traps-enabled)) + with-float-traps-enabled + with-float-rounding-mode)) (in-package "VM") (eval-when (compile load eval) @@ -495,3 +496,34 @@ accrued exceptions are cleared at the start of the body to support their testing within, and restored on exit.")) +(defmacro with-float-rounding-mode ((rounding-mode) &body body) + _N"Execute BODY with the floating-point rounding mode set to + ROUNDING-MODE. ROUNDING-MODE must be a one: + + :NEAREST + the default mode of round to nearest even. + :ZERO + round numbers down towards zero. Positive numbers round down + and negative numbers round up. + :POSITIVE-INFINITY + round numbers up towards positive infinity. + :NEGATIVE-INFINITY + round numbers down towards negative infinity. + + These are the same as the possible values for the rounding mode in + SET-FLOATING-POINT-MODES. + + Only the rounding mode is restored on exit; other floating-point + modes are not modified." + (let ((old-mode (gensym "OLD-MODE-")) + (new-mode (gensym "NEW-MODE-"))) + `(let ((,old-mode (ldb float-rounding-mode (floating-point-modes))) + (,new-mode (cdr (assoc ,rounding-mode rounding-mode-alist)))) + (unwind-protect + (progn + (setf (floating-point-modes) + (dpb ,new-mode float-rounding-mode (floating-point-modes))) + ,@body) + ;; Restore just the rounding mode to the original value. + (setf (floating-point-modes) + (dpb ,old-mode float-rounding-mode (floating-point-modes))))))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -4868,6 +4868,28 @@ msgid "" " their testing within, and restored on exit." msgstr "" +#: src/code/float-trap.lisp +msgid "" +"Execute BODY with the floating-point rounding mode set to\n" +" ROUNDING-MODE. ROUNDING-MODE must be a one:\n" +"\n" +" :NEAREST\n" +" the default mode of round to nearest even.\n" +" :ZERO\n" +" round numbers down towards zero. Positive numbers round down\n" +" and negative numbers round up.\n" +" :POSITIVE-INFINITY\n" +" round numbers up towards positive infinity.\n" +" :NEGATIVE-INFINITY\n" +" round numbers down towards negative infinity.\n" +"\n" +" These are the same as the possible values for the rounding mode in\n" +" SET-FLOATING-POINT-MODES.\n" +"\n" +" Only the rounding mode is restored on exit; other floating-point\n" +" modes are not modified." +msgstr "" + #: src/code/float.lisp msgid "Return true if the float X is denormalized." msgstr "" ===================================== tests/float.lisp ===================================== @@ -212,3 +212,38 @@ ;; most-positive-double-float. And a really big single-float. (assert-error 'reader-error (read-from-string "1.8d308")) (assert-error 'reader-error (read-from-string "1d999999999"))) + +(defun rounding-test (x) + (declare (double-float x) + (optimize (speed 3))) + (* x (/ 1d0 x))) + +(define-test rounding-mode.nearest + (:tag :issues) + (ext:with-float-rounding-mode (:nearest) + (assert-equal 1d0 (rounding-test 3d0)))) + +(define-test rounding-mode.zero.1 + (:tag :issues) + (ext:with-float-rounding-mode (:zero) + (assert-equal 0.9999999999999999d0 + (rounding-test 3d0)))) + +(define-test rounding-mode.zero.2 + (:tag :issues) + (ext:with-float-rounding-mode (:zero) + (assert-equal 0.9999999999999999d0 + (rounding-test -3d0)))) + +(define-test rounding-mode.positive-infinity + (:tag :issues) + (ext:with-float-rounding-mode (:positive-infinity) + (assert-equal 1.0000000000000002d0 + (rounding-test 3d0)))) + +(define-test rounding-mode.negative-infinity + (:tag :issues) + (ext:with-float-rounding-mode (:negative-infinity) + (assert-equal 0.9999999999999999d0 + (rounding-test 3d0)))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/574eef63f932ae5da3fc560... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/574eef63f932ae5da3fc560... You're receiving this email because of your account on gitlab.common-lisp.net.