May 2026 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][rtoy-print-using-ryu] Use updated branch for ansi-tests
by Raymond Toy (＠rtoy) 28 May '26

28 May '26

Raymond Toy pushed to branch rtoy-print-using-ryu at cmucl / cmucl Commits: c7371263 by Raymond Toy at 2026-05-28T09:34:30-07:00 Use updated branch for ansi-tests The ryu printer fixes many format issues, so use the correct branch with the unexpected successes removed. Update cmucl.pot too. - - - - - 2 changed files: - bin/run-ansi-tests.sh - src/i18n/locale/cmucl.pot Changes: ===================================== bin/run-ansi-tests.sh ===================================== @@ -36,7 +36,8 @@ shift $((OPTIND - 1)) # Use branch cmucl-expected-failures in general since this branch # generally has the list of expected failures. This is the branch to # use on cmucl master in general. -BRANCH=cmucl-expected-failures +#BRANCH=cmucl-expected-failures +BRANCH=rtoy-print-using-ryu set -x if [ -d ../ansi-test ]; then ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -7449,6 +7449,13 @@ msgid "" " form." msgstr "" +#: src/code/ryu-print.lisp +msgid "" +"Return the number of significant digits in MANTISSA, a string of\n" +" the form \"d\" or \"d.dddd\" (as produced by d2s/d2exp). The decimal\n" +" point, if present, is not counted." +msgstr "" + #: src/code/ryu-print.lisp msgid "" "Number of decimal digits in N. N is the absolute value of a\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c7371263d0f63d589c31701… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c7371263d0f63d589c31701… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-print-using-ryu] Avoid consing in emit-rounded-to-width
by Raymond Toy (＠rtoy) 28 May '26

28 May '26

Raymond Toy pushed to branch rtoy-print-using-ryu at cmucl / cmucl Commits: 49579612 by Raymond Toy at 2026-05-28T07:52:41-07:00 Avoid consing in emit-rounded-to-width Don't cons up strings. Instead, keep track of where the decimal point is and emit the parts based on the location of the decimal. - - - - - 1 changed file: - src/code/ryu-print.lisp Changes: ===================================== src/code/ryu-print.lisp ===================================== @@ -124,6 +124,15 @@ (values mantissa (truly-the (signed-byte 11) exp)))) +(declaim (inline mantissa-digit-count)) +(defun mantissa-digit-count (mantissa) + "Return the number of significant digits in MANTISSA, a string of + the form \"d\" or \"d.dddd\" (as produced by d2s/d2exp). The decimal + point, if present, is not counted." + (declare (type string mantissa)) + (- (length mantissa) + (if (find #\. mantissa) 1 0))) + (defun compute-d-for-width (w e k actual-exp is-negative-p at-sign-p) ;; Find the largest d (precision) value that fits in width W given ;; the actual exponent (adjusted by k), and whether signs are @@ -175,9 +184,7 @@ (let* ((sign-len (if (or is-negative-p at-sign-p) 1 0)) (exp-digits (max (or e 1) (count-decimal-digits (abs actual-exp)))) - (dotp (find #\. mantissa)) - (raw-digits (let ((len (length mantissa))) - (if dotp (1- len) len))) + (raw-digits (mantissa-digit-count mantissa)) (mantissa-len (cond ((plusp k) @@ -462,10 +469,8 @@ overflowchar padchar at-sign-p) (declare (type simple-string mantissa) (type (signed-byte 10) exponent)) - (let* ((has-dot (find #\. mantissa)) - ;; Number of digits, not including the decimal point. - (digit-count (- (length mantissa) - (if has-dot 1 0))) + (let* (;; Number of digits, not including the decimal point. + (digit-count (mantissa-digit-count mantissa)) (sign-len (if (or is-negative-p at-sign-p) 1 0)) (reshaped-len (reshape-fixed-length digit-count exponent)) (field-len (+ sign-len reshaped-len))) @@ -478,6 +483,55 @@ (declare (dynamic-extent #'write-field)) (pad-overflow stream field-len w overflowchar padchar #'write-field)))) +(defun emit-rounded-to-width (stream value frac is-negative-p w + overflowchar padchar at-sign-p) + "Round (the magnitude of) VALUE to FRAC fractional digits with + d2fixed and write it right-justified in a field of width W. At + least one fractional digit is always shown: if FRAC is 0 the + rounded value is integral and a single \"0\" is appended after the + decimal point (CLHS 22.3.3.1). The optional leading zero before + the decimal point is dropped when the field would otherwise + overflow W. Used by the free-format ~F path when the shortest + representation does not fit in W." + (declare (type (or single-float double-float) value) + (type (integer 0 *) frac)) + (let* ((rounded (d2fixed (float (abs value) 1d0) frac)) + (len (length rounded)) + ;; ROUNDED is "ddd" (frac=0) or "ddd.ddd" (frac>0). Locate the + ;; decimal point and the integer/fractional digit spans without + ;; allocating substrings. + (dot (position #\. rounded)) + (int-end (or dot len)) + (frac-start (if dot (1+ dot) len)) + (frac-len (- len frac-start)) + ;; At least one fractional digit is always shown; when there are + ;; none a single "0" is emitted instead. + (frac-out-len (max 1 frac-len)) + (sign-len (if (or is-negative-p at-sign-p) 1 0)) + ;; The leading "0." may be shortened to "." when the magnitude + ;; is < 1 (integer part is the single digit "0") and nonzero, + ;; and the full field would not fit in W. + (lpoint-droppable + (and (= int-end 1) + (char= (char rounded 0) #\0) + (not (zerop value)))) + (full-len (+ sign-len int-end 1 frac-out-len)) + (drop-leading-zero-p + (and lpoint-droppable w (> full-len w))) + (field-len (if drop-leading-zero-p (1- full-len) full-len))) + (flet ((write-field () + (cond (is-negative-p (write-char #\- stream)) + (at-sign-p (write-char #\+ stream))) + (unless drop-leading-zero-p + (write-string rounded stream :start 0 :end int-end)) + (write-char #\. stream) + (cond ((zerop frac-len) + (write-char #\0 stream)) + (t + (write-string rounded stream :start frac-start :end len))))) + (declare (dynamic-extent #'write-field)) + (pad-overflow stream field-len w overflowchar padchar #'write-field)))) + (defun format-f-free (stream value w overflowchar padchar at-sign-p) (declare (type (or single-float double-float) value)) @@ -486,8 +540,7 @@ (declare (ignore abs-value)) (multiple-value-bind (mantissa exponent) (parsed-exp-form (float-to-string value)) - (let* ((has-dot (find #\. mantissa)) - (digit-count (if has-dot (1- (length mantissa)) (length mantissa))) + (let* ((digit-count (mantissa-digit-count mantissa)) (int-len (max 1 (1+ exponent))) (shortest-d (max 0 (- digit-count 1 exponent))) (sign-len (if (or is-negative-p at-sign-p) 1 0)) @@ -524,47 +577,6 @@ is-negative-p w overflowchar padchar at-sign-p))))))) -(defun emit-rounded-to-width (stream value frac is-negative-p w - overflowchar padchar at-sign-p) - "Round (the magnitude of) VALUE to FRAC fractional digits with - d2fixed and write it right-justified in a field of width W. At - least one fractional digit is always shown: if FRAC is 0 the - rounded value is integral and a single \"0\" is appended after the - decimal point (CLHS 22.3.3.1). The optional leading zero before - the decimal point is dropped when the field would otherwise - overflow W. Used by the free-format ~F path when the shortest - representation does not fit in W." - (declare (type (or single-float double-float) value) - (type (integer 0 *) frac)) - (let* ((rounded (d2fixed (float (abs value) 1d0) frac)) - ;; ROUNDED is "ddd" (frac=0) or "ddd.ddd" (frac>0). Split it - ;; into integer and fractional digit runs. - (dot (position #\. rounded)) - (int-part (if dot (subseq rounded 0 dot) rounded)) - (frac-part (if dot (subseq rounded (1+ dot)) "")) - ;; Force at least one fractional digit. - (frac-out (if (zerop (length frac-part)) "0" frac-part)) - (sign-len (if (or is-negative-p at-sign-p) 1 0)) - ;; The leading "0." may be shortened to "." when the magnitude - ;; is < 1 (integer part is a single "0") and nonzero, and the - ;; full field would not fit in W. - (lpoint-droppable - (and (string= int-part "0") - (not (zerop value)))) - (full-len (+ sign-len (length int-part) 1 (length frac-out))) - (drop-leading-zero-p - (and lpoint-droppable w (> full-len w))) - (field-len (if drop-leading-zero-p (1- full-len) full-len))) - (flet ((write-field () - (cond (is-negative-p (write-char #\- stream)) - (at-sign-p (write-char #\+ stream))) - (unless drop-leading-zero-p - (write-string int-part stream)) - (write-char #\. stream) - (write-string frac-out stream))) - (declare (dynamic-extent #'write-field)) - (pad-overflow stream field-len w overflowchar padchar #'write-field)))) - (defun format-f (value w d k overflowchar padchar at-sign-p) (declare (type (or single-float double-float) value) (fixnum k) @@ -591,9 +603,7 @@ (type (or null (and unsigned-byte fixnum)) w d e)) (multiple-value-bind (mantissa exponent) (parsed-exp-form (float-to-string value)) - (let* ((digit-count (- (length mantissa) - (if (find #\. mantissa) - 1 0))) + (let* ((digit-count (mantissa-digit-count mantissa)) (n (1+ exponent)) (effective-d (or d (max digit-count (min n 7)))) (ee (if e (+ e 2) 4)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/495796125c843e1f6b280df… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/495796125c843e1f6b280df… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-print-using-ryu] Round ~F to width when d is unspecified
by Raymond Toy (＠rtoy) 28 May '26

28 May '26

Raymond Toy pushed to branch rtoy-print-using-ryu at cmucl / cmucl Commits: 0a9c9c7c by Raymond Toy at 2026-05-28T07:23:00-07:00 Round ~F to width when d is unspecified `format-f-free` emitted the un-rounded shortest form when it didn't fit in the field width of w. Add `emit-rounded-to-width`: round to the fractional digits that fit, always showing at least one (CLHS 22.3.3.1), dropping the leading zero to fit. Fixes ansi-tests FORMAT.F.45 and F.47. Tests in ryu.lisp also updated because they erroneously used the un-rounded result instead of one that fits in the specified width. - - - - - 3 changed files: - src/code/ryu-print.lisp - src/i18n/locale/cmucl.pot - tests/ryu.lisp Changes: ===================================== src/code/ryu-print.lisp ===================================== @@ -491,24 +491,79 @@ (int-len (max 1 (1+ exponent))) (shortest-d (max 0 (- digit-count 1 exponent))) (sign-len (if (or is-negative-p at-sign-p) 1 0)) - (d-fit (and w (- w sign-len int-len 1)))) + (d-fit (and w (- w sign-len int-len 1))) + ;; When the magnitude is < 1 the integer part is a single + ;; "0" that may be dropped (the leading zero is optional), + ;; freeing one more slot for a fractional digit. Compute + ;; the fractional-digit count that exactly fills W under + ;; that rule. + (frac-fit (and w + (if (plusp (1+ exponent)) + (- w sign-len int-len 1) ; "[int]." + (- w sign-len 1))))) ; ".[frac]" (cond ((or (null w) (>= d-fit shortest-d)) - ;; No width or the shortest form fits within a field width - ;; of W. + ;; No width, or the shortest round-trip form already fits + ;; within a field width of W. Emit it directly. (emit-shortest stream mantissa exponent is-negative-p w overflowchar padchar at-sign-p)) - (overflowchar - ;; Shortest form does not fit and OVERFLOWCHAR is set; fill - ;; the field with overflow characters. + ((and overflowchar (minusp frac-fit)) + ;; Not even the integer part and decimal point fit, and an + ;; overflow character was supplied: fill the field. (loop repeat w do (write-char overflowchar stream))) (t - ;; Shortest form does not fit and no OVERFLOWCHAR; emit the - ;; full shortest form, letting the field expand. CLHS - ;; 22.3.3.1 requires this. - (emit-shortest stream mantissa exponent is-negative-p w - overflowchar padchar at-sign-p))))))) + ;; The shortest form does not fit in W. D was not specified, + ;; so round the value to the largest number of fractional + ;; digits FRAC-FIT that fits, then display it. Per CLHS + ;; 22.3.3.1, if the fraction rounds away to nothing a single + ;; zero digit must still appear after the decimal point. We + ;; therefore round at FRAC-FIT places (which may be 0) but + ;; always show at least one fractional digit. + (emit-rounded-to-width stream value (max 0 frac-fit) + is-negative-p w + overflowchar padchar at-sign-p))))))) + +(defun emit-rounded-to-width (stream value frac is-negative-p w + overflowchar padchar at-sign-p) + "Round (the magnitude of) VALUE to FRAC fractional digits with + d2fixed and write it right-justified in a field of width W. At + least one fractional digit is always shown: if FRAC is 0 the + rounded value is integral and a single \"0\" is appended after the + decimal point (CLHS 22.3.3.1). The optional leading zero before + the decimal point is dropped when the field would otherwise + overflow W. Used by the free-format ~F path when the shortest + representation does not fit in W." + (declare (type (or single-float double-float) value) + (type (integer 0 *) frac)) + (let* ((rounded (d2fixed (float (abs value) 1d0) frac)) + ;; ROUNDED is "ddd" (frac=0) or "ddd.ddd" (frac>0). Split it + ;; into integer and fractional digit runs. + (dot (position #\. rounded)) + (int-part (if dot (subseq rounded 0 dot) rounded)) + (frac-part (if dot (subseq rounded (1+ dot)) "")) + ;; Force at least one fractional digit. + (frac-out (if (zerop (length frac-part)) "0" frac-part)) + (sign-len (if (or is-negative-p at-sign-p) 1 0)) + ;; The leading "0." may be shortened to "." when the magnitude + ;; is < 1 (integer part is a single "0") and nonzero, and the + ;; full field would not fit in W. + (lpoint-droppable + (and (string= int-part "0") + (not (zerop value)))) + (full-len (+ sign-len (length int-part) 1 (length frac-out))) + (drop-leading-zero-p + (and lpoint-droppable w (> full-len w))) + (field-len (if drop-leading-zero-p (1- full-len) full-len))) + (flet ((write-field () + (cond (is-negative-p (write-char #\- stream)) + (at-sign-p (write-char #\+ stream))) + (unless drop-leading-zero-p + (write-string int-part stream)) + (write-char #\. stream) + (write-string frac-out stream))) + (declare (dynamic-extent #'write-field)) + (pad-overflow stream field-len w overflowchar padchar #'write-field)))) (defun format-f (value w d k overflowchar padchar at-sign-p) (declare (type (or single-float double-float) value) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -7477,6 +7477,18 @@ msgid "" " the double-float absolute value of VALUE." msgstr "" +#: src/code/ryu-print.lisp +msgid "" +"Round (the magnitude of) VALUE to FRAC fractional digits with\n" +" d2fixed and write it right-justified in a field of width W. At\n" +" least one fractional digit is always shown: if FRAC is 0 the\n" +" rounded value is integral and a single \"0\" is appended after the\n" +" decimal point (CLHS 22.3.3.1). The optional leading zero before\n" +" the decimal point is dropped when the field would otherwise\n" +" overflow W. Used by the free-format ~F path when the shortest\n" +" representation does not fit in W." +msgstr "" + #: src/code/print.lisp msgid "" "If true, all objects will printed readably. If readably printing is\n" ===================================== tests/ryu.lisp ===================================== @@ -367,20 +367,17 @@ (assert-equal " 1.0" (lisp::format-f 1d0 10 nil 0 nil nil nil))) -(define-test format-f.d-nil-with-w-no-shrink +(define-test format-f.d-nil-with-w-shrinks (:tag :format-f) - ;; CLHS 22.3.3.1: when d is unspecified, the digit count is set so - ;; that the result reads back as an EQUAL float, with no extraneous - ;; trailing zeros. This is the round-trip count. When the result - ;; does not fit in w and no overflowchar is supplied, the field - ;; expands -- it does NOT shrink the digits, because doing so would - ;; produce a different float on read-back. (Earlier ryu code did - ;; shrink here; that change was needed to pass ANSI FORMAT.F.5.) - (assert-equal "1.234567" + ;; d=nil with a tight width: CL rounds the value to the largest + ;; number of fractional digits that fits in W (matching the B&D + ;; reference output). 3.141592653589793 shrinks to fit; 1.234567 + ;; with w=6 rounds to "1.2346". + (assert-equal "1.2346" (lisp::format-f 1.234567d0 6 nil 0 nil nil nil)) - (assert-equal "3.141592653589793" + (assert-equal "3.14159265" (lisp::format-f 3.141592653589793d0 10 nil 0 nil nil nil)) - (assert-equal "3.141592653589793" + (assert-equal "3.141593" (lisp::format-f 3.141592653589793d0 8 nil 0 nil nil nil))) (define-test format-f.d-nil-with-w-overflow @@ -755,10 +752,11 @@ (define-test format-f.single-narrow-width-no-overflow-char (:tag :format-f :single-float) - ;; CLHS 22.3.3.1: when the shortest form does not fit in the - ;; specified width and no overflow character is supplied, the field - ;; expands rather than truncating digits. Round-trip and the - ;; "at least one digit after the decimal point" rule must both hold. + ;; ~F with unspecified d and a width too small for the shortest form: + ;; the value is rounded to the fractional digits that fit, but at + ;; least one fractional digit is always shown (CLHS 22.3.3.1). With + ;; no overflow char the field expands when even that minimum + ;; doesn't fit. 1.0 -> "1.0". (assert-equal "1.0" (lisp::format-f 1.0f0 2 nil 0 nil nil nil)) (assert-equal "1.0" @@ -767,6 +765,21 @@ (assert-equal "1.0" (lisp::format-f 1.0d0 2 nil 0 nil nil nil))) +(define-test format-f.d-nil-rounds-to-width-with-forced-zero + (:tag :format-f) + ;; ANSI FORMAT.F.45/F.47: ~F with unspecified d rounds the value to + ;; the fractional digits that fit in W, but always shows at least one + ;; fractional digit (a single "0" if the fraction rounds away). The + ;; field expands past W when even that minimum doesn't fit and no + ;; overflow char is given. + ;; ~2f of 1.1 and 1.9 round to integers, forced ".0", overflow to 3. + (assert-equal "1.0" (lisp::format-f 1.1f0 2 nil 0 nil nil nil)) + (assert-equal "2.0" (lisp::format-f 1.9f0 2 nil 0 nil nil nil)) + ;; ~3f of 1e-6: rounds to .00 (leading zero dropped to fit width 3). + (assert-equal ".00" (lisp::format-f 1.0f-6 3 nil 0 nil nil nil)) + ;; ~4f of 1e-6: .000. + (assert-equal ".000" (lisp::format-f 1.0f-6 4 nil 0 nil nil nil))) + (define-test format-f.single-narrow-width-with-overflow-char (:tag :format-f :single-float) ;; With overflowchar supplied, the field is filled with the overflow View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0a9c9c7c673cc6f9342ae9a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0a9c9c7c673cc6f9342ae9a… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-print-using-ryu] Fix Ryu format-g to pass user's d to format-e
by Raymond Toy (＠rtoy) 27 May '26

27 May '26

Raymond Toy pushed to branch rtoy-print-using-ryu at cmucl / cmucl Commits: dc28a0ad by Raymond Toy at 2026-05-26T21:11:56-07:00 Fix Ryu format-g to pass user's d to format-e Previously, format-g called format-e with `effective-d` instead of `d`. But CLHS 22.3.3.3 specifies that when ~E is called, the user's original d is used. One example Before: (format nil "~g" 1.5d-10) => "1.50d-10" After: (format nil "~g" 1.5d-10) => "1.5d-10" The latter is correct. Adjusted the existing format-g tests and added a regression test for 1.5d-10. - - - - - 2 changed files: - src/code/ryu-print.lisp - tests/ryu.lisp Changes: ===================================== src/code/ryu-print.lisp ===================================== @@ -555,6 +555,10 @@ (format-f value ww dd 0 overflowchar padchar at-sign-p) (make-string ee :initial-element #\space))) (t - ;; ~E form - (format-e value w effective-d e k overflowchar padchar exponentchar at-sign-p)))))) + ;; ~E form. CLHS 22.3.3.3 specifies the resulting call as + ;; "~w,d,e,k,...,E" -- using the user's original D, not the + ;; EFFECTIVE-D computed for the ~F-vs-~E decision. When D is + ;; NIL this lets format-e produce its free-format (shortest) + ;; output rather than fixed-precision. + (format-e value w d e k overflowchar padchar exponentchar at-sign-p)))))) ===================================== tests/ryu.lisp ===================================== @@ -518,11 +518,12 @@ (define-test format-g.large-uses-e (:tag :format-g) ;; Values with n > 7 should fall into ~E form (no trailing spaces). - ;; 1d10 has n=11, q=1, effective-d = max(1, 7) = 7, dd = 7-11 = -4. - ;; ~E with effective-d = 7: 1.0000000d+10. - (assert-equal "1.0000000d+10" + ;; Per CLHS 22.3.3.3, when D is unspecified ~G's ~E call also has + ;; D unspecified, so ~E uses free-format (shortest) output rather + ;; than fixed precision. + (assert-equal "1.0d+10" (lisp::format-g 1d10 nil nil nil 1 nil nil #\d nil)) - (assert-equal "1.0000000d+100" + (assert-equal "1.0d+100" (lisp::format-g 1d100 nil nil nil 1 nil nil #\d nil))) (define-test format-g.small-uses-e @@ -563,8 +564,9 @@ (:tag :format-g) ;; e parameter controls exponent width in the ~E branch and ee in ;; the ~F branch (ee = e + 2). - ;; 1d10 with e=3: ~E with 3-digit exponent, "1.0000000d+010". - (assert-equal "1.0000000d+010" + ;; 1d10 with e=3: ~E with 3-digit exponent. D is unspecified so + ;; ~E uses free-format, giving "1.0d+010". + (assert-equal "1.0d+010" (lisp::format-g 1d10 nil nil 3 1 nil nil #\d nil)) ;; 3.14 with e=3: ~F branch, ee = 5 trailing spaces. (assert-equal "3.14 " @@ -577,7 +579,7 @@ (lisp::format-g 3.14d0 nil nil nil 1 nil nil #\d t)) (assert-equal "-3.14 " (lisp::format-g -3.14d0 nil nil nil 1 nil nil #\d t)) - (assert-equal "+1.0000000d+10" + (assert-equal "+1.0d+10" (lisp::format-g 1d10 nil nil nil 1 nil nil #\d t))) (define-test format-g.boundary-n-7 @@ -587,10 +589,26 @@ ;; dd = 0 is in [0, d] so ~F path with d=0. Output: "1000000." + 4 sp. (assert-equal "1000000. " (lisp::format-g 1d6 nil nil nil 1 nil nil #\d nil)) - ;; 1d7 has n=8, dd = 7-8 = -1, falls into ~E. - (assert-equal "1.0000000d+7" + ;; 1d7 has n=8, dd = 7-8 = -1, falls into ~E. D is unspecified so + ;; ~E uses free-format. + (assert-equal "1.0d+7" (lisp::format-g 1d7 nil nil nil 1 nil nil #\d nil))) +(define-test format-g.d-nil-routes-to-e-with-d-nil + (:tag :format-g) + ;; CLHS 22.3.3.3 specifies that when ~G falls through to the ~E + ;; branch, the ~E directive is called with the user's original D + ;; (per "~w,d,e,k,...,E"), NOT the EFFECTIVE-D that ~G computed for + ;; the ~F-vs-~E decision. This makes a visible difference when D + ;; was originally NIL: ~E then produces its free-format (shortest) + ;; output rather than the longer fixed-precision form. + ;; 1.5d-10 has n=-9, q=2, effective-d=2, dd=11 -> ~E with D=nil. + (assert-equal "1.5d-10" + (lisp::format-g 1.5d-10 nil nil nil 1 nil nil #\d nil)) + ;; If we passed effective-d=2 to ~E we'd get "1.50d-10" instead. + (assert-false (equal "1.50d-10" + (lisp::format-g 1.5d-10 nil nil nil 1 nil nil #\d nil)))) + (define-test format-g.padchar (:tag :format-g) ;; padchar passed through to whichever sub-formatter fires. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dc28a0ad6ab31c787d37ca4… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dc28a0ad6ab31c787d37ca4… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-print-using-ryu] 3 commits: Fix double rounding when reading denormal float literals
by Raymond Toy (＠rtoy) 27 May '26

27 May '26

Raymond Toy pushed to branch rtoy-print-using-ryu at cmucl / cmucl Commits: 50d9df5c by Raymond Toy at 2026-05-26T18:47:45-07:00 Fix double rounding when reading denormal float literals `float-ratio-float` was always rounding the rational full precision before handing the result to `scale-float`. When the result was a denormal, `scale-float-maybe-underflow` could then round the number again to remove some bits to fit in a denormal. This causes double rounding as seen with "7.290983e-39". To fix this `float-ratio-float` re-rounds directly to denormal range. The number of extra bits in the denormal is detected and the extra bits are dropped using round-to-nearest-even. The denormal is emitted directly so `scale-float` isn't involved. The normal path is unchanged and `scale-float-maybe-underflow` still needs correctly rounding in case `scale-float` would produce a denormal. - - - - - bc6c560e by Raymond Toy at 2026-05-26T18:56:29-07:00 Add tests to exercise float-ratio-float Each test calls `float-ratio-float` with an exact rational to test a specific branch of the new helpers. - - - - - 94858a23 by Raymond Toy at 2026-05-26T20:41:16-07:00 Merge branch 'issue-504-read-denormals-with-rounding' into rtoy-print-using-ryu - - - - - 2 changed files: - src/code/float.lisp - tests/float.lisp Changes: ===================================== src/code/float.lisp ===================================== @@ -1152,26 +1152,74 @@ (assert (= len (the fixnum (1+ digits)))) (multiple-value-bind (f0) (floatit (ash bits -1)) - #+nil - (progn - (format t "x = ~A~%" x) - (format t "1: f0, f1 = ~A~%" f0) - (format t " scale = ~A~%" (1+ scale))) - (scale-float f0 (1+ scale)))) (t (multiple-value-bind (f0) (floatit bits) - #+nil - (progn - (format t "2: f0, f1 = ~A~%" f0) - (format t " scale = ~A~%" scale) - (format t "scale-float f0 = ~A~%" (scale-float f0 scale))) - ;; SCALE-FLOAT-MAYBE-UNDERFLOW correctly rounds - ;; to nearest when constructing a denormal result, - ;; so just call SCALE-FLOAT here without any - ;; boundary-case fixup. (scale-float f0 scale)))))) + (denormal-excess () + ;; How many bits of precision the result loses by being + ;; denormal instead of normal. A normal-precision return + ;; would be BITS*2^(SCALE-DIGITS) with BITS having DIGITS + ;; bits. Once it's known that this representation will + ;; produce a denormal -- equivalently, that SCALE-FLOAT- + ;; MAYBE-UNDERFLOW would take the underflow branch -- + ;; (1 - BIAS) - SCALE bits of the mantissa fall below the + ;; denormal's narrower storage and must be rounded off. + ;; Zero in the normal range. + (let ((bias + (ecase format + (single-float vm:single-float-bias) + (double-float vm:double-float-bias)))) + (declare (fixnum bias)) + (max 0 (the fixnum + (- (the fixnum (- 1 bias)) + scale))))) + (round-denormal (fraction-and-guard rem excess) + ;; FRACTION-AND-GUARD has (1+ DIGITS) bits with one guard + ;; bit; round it to (- DIGITS EXCESS) bits using round-to- + ;; nearest, ties to even, with REM as the sticky tail. + ;; Drops EXCESS+1 low bits in a single step. This is the + ;; one rounding the denormal result undergoes; no + ;; subsequent SCALE-FLOAT call is needed, so there is no + ;; double rounding. + (declare (type unsigned-byte fraction-and-guard rem) + (fixnum excess)) + (let* ((shift (1+ excess)) + (low (ldb (byte shift 0) fraction-and-guard)) + (quot (ash fraction-and-guard (- shift))) + (halfway (ash 1 excess))) + (declare (fixnum shift)) + (cond ((< low halfway) quot) + ((> low halfway) (1+ quot)) + ((not (zerop rem)) (1+ quot)) + ((oddp quot) (1+ quot)) + (t quot)))) + (denormal-from-bits (mantissa excess) + ;; MANTISSA has at most (- DIGITS EXCESS) bits and is the + ;; stored significand of a denormal result. Denormal + ;; storage holds (1- DIGITS) bits, so rounding can carry + ;; into the smallest normal only when EXCESS = 1, in + ;; which case MANTISSA can be exactly (ASH 1 (1- DIGITS)). + (declare (fixnum excess)) + (let ((sign (if plusp 0 1))) + (case format + (single-float + (cond ((and (= excess 1) + (= mantissa + (ash 1 (1- vm:single-float-digits)))) + (single-from-bits + sign vm:single-float-normal-exponent-min 0)) + (t + (single-from-bits sign 0 mantissa)))) + (double-float + (cond ((and (= excess 1) + (= mantissa + (ash 1 (1- vm:double-float-digits)))) + (double-from-bits + sign vm:double-float-normal-exponent-min 0)) + (t + (double-from-bits sign 0 mantissa))))))) (floatit (bits) (let ((sign (if plusp 0 1))) (case format @@ -1189,16 +1237,36 @@ (declare (fixnum extra)) (cond ((/= extra 1) (assert (> extra 1))) - ((oddp fraction-and-guard) - (return - (if (zerop rem) - (float-and-scale - (if (zerop (logand fraction-and-guard 2)) - fraction-and-guard - (1+ fraction-and-guard))) - (float-and-scale (1+ fraction-and-guard))))) (t - (return (float-and-scale fraction-and-guard))))) + (return + (let ((excess (denormal-excess))) + (cond + ((zerop excess) + ;; Normal result: original odd/even tie-break. + (cond ((oddp fraction-and-guard) + (if (zerop rem) + (float-and-scale + (if (zerop + (logand fraction-and-guard 2)) + fraction-and-guard + (1+ fraction-and-guard))) + (float-and-scale + (1+ fraction-and-guard)))) + (t + (float-and-scale fraction-and-guard)))) + (t + ;; Denormal result: re-round directly to the + ;; denormal's narrower precision so the only + ;; rounding step happens here. Rounding to + ;; DIGITS first and re-rounding via + ;; SCALE-FLOAT-MAYBE-UNDERFLOW would double- + ;; round (e.g. 7.290983e-39 would land on an + ;; artifical tie at the 24-bit boundary). + (let ((mantissa + (round-denormal fraction-and-guard rem + excess))) + (declare (type unsigned-byte mantissa)) + (denormal-from-bits mantissa excess))))))))) (setq shifted-num (ash shifted-num -1)) (incf scale))))))) ===================================== tests/float.lisp ===================================== @@ -853,3 +853,176 @@ (ext:with-float-traps-masked (:underflow :inexact) (assert-equal 0 (kernel:double-float-high-bits 1.1d-322)) (assert-equal #x16 (kernel:double-float-low-bits 1.1d-322)))) + +(define-test float-ratio-float.denormal-double-rounding.single + (:tag :issues) + ;; Regression for the double-rounding bug exposed by reading + ;; "7.290983e-39". The exact rational lies at 5203019.332 * 2^-149, + ;; below halfway between denormals #x4f644b and #x4f644c. An earlier + ;; fix rounded to 24 bits first (lifting it to the artificial tie + ;; 5203019.5 * 2^-149) and then re-rounded ties-to-even to #x4f644c. + ;; FLOAT-RATIO-FLOAT now re-rounds directly to denormal precision in a + ;; single step, yielding the correctly-rounded #x4f644b. + (assert-equal #x4f644b + (kernel:single-float-bits 7.290983e-39))) + +(define-test float-ratio-float.denormal-low-below-halfway.single + (:tag :issues) + ;; Exercise ROUND-DENORMAL's `low < halfway' branch via FLOAT-RATIO- + ;; FLOAT. Value 11/10 * least-positive is 1.1 denormal-units; the + ;; loop sees several bits of low and the comparison must take the + ;; round-down path so the mantissa stays at 1. + (let ((x (* 11/10 (expt 2 -149)))) + (assert-equal #x00000001 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-low-above-halfway.single + (:tag :issues) + ;; ROUND-DENORMAL's `low > halfway' branch: 17/10 * least-positive + ;; (= 1.7 denormal-units), past halfway between 1 and 2, rounds up. + (let ((x (* 17/10 (expt 2 -149)))) + (assert-equal #x00000002 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-tie-to-even.single + (:tag :issues) + ;; ROUND-DENORMAL's tie path, REM = 0: exact halfway between two + ;; denormals rounds to even. 3/2 * least-positive ties between + ;; denormals 1 and 2; the even neighbour is 2. + (let ((x (* 3/2 (expt 2 -149)))) + (assert-equal #x00000002 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; 5/2 * least-positive ties between 2 and 3; even is 2. + (let ((x (* 5/2 (expt 2 -149)))) + (assert-equal #x00000002 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; 7/2 * least-positive ties between 3 and 4; even is 4. + (let ((x (* 7/2 (expt 2 -149)))) + (assert-equal #x00000004 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; 1/2 * least-positive ties between 0 and 1; even is 0. + (let ((x (* 1/2 (expt 2 -149)))) + (assert-equal #x00000000 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-tie-with-sticky.single + (:tag :issues) + ;; ROUND-DENORMAL's tie path with REM != 0: when the loop's + ;; FRACTION-AND-GUARD reaches an exact halfway pattern but the + ;; division has a nonzero remainder, the rounding must go up because + ;; the original rational is strictly above halfway. 3/2 * least- + ;; positive + a tiny fraction of least-positive lands just past tie 1-2, + ;; rounds up to 2. + (let ((x (+ (* 3/2 (expt 2 -149)) + (* (expt 2 -149) 1/1000000000)))) + (assert-equal #x00000002 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; 1/2 + tiny: just past tie 0-1, rounds up to 1. + (let ((x (+ (* 1/2 (expt 2 -149)) + (* (expt 2 -149) 1/1000000000)))) + (assert-equal #x00000001 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-excess.single + (:tag :issues) + ;; Exercise DENORMAL-EXCESS over a range of magnitudes. EXCESS + ;; varies inversely with the result's magnitude; each case has the + ;; result land on a chosen denormal so an off-by-one in the EXCESS + ;; computation would shift the result by a factor of two. + ;; EXCESS = 1: value near smallest normal; pick (2^23 - 1) * 2^-149, + ;; the largest denormal. + (let ((x (* (1- (expt 2 23)) (expt 2 -149)))) + (assert-equal #x007fffff + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; EXCESS = 4: small denormal, mantissa 2^19. + (let ((x (expt 2 -130))) + (assert-equal (ash 1 19) + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; EXCESS = 21: very small denormal, mantissa 8. + (let ((x (* 8 (expt 2 -149)))) + (assert-equal #x00000008 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; EXCESS = 23 (the maximum): only the bottom three denormals are + ;; reachable. 3 * least-positive gives mantissa 3. + (let ((x (* 3 (expt 2 -149)))) + (assert-equal #x00000003 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-carry-to-normal.single + (:tag :issues) + ;; DENORMAL-FROM-BITS's carry-into-smallest-normal branch. Rounding + ;; promotes the denormal mantissa to 2^(DIGITS-1), which doesn't fit + ;; in the denormal's stored mantissa width; the result must be the + ;; smallest normal (stored exponent = 1, mantissa = 0). + ;; + ;; (2^24 - 1)/2 * 2^-149 is an exact tie between the largest denormal + ;; (mantissa 2^23 - 1) and the smallest normal (2^-126); the latter + ;; has stored mantissa 0 which is even, so the tie rounds to it. + (let ((x (* (1- (expt 2 24)) 1/2 (expt 2 -149)))) + (assert-equal #x00800000 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; Just past that tie, also rounds up to smallest normal. + (let ((x (+ (* (1- (expt 2 24)) 1/2 (expt 2 -149)) + (* (expt 2 -149) 1/1000)))) + (assert-equal #x00800000 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; Just below that tie, rounds down to the largest denormal. + (let ((x (- (* (1- (expt 2 24)) 1/2 (expt 2 -149)) + (* (expt 2 -149) 1/1000)))) + (assert-equal #x007fffff + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-double-rounding.double + (:tag :issues) + ;; Double-float equivalents. Pick a rational that lands strictly + ;; below halfway between two denormals after 53-bit rounding would + ;; otherwise lift to the halfway position. Verify a few denormal + ;; cases also work end-to-end through FLOAT-RATIO-FLOAT. + ;; + ;; 1.1d-322 -> mantissa #x16 (= 22). + (assert-equal 0 (kernel:double-float-high-bits 1.1d-322)) + (assert-equal #x16 (kernel:double-float-low-bits 1.1d-322)) + ;; Tie-to-even, double: 3/2 * least-positive ties between denormals + ;; 1 and 2; even neighbour is 2. + (let ((x (* 3/2 (expt 2 -1074)))) + (assert-equal 0 (kernel:double-float-high-bits + (kernel::float-ratio-float x 'double-float))) + (assert-equal 2 (kernel:double-float-low-bits + (kernel::float-ratio-float x 'double-float)))) + ;; Carry into smallest normal: (2^53 - 1)/2 * 2^-1074 exactly halfway + ;; between the largest double denormal and the smallest normal; + ;; rounds up to the smallest normal #x00100000_00000000. + (let* ((x (* (1- (expt 2 53)) 1/2 (expt 2 -1074))) + (r (kernel::float-ratio-float x 'double-float))) + (assert-equal #x00100000 (kernel:double-float-high-bits r) x) + (assert-equal 0 (kernel:double-float-low-bits r) x))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/af544ca1ef157e4bc78edd… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/af544ca1ef157e4bc78edd… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][issue-504-read-denormals-with-rounding] Add tests to exercise float-ratio-float
by Raymond Toy (＠rtoy) 27 May '26

27 May '26

Raymond Toy pushed to branch issue-504-read-denormals-with-rounding at cmucl / cmucl Commits: bc6c560e by Raymond Toy at 2026-05-26T18:56:29-07:00 Add tests to exercise float-ratio-float Each test calls `float-ratio-float` with an exact rational to test a specific branch of the new helpers. - - - - - 1 changed file: - tests/float.lisp Changes: ===================================== tests/float.lisp ===================================== @@ -853,3 +853,176 @@ (ext:with-float-traps-masked (:underflow :inexact) (assert-equal 0 (kernel:double-float-high-bits 1.1d-322)) (assert-equal #x16 (kernel:double-float-low-bits 1.1d-322)))) + +(define-test float-ratio-float.denormal-double-rounding.single + (:tag :issues) + ;; Regression for the double-rounding bug exposed by reading + ;; "7.290983e-39". The exact rational lies at 5203019.332 * 2^-149, + ;; below halfway between denormals #x4f644b and #x4f644c. An earlier + ;; fix rounded to 24 bits first (lifting it to the artificial tie + ;; 5203019.5 * 2^-149) and then re-rounded ties-to-even to #x4f644c. + ;; FLOAT-RATIO-FLOAT now re-rounds directly to denormal precision in a + ;; single step, yielding the correctly-rounded #x4f644b. + (assert-equal #x4f644b + (kernel:single-float-bits 7.290983e-39))) + +(define-test float-ratio-float.denormal-low-below-halfway.single + (:tag :issues) + ;; Exercise ROUND-DENORMAL's `low < halfway' branch via FLOAT-RATIO- + ;; FLOAT. Value 11/10 * least-positive is 1.1 denormal-units; the + ;; loop sees several bits of low and the comparison must take the + ;; round-down path so the mantissa stays at 1. + (let ((x (* 11/10 (expt 2 -149)))) + (assert-equal #x00000001 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-low-above-halfway.single + (:tag :issues) + ;; ROUND-DENORMAL's `low > halfway' branch: 17/10 * least-positive + ;; (= 1.7 denormal-units), past halfway between 1 and 2, rounds up. + (let ((x (* 17/10 (expt 2 -149)))) + (assert-equal #x00000002 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-tie-to-even.single + (:tag :issues) + ;; ROUND-DENORMAL's tie path, REM = 0: exact halfway between two + ;; denormals rounds to even. 3/2 * least-positive ties between + ;; denormals 1 and 2; the even neighbour is 2. + (let ((x (* 3/2 (expt 2 -149)))) + (assert-equal #x00000002 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; 5/2 * least-positive ties between 2 and 3; even is 2. + (let ((x (* 5/2 (expt 2 -149)))) + (assert-equal #x00000002 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; 7/2 * least-positive ties between 3 and 4; even is 4. + (let ((x (* 7/2 (expt 2 -149)))) + (assert-equal #x00000004 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; 1/2 * least-positive ties between 0 and 1; even is 0. + (let ((x (* 1/2 (expt 2 -149)))) + (assert-equal #x00000000 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-tie-with-sticky.single + (:tag :issues) + ;; ROUND-DENORMAL's tie path with REM != 0: when the loop's + ;; FRACTION-AND-GUARD reaches an exact halfway pattern but the + ;; division has a nonzero remainder, the rounding must go up because + ;; the original rational is strictly above halfway. 3/2 * least- + ;; positive + a tiny fraction of least-positive lands just past tie 1-2, + ;; rounds up to 2. + (let ((x (+ (* 3/2 (expt 2 -149)) + (* (expt 2 -149) 1/1000000000)))) + (assert-equal #x00000002 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; 1/2 + tiny: just past tie 0-1, rounds up to 1. + (let ((x (+ (* 1/2 (expt 2 -149)) + (* (expt 2 -149) 1/1000000000)))) + (assert-equal #x00000001 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-excess.single + (:tag :issues) + ;; Exercise DENORMAL-EXCESS over a range of magnitudes. EXCESS + ;; varies inversely with the result's magnitude; each case has the + ;; result land on a chosen denormal so an off-by-one in the EXCESS + ;; computation would shift the result by a factor of two. + ;; EXCESS = 1: value near smallest normal; pick (2^23 - 1) * 2^-149, + ;; the largest denormal. + (let ((x (* (1- (expt 2 23)) (expt 2 -149)))) + (assert-equal #x007fffff + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; EXCESS = 4: small denormal, mantissa 2^19. + (let ((x (expt 2 -130))) + (assert-equal (ash 1 19) + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; EXCESS = 21: very small denormal, mantissa 8. + (let ((x (* 8 (expt 2 -149)))) + (assert-equal #x00000008 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; EXCESS = 23 (the maximum): only the bottom three denormals are + ;; reachable. 3 * least-positive gives mantissa 3. + (let ((x (* 3 (expt 2 -149)))) + (assert-equal #x00000003 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-carry-to-normal.single + (:tag :issues) + ;; DENORMAL-FROM-BITS's carry-into-smallest-normal branch. Rounding + ;; promotes the denormal mantissa to 2^(DIGITS-1), which doesn't fit + ;; in the denormal's stored mantissa width; the result must be the + ;; smallest normal (stored exponent = 1, mantissa = 0). + ;; + ;; (2^24 - 1)/2 * 2^-149 is an exact tie between the largest denormal + ;; (mantissa 2^23 - 1) and the smallest normal (2^-126); the latter + ;; has stored mantissa 0 which is even, so the tie rounds to it. + (let ((x (* (1- (expt 2 24)) 1/2 (expt 2 -149)))) + (assert-equal #x00800000 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; Just past that tie, also rounds up to smallest normal. + (let ((x (+ (* (1- (expt 2 24)) 1/2 (expt 2 -149)) + (* (expt 2 -149) 1/1000)))) + (assert-equal #x00800000 + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x)) + ;; Just below that tie, rounds down to the largest denormal. + (let ((x (- (* (1- (expt 2 24)) 1/2 (expt 2 -149)) + (* (expt 2 -149) 1/1000)))) + (assert-equal #x007fffff + (kernel:single-float-bits + (kernel::float-ratio-float x 'single-float)) + x))) + +(define-test float-ratio-float.denormal-double-rounding.double + (:tag :issues) + ;; Double-float equivalents. Pick a rational that lands strictly + ;; below halfway between two denormals after 53-bit rounding would + ;; otherwise lift to the halfway position. Verify a few denormal + ;; cases also work end-to-end through FLOAT-RATIO-FLOAT. + ;; + ;; 1.1d-322 -> mantissa #x16 (= 22). + (assert-equal 0 (kernel:double-float-high-bits 1.1d-322)) + (assert-equal #x16 (kernel:double-float-low-bits 1.1d-322)) + ;; Tie-to-even, double: 3/2 * least-positive ties between denormals + ;; 1 and 2; even neighbour is 2. + (let ((x (* 3/2 (expt 2 -1074)))) + (assert-equal 0 (kernel:double-float-high-bits + (kernel::float-ratio-float x 'double-float))) + (assert-equal 2 (kernel:double-float-low-bits + (kernel::float-ratio-float x 'double-float)))) + ;; Carry into smallest normal: (2^53 - 1)/2 * 2^-1074 exactly halfway + ;; between the largest double denormal and the smallest normal; + ;; rounds up to the smallest normal #x00100000_00000000. + (let* ((x (* (1- (expt 2 53)) 1/2 (expt 2 -1074))) + (r (kernel::float-ratio-float x 'double-float))) + (assert-equal #x00100000 (kernel:double-float-high-bits r) x) + (assert-equal 0 (kernel:double-float-low-bits r) x))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/bc6c560e5d4632f897854f3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/bc6c560e5d4632f897854f3… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][issue-504-read-denormals-with-rounding] Fix double rounding when reading denormal float literals
by Raymond Toy (＠rtoy) 27 May '26

27 May '26

Raymond Toy pushed to branch issue-504-read-denormals-with-rounding at cmucl / cmucl Commits: 50d9df5c by Raymond Toy at 2026-05-26T18:47:45-07:00 Fix double rounding when reading denormal float literals `float-ratio-float` was always rounding the rational full precision before handing the result to `scale-float`. When the result was a denormal, `scale-float-maybe-underflow` could then round the number again to remove some bits to fit in a denormal. This causes double rounding as seen with "7.290983e-39". To fix this `float-ratio-float` re-rounds directly to denormal range. The number of extra bits in the denormal is detected and the extra bits are dropped using round-to-nearest-even. The denormal is emitted directly so `scale-float` isn't involved. The normal path is unchanged and `scale-float-maybe-underflow` still needs correctly rounding in case `scale-float` would produce a denormal. - - - - - 1 changed file: - src/code/float.lisp Changes: ===================================== src/code/float.lisp ===================================== @@ -1152,26 +1152,74 @@ (assert (= len (the fixnum (1+ digits)))) (multiple-value-bind (f0) (floatit (ash bits -1)) - #+nil - (progn - (format t "x = ~A~%" x) - (format t "1: f0, f1 = ~A~%" f0) - (format t " scale = ~A~%" (1+ scale))) - (scale-float f0 (1+ scale)))) (t (multiple-value-bind (f0) (floatit bits) - #+nil - (progn - (format t "2: f0, f1 = ~A~%" f0) - (format t " scale = ~A~%" scale) - (format t "scale-float f0 = ~A~%" (scale-float f0 scale))) - ;; SCALE-FLOAT-MAYBE-UNDERFLOW correctly rounds - ;; to nearest when constructing a denormal result, - ;; so just call SCALE-FLOAT here without any - ;; boundary-case fixup. (scale-float f0 scale)))))) + (denormal-excess () + ;; How many bits of precision the result loses by being + ;; denormal instead of normal. A normal-precision return + ;; would be BITS*2^(SCALE-DIGITS) with BITS having DIGITS + ;; bits. Once it's known that this representation will + ;; produce a denormal -- equivalently, that SCALE-FLOAT- + ;; MAYBE-UNDERFLOW would take the underflow branch -- + ;; (1 - BIAS) - SCALE bits of the mantissa fall below the + ;; denormal's narrower storage and must be rounded off. + ;; Zero in the normal range. + (let ((bias + (ecase format + (single-float vm:single-float-bias) + (double-float vm:double-float-bias)))) + (declare (fixnum bias)) + (max 0 (the fixnum + (- (the fixnum (- 1 bias)) + scale))))) + (round-denormal (fraction-and-guard rem excess) + ;; FRACTION-AND-GUARD has (1+ DIGITS) bits with one guard + ;; bit; round it to (- DIGITS EXCESS) bits using round-to- + ;; nearest, ties to even, with REM as the sticky tail. + ;; Drops EXCESS+1 low bits in a single step. This is the + ;; one rounding the denormal result undergoes; no + ;; subsequent SCALE-FLOAT call is needed, so there is no + ;; double rounding. + (declare (type unsigned-byte fraction-and-guard rem) + (fixnum excess)) + (let* ((shift (1+ excess)) + (low (ldb (byte shift 0) fraction-and-guard)) + (quot (ash fraction-and-guard (- shift))) + (halfway (ash 1 excess))) + (declare (fixnum shift)) + (cond ((< low halfway) quot) + ((> low halfway) (1+ quot)) + ((not (zerop rem)) (1+ quot)) + ((oddp quot) (1+ quot)) + (t quot)))) + (denormal-from-bits (mantissa excess) + ;; MANTISSA has at most (- DIGITS EXCESS) bits and is the + ;; stored significand of a denormal result. Denormal + ;; storage holds (1- DIGITS) bits, so rounding can carry + ;; into the smallest normal only when EXCESS = 1, in + ;; which case MANTISSA can be exactly (ASH 1 (1- DIGITS)). + (declare (fixnum excess)) + (let ((sign (if plusp 0 1))) + (case format + (single-float + (cond ((and (= excess 1) + (= mantissa + (ash 1 (1- vm:single-float-digits)))) + (single-from-bits + sign vm:single-float-normal-exponent-min 0)) + (t + (single-from-bits sign 0 mantissa)))) + (double-float + (cond ((and (= excess 1) + (= mantissa + (ash 1 (1- vm:double-float-digits)))) + (double-from-bits + sign vm:double-float-normal-exponent-min 0)) + (t + (double-from-bits sign 0 mantissa))))))) (floatit (bits) (let ((sign (if plusp 0 1))) (case format @@ -1189,16 +1237,36 @@ (declare (fixnum extra)) (cond ((/= extra 1) (assert (> extra 1))) - ((oddp fraction-and-guard) - (return - (if (zerop rem) - (float-and-scale - (if (zerop (logand fraction-and-guard 2)) - fraction-and-guard - (1+ fraction-and-guard))) - (float-and-scale (1+ fraction-and-guard))))) (t - (return (float-and-scale fraction-and-guard))))) + (return + (let ((excess (denormal-excess))) + (cond + ((zerop excess) + ;; Normal result: original odd/even tie-break. + (cond ((oddp fraction-and-guard) + (if (zerop rem) + (float-and-scale + (if (zerop + (logand fraction-and-guard 2)) + fraction-and-guard + (1+ fraction-and-guard))) + (float-and-scale + (1+ fraction-and-guard)))) + (t + (float-and-scale fraction-and-guard)))) + (t + ;; Denormal result: re-round directly to the + ;; denormal's narrower precision so the only + ;; rounding step happens here. Rounding to + ;; DIGITS first and re-rounding via + ;; SCALE-FLOAT-MAYBE-UNDERFLOW would double- + ;; round (e.g. 7.290983e-39 would land on an + ;; artifical tie at the 24-bit boundary). + (let ((mantissa + (round-denormal fraction-and-guard rem + excess))) + (declare (type unsigned-byte mantissa)) + (denormal-from-bits mantissa excess))))))))) (setq shifted-num (ash shifted-num -1)) (incf scale))))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/50d9df5cd5c68fd9760d5f2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/50d9df5cd5c68fd9760d5f2… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][rtoy-print-using-ryu] 5 commits: Fix #504: Do correct rounding in scale-float-maybe-underflow
by Raymond Toy (＠rtoy) 26 May '26

26 May '26

Raymond Toy pushed to branch rtoy-print-using-ryu at cmucl / cmucl Commits: f65ff9eb by Raymond Toy at 2026-05-25T17:34:15-07:00 Fix #504: Do correct rounding in scale-float-maybe-underflow Previously, when dealing with denormals, we right shifted the bits so we were truncating instead of rounding to even as expected. Instead of trying to round the bits ourselves, build a normal-range float that is not a denormal by increasing the exponent outside the denormal range. `scale-float` is fine for this and doesn't introduce any round-off. Then multiply by a power of two to get the correct denormal. Since it's a power of two, there's no rounding except when we get a denormal. This is the rounding we want. The kludge in `float-ratio-float` isn't needed because it was trying to fix the denormal case. It incorrectly assumed that `scale-float` was rounding correctly. As we know now, it wasn't. Updated the test `float-ratio.double` which had the incorrect expected value. It should round to twice the least-positive-double-float. Because we've corrected the reader, cdiv.maxima-case was getting slightly different floats. Compute the expected value by converting the args to complex rationals and doing a rational division to get the fully accurate result. Added additional test for `scale-float-maybe-underflow` to make sure we get the rounding correct. And verify that we read 1.1e-44 and 1.1d-322 correctly. The former value showed up in an ansi-test failure before this fix. - - - - - 63c190db by Raymond Toy at 2026-05-25T17:54:42-07:00 Add some declarations and simplify comment Add some declarations to scale-float-maybe-underflow to help the compiler generate a little bit better code. Simplify the comment about how we do scaling for denormals. - - - - - 06ea24af by Raymond Toy at 2026-05-26T07:22:37-07:00 Change declaration of exp arg In `scale-float-maybe-underflow`, the exponent (`exp`) isn't limited to the double-float-exponent range. It can basically be any fixnum. This can be seen with `(scale-float 1d0 -9999)`. `scale-float-maybe-underflow` sees -9999, well outside the range of double-float-exponent type. - - - - - a5b2bbcc by Raymond Toy at 2026-05-26T07:37:03-07:00 Update release notes. No other changes. - - - - - af544ca1 by Raymond Toy at 2026-05-26T07:38:14-07:00 Merge branch 'issue-504-read-denormals-with-rounding' into rtoy-print-using-ryu - - - - - 3 changed files: - src/code/float.lisp - src/general-info/release-22a.md - tests/float.lisp Changes: ===================================== src/code/float.lisp ===================================== @@ -885,40 +885,57 @@ ;;; denormalized or underflows to 0. ;;; (defun scale-float-maybe-underflow (x exp) + (declare (type (or single-float double-float) x) + (fixnum exp)) (multiple-value-bind (sig old-exp) - (integer-decode-float x) + (integer-decode-float x) (let* ((digits (float-digits x)) + (1+digits (1+ digits)) (new-exp (+ exp old-exp digits (etypecase x (single-float vm:single-float-bias) (double-float vm:double-float-bias)))) (sign (if (minusp (float-sign x)) 1 0))) (cond - ((< new-exp - (etypecase x - (single-float vm:single-float-normal-exponent-min) - (double-float vm:double-float-normal-exponent-min))) - (when (vm:current-float-trap :inexact) - (error 'floating-point-inexact :operation 'scale-float - :operands (list x exp))) - (when (vm:current-float-trap :underflow) - (error 'floating-point-underflow :operation 'scale-float - :operands (list x exp))) - (let ((shift (1- new-exp))) - ;; Is it necessary to have this IF here? Is there any case - ;; where (ash sig shift) won't return 0 when - ;; shift < -(digits-1)? - (if (< shift (- (1- digits))) + ((< new-exp + (etypecase x + (single-float vm:single-float-normal-exponent-min) + (double-float vm:double-float-normal-exponent-min))) + (when (vm:current-float-trap :inexact) + (error 'floating-point-inexact :operation 'scale-float + :operands (list x exp))) + (when (vm:current-float-trap :underflow) + (error 'floating-point-underflow :operation 'scale-float + :operands (list x exp))) + ;; To round correctly, let the hardware multiplier do the + ;; rounding: build a normal float whose stored exponent is + ;; bumped up by 1+DIGITS (which puts it safely in the normal + ;; range), then multiply by 2^-(1+DIGITS). The multiplier is + ;; an exact power of two, so the multiplication is exact + ;; apart from the unavoidable rounding step that expresses + ;; the product as a denormal, which the FPU performs in the + ;; current rounding mode. If the bumped exponent is zero or + ;; negative the bumped float would itself be a denormal -- + ;; losing the implicit 1 bit of SIG -- so handle that case + ;; explicitly by returning signed zero. + (let ((bumped-exp (+ new-exp 1+digits))) + (cond + ((<= bumped-exp 0) (etypecase x (single-float (single-from-bits sign 0 0)) - (double-float (double-from-bits sign 0 0))) + (double-float (double-from-bits sign 0 0)))) + (t (etypecase x - (single-float (single-from-bits sign 0 (ash sig shift))) - (double-float (double-from-bits sign 0 (ash sig shift))))))) - (t - (etypecase x - (single-float (single-from-bits sign new-exp sig)) - (double-float (double-from-bits sign new-exp sig)))))))) + (single-float + (* (single-from-bits sign bumped-exp sig) + (scale-float 1f0 (- 1+digits)))) + (double-float + (* (double-from-bits sign bumped-exp sig) + (scale-float 1d0 (- 1+digits))))))))) + (t + (etypecase x + (single-float (single-from-bits sign new-exp sig)) + (double-float (double-from-bits sign new-exp sig)))))))) ;;; SCALE-FLOAT-MAYBE-OVERFLOW -- Internal @@ -1150,27 +1167,11 @@ (format t "2: f0, f1 = ~A~%" f0) (format t " scale = ~A~%" scale) (format t "scale-float f0 = ~A~%" (scale-float f0 scale))) - (let ((min-exponent - ;; Compute the min (unbiased) exponent - (ecase format - (single-float - (- vm:single-float-normal-exponent-min - vm:single-float-bias - vm:single-float-digits)) - (double-float - (- vm:double-float-normal-exponent-min - vm:double-float-bias - vm:double-float-digits))))) - ;; F0 is always between 0.5 and 1. If - ;; SCALE is the min exponent, we have a - ;; denormal number just less than the - ;; least-positive float. We want to - ;; return the least-positive-float so - ;; multiply F0 by 2 (without adjusting - ;; SCALE) to get the nearest float. - (if (= scale min-exponent) - (scale-float (* 2 f0) scale) - (scale-float f0 scale)))))))) + ;; SCALE-FLOAT-MAYBE-UNDERFLOW correctly rounds + ;; to nearest when constructing a denormal result, + ;; so just call SCALE-FLOAT here without any + ;; boundary-case fixup. + (scale-float f0 scale)))))) (floatit (bits) (let ((sign (if plusp 0 1))) (case format ===================================== src/general-info/release-22a.md ===================================== @@ -58,6 +58,8 @@ public domain. * #463: `double-double-float` is missing comparison operations between `double-double-float` and `double-float` * #474: Add functions to print and parse C-style hex floats. + * #504: Do correct rounding in `scale-float-maybe-underflow`. + This was causing some denormals to be read incorrectly. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== tests/float.lisp ===================================== @@ -179,7 +179,9 @@ (kernel::float-ratio-float (* 4 expo) 'double-float)) (assert-equal least-positive-double-float (kernel::float-ratio-float (* 494/100 expo) 'double-float)) - (assert-equal least-positive-double-float + ;; 988/100*10^-324 is very close to 2*least-positive (the exact ratio + ;; is 1.9997 * least-positive), so it rounds to 2*least-positive. + (assert-equal (* 2 least-positive-double-float) (kernel::float-ratio-float (* 988/100 expo) 'double-float))))) (define-test reader-error.small-single-floats @@ -678,8 +680,11 @@ (frob cdiv.maxima-case #c(5.43d-10 1.13d-100) #c(1.2d-311 5.7d-312) - #c(3.691993880674614517999740937026568563794896024143749539711267954d301 - -1.753697093319947872394996242210428954266103103602859195409591583d301) + ;; Compute the expected value using rational arithmetic after + ;; converting the complex numbers above to the equivalent + ;; complex rationals. + (/ (complex (rational 5.43d-10) (rational 1.13d-100)) + (complex (rational 1.2d-311) (rational 5.7d-312))) 52) ;; 12 ;; @@ -766,3 +771,85 @@ (coerce y '(complex single-float))) x y))) + +(define-test scale-float-underflow-rounding.single + (:tag :issues) + ;; SCALE-FLOAT into the denormal range must round to nearest, ties to + ;; even, instead of truncating the discarded bits. Each (X EXP BITS) + ;; triple gives a normal X, an exponent EXP to scale by, and the IEEE + ;; bits of the expected single-float result. + (ext:with-float-traps-masked (:underflow :inexact) + (dolist (case (list + ;; 1.7f0 * 2^-149: between denormals 1 and 2, closer to 2. + (list 1.7f0 -149 #x00000002) + ;; 1.5f0 * 2^-149: halfway between denormals 1 and 2; + ;; ties round to even -> 2. + (list 1.5f0 -149 #x00000002) + ;; 1.1f0 * 2^-149: closer to denormal 1. + (list 1.1f0 -149 #x00000001) + ;; 1.0001f0 * 2^-150: just above halfway between 0 and + ;; smallest denormal; rounds up to 1. + (list 1.0001f0 -150 #x00000001) + ;; 1.0f0 * 2^-150: exactly halfway between 0 and smallest + ;; denormal; ties round to even -> 0. + (list 1.0f0 -150 #x00000000) + ;; Largest single < 2 scaled by 2^-127: rounding carries + ;; into the implicit-1 position and produces the smallest + ;; normal number. + (list (kernel:make-single-float #x3fffffff) + -127 #x00800000))) + (destructuring-bind (x exp bits) case + (let ((result (scale-float x exp))) + (assert-equal bits (kernel:single-float-bits result) + x exp result)))))) + +(define-test scale-float-underflow-rounding.double + (:tag :issues) + ;; Like SCALE-FLOAT-UNDERFLOW-ROUNDING.SINGLE but for double-floats. + ;; Each (X EXP HI LO) gives a normal X, an exponent EXP, and the IEEE + ;; high and low bits of the expected double-float result. + (ext:with-float-traps-masked (:underflow :inexact) + (dolist (case (list + ;; 1.7d0 * 2^-1074: between denormals 1 and 2, closer to 2. + (list 1.7d0 -1074 0 2) + ;; 1.5d0 * 2^-1074: tie, rounds to even -> 2. + (list 1.5d0 -1074 0 2) + ;; 1.1d0 * 2^-1074: closer to denormal 1. + (list 1.1d0 -1074 0 1) + ;; 1.0001d0 * 2^-1075: just above halfway, rounds up. + (list 1.0001d0 -1075 0 1) + ;; 1.0d0 * 2^-1075: tie at the bottom, rounds to even -> 0. + (list 1.0d0 -1075 0 0) + ;; Largest double < 2 scaled by 2^-1023: rounding carries + ;; into the implicit-1 position and produces the smallest + ;; normal number. + (list (kernel:make-double-float #x3fffffff #xffffffff) + -1023 #x00100000 0))) + (destructuring-bind (x exp hi lo) case + (let ((result (scale-float x exp))) + (assert-equal hi (kernel:double-float-high-bits result) + x exp result) + (assert-equal lo (kernel:double-float-low-bits result) + x exp result)))))) + +(define-test scale-float-underflow-rounding.reader-single + (:tag :issues) + ;; The reader uses FLOAT-RATIO-FLOAT, which calls SCALE-FLOAT and + ;; hence SCALE-FLOAT-MAYBE-UNDERFLOW on denormal results. Reading + ;; small float literals must therefore also round to nearest. + (ext:with-float-traps-masked (:underflow :inexact) + ;; 1.1e-44 is closer to 8 * least-positive-single-float than to 7. + (assert-equal #x00000008 + (kernel:single-float-bits 1.1e-44)) + ;; 1.121e-44 (essentially the IEEE representation of 1.1e-44) reads + ;; as the same denormal. + (assert-equal #x00000008 + (kernel:single-float-bits 1.121e-44)))) + +(define-test scale-float-underflow-rounding.reader-double + (:tag :issues) + ;; Like the single-float reader test, in the double denormal range. + ;; 1.1d-322 is closest to denormal #x16 (= 22). + (ext:with-float-traps-masked (:underflow :inexact) + (assert-equal 0 (kernel:double-float-high-bits 1.1d-322)) + (assert-equal #x16 (kernel:double-float-low-bits 1.1d-322)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b71a67e281f3eab0f6e950… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b71a67e281f3eab0f6e950… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][issue-504-read-denormals-with-rounding] Update release notes.
by Raymond Toy (＠rtoy) 26 May '26

26 May '26

Raymond Toy pushed to branch issue-504-read-denormals-with-rounding at cmucl / cmucl Commits: a5b2bbcc by Raymond Toy at 2026-05-26T07:37:03-07:00 Update release notes. No other changes. - - - - - 1 changed file: - src/general-info/release-22a.md Changes: ===================================== src/general-info/release-22a.md ===================================== @@ -58,6 +58,8 @@ public domain. * #463: `double-double-float` is missing comparison operations between `double-double-float` and `double-float` * #474: Add functions to print and parse C-style hex floats. + * #504: Do correct rounding in `scale-float-maybe-underflow`. + This was causing some denormals to be read incorrectly. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a5b2bbcc68930295d4c56c7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a5b2bbcc68930295d4c56c7… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0

[Git][cmucl/cmucl][issue-504-read-denormals-with-rounding] Change declaration of exp arg
by Raymond Toy (＠rtoy) 26 May '26

26 May '26

Raymond Toy pushed to branch issue-504-read-denormals-with-rounding at cmucl / cmucl Commits: 06ea24af by Raymond Toy at 2026-05-26T07:22:37-07:00 Change declaration of exp arg In `scale-float-maybe-underflow`, the exponent (`exp`) isn't limited to the double-float-exponent range. It can basically be any fixnum. This can be seen with `(scale-float 1d0 -9999)`. `scale-float-maybe-underflow` sees -9999, well outside the range of double-float-exponent type. - - - - - 1 changed file: - src/code/float.lisp Changes: ===================================== src/code/float.lisp ===================================== @@ -886,7 +886,7 @@ ;;; (defun scale-float-maybe-underflow (x exp) (declare (type (or single-float double-float) x) - (type kernel:double-float-exponent exp)) + (fixnum exp)) (multiple-value-bind (sig old-exp) (integer-decode-float x) (let* ((digits (float-digits x)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/06ea24afc6cdc41464ecf26… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/06ea24afc6cdc41464ecf26… You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications: https://gitlab.common-lisp.net/-/profile/notifications | Help: https://gitlab.common-lisp.net/help

1 0