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

[Git][cmucl/cmucl][rtoy-ryu-printf] 2 commits: Change d2fixed max precison
by Raymond Toy (＠rtoy) 24 May '26

24 May '26

Raymond Toy pushed to branch rtoy-ryu-printf at cmucl / cmucl Commits: 26864253 by Raymond Toy at 2026-05-24T08:23:23-07:00 Change d2fixed max precison 1000 digits of precision for d2fixed should be enough for practical uses of d2fixed. - - - - - 683edf58 by Raymond Toy at 2026-05-24T14:13:19-07:00 First cut at float support for ~E/F/G Basically wherever we called d2s, call d2s or f2s to get the shortest string. For all the other calls to d2exp/d2fixed, we convert the float to a double. tests/ryu.lisp updated with more tests. This needs to be cleaned up. - - - - - 3 changed files: - src/code/print.lisp - src/i18n/locale/cmucl.pot - tests/ryu.lisp Changes: ===================================== src/code/print.lisp ===================================== @@ -2001,15 +2001,21 @@ radix-R. If you have a power-list then pass it in as PL." ;;; Ryu interface + +;; This could be larger, but that would mean larger stack size for the +;; foreign call. This should be large enough for practical use. (defconstant +d2fixed-max-precision+ - 64 - "") + 1000 + "Maximum precision (fractional digits for d2fixed.") (defconstant +d2fixed-buffer-size+ + ;; +320 to account for 300 ingeger digts + sign + dot + terminator + + ;; slack. (+ +d2fixed-max-precision+ 320) - "") + "Buffer size for d2fixed.") (defun d2fixed (d precision) + "Lisp interface to Ryu d2fixed routine (specically d2fixed_buffered)" (declare (double-float d) (type (integer 0 #.+d2fixed-max-precision+) precision)) (alien:with-alien ((buf (alien:array c-call:char #.+d2fixed-buffer-size+))) @@ -2025,6 +2031,7 @@ radix-R. If you have a power-list then pass it in as PL." (alien:cast buf c-call:c-string))) (defun d2exp (d precision) + "Lisp interface to Ryu d2exp (specifically d2exp-buffered)." (declare (double-float d) (type (integer 0 #.+d2fixed-max-precision+) precision)) (alien:with-alien ((buf (alien:array c-call:char #.+d2fixed-buffer-size+))) @@ -2040,6 +2047,7 @@ radix-R. If you have a power-list then pass it in as PL." (alien:cast buf c-call:c-string))) (defun d2s (d) + "Lisp interface to Ryu d2s (specifically d2s_buffered" (declare (double-float d)) (alien:with-alien ((buf (alien:array c-call:char #.+d2fixed-buffer-size+))) (alien:alien-funcall @@ -2051,6 +2059,27 @@ radix-R. If you have a power-list then pass it in as PL." (alien:cast buf (* c-call:char))) (alien:cast buf c-call:c-string))) +(defun f2s (s) + (declare (single-float s)) + (alien:with-alien ((buf (alien:array c-call:char 16))) + (alien:alien-funcall + (alien:extern-alien "f2s_buffered" + (function c-call:void + c-call:float + (* c-call:char))) + s + (alien:cast buf (* c-call:char))) + (alien:cast buf c-call:c-string))) + +(declaim (inline float-to-string)) +(defun float-to-string (f) + "Convert F, a single-float or double-float, to a string of the shortest + form." + (declare (type (or single-float double-float) f)) + (etypecase f + (double-float (d2s (abs f))) + (single-float (f2s (abs f))))) + (defun parsed-d2exp (pos-x digits) (let* ((raw (d2exp pos-x digits)) ;; Parse the result from d2exp. It has the form "d.dddEeee". @@ -2260,22 +2289,29 @@ radix-R. If you have a power-list then pass it in as PL." (pad-overflow stream field-len w overflowchar padchar #'write-field)))) (defun format-e (value w d e k overflowchar padchar exponentchar at-sign-p) - (declare (double-float value) + (declare (type (or single-float double-float) value) (fixnum k) (type (or null (and unsigned-byte fixnum)) w d e) (optimize (speed 3))) - (let* ((is-negative-p (minusp (float-sign value))) - (abs-value (abs value))) + (multiple-value-bind (is-negative-p abs-value) + (etypecase value + (double-float + (values (minusp (float-sign value)) + (abs value))) + (single-float + (values (minusp (float-sign value)) + (abs (float value 1d0))))) (with-output-to-string (stream) (cond (d (multiple-value-bind (mantissa exponent) - (parsed-exp-form (d2exp abs-value (d2exp-precision d k))) + (parsed-exp-form (d2exp abs-value + (d2exp-precision d k))) (format-e-string stream mantissa exponent is-negative-p w e k overflowchar padchar exponentchar at-sign-p nil))) (t (multiple-value-bind (mantissa exponent) - (parsed-exp-form (d2s abs-value)) + (parsed-exp-form (float-to-string value)) (let* ((actual-exp (- exponent (1- k))) (full-len (compute-exp-output-length mantissa actual-exp k e is-negative-p at-sign-p @@ -2291,7 +2327,8 @@ radix-R. If you have a power-list then pass it in as PL." (drop-zero-p (and d-fit (<= k 0)))) (if d-fit (multiple-value-bind (mantissa exponent) - (parsed-exp-form (d2exp abs-value (d2exp-precision d-fit k))) + (parsed-exp-form (d2exp abs-value + (d2exp-precision d-fit k))) (format-e-string stream mantissa exponent is-negative-p w e k overflowchar padchar exponentchar at-sign-p drop-zero-p)) @@ -2322,6 +2359,7 @@ radix-R. If you have a power-list then pass it in as PL." (defun format-f-fixed (stream abs-value is-negative-p w d overflowchar padchar at-sign-p) + (declare (double-float abs-value)) (let* ((raw-string (d2fixed abs-value d)) (raw-len (length raw-string)) (sign-len (if (or is-negative-p at-sign-p) 1 0)) @@ -2370,10 +2408,11 @@ radix-R. If you have a power-list then pass it in as PL." (declare (dynamic-extent #'write-field)) (pad-overflow stream field-len w overflowchar padchar #'write-field)))) -(defun format-f-free (stream abs-value is-negative-p w +(defun format-f-free (stream value is-negative-p w overflowchar padchar at-sign-p) + (declare (type (or single-float double-float) value)) (multiple-value-bind (mantissa exponent) - (parsed-exp-form (d2s abs-value)) + (parsed-exp-form (float-to-string value)) (let* ((has-dot (find #\. mantissa)) (digit-count (if has-dot (1- (length mantissa)) (length mantissa))) (int-len (max 1 (1+ exponent))) @@ -2391,15 +2430,24 @@ radix-R. If you have a power-list then pass it in as PL." (emit-shortest stream mantissa exponent is-negative-p w overflowchar padchar at-sign-p)))) (t - (format-f-fixed stream abs-value is-negative-p w d-fit - overflowchar padchar at-sign-p)))))) + (let ((abs-value (etypecase value + (double-float (abs value)) + (single-float (abs value))))) + (format-f-fixed stream abs-value is-negative-p w d-fit + overflowchar padchar at-sign-p))))))) (defun format-f (value w d k overflowchar padchar at-sign-p) - (declare (double-float value) + (declare (type (or single-float double-float) value) (fixnum k) (type (or null (and unsigned-byte fixnum)) w d)) - (let ((is-negative-p (minusp (float-sign value))) - (abs-value (abs value))) + (multiple-value-bind (is-negative-p abs-value) + (etypecase value + (double-float + (values (minusp (float-sign value)) + (abs value))) + (single-float + (values (minusp (float-sign value)) + (abs (float value 1d0))))) (with-output-to-string (s) (cond ((not (zerop k)) ;; Complex case that doesn't fit with what d2s and d2fixed @@ -2413,15 +2461,15 @@ radix-R. If you have a power-list then pass it in as PL." (t ;; No d, so use d2s to get the shortest digits; convert by ;; placing the decimal poin at the right spot. - (format-f-free s abs-value is-negative-p w overflowchar padchar at-sign-p)))))) + (format-f-free s value is-negative-p w overflowchar padchar at-sign-p)))))) ;;; Ryu ~G (defun format-g (value w d e k overflowchar padchar exponentchar at-sign-p) - (declare (double-float value) + (declare (type (or single-float double-float) value) (fixnum k) (type (or null (and unsigned-byte fixnum)) w d e)) (multiple-value-bind (mantissa exponent) - (parsed-exp-form (d2s (abs value))) + (parsed-exp-form (float-to-string value)) (let* ((digit-count (length (remove #\. mantissa))) (n (1+ exponent)) (effective-d (or d (max digit-count (min n 7)))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -7711,8 +7711,30 @@ msgstr "" msgid "Print out a double-double to a string" msgstr "" +#: src/code/print.lisp +msgid "Maximum precision (fractional digits for d2fixed." +msgstr "" + +#: src/code/print.lisp +msgid "Buffer size for d2fixed." +msgstr "" + +#: src/code/print.lisp +msgid "Lisp interface to Ryu d2fixed routine (specically d2fixed_buffered)" +msgstr "" + +#: src/code/print.lisp +msgid "Lisp interface to Ryu d2exp (specifically d2exp-buffered)." +msgstr "" + +#: src/code/print.lisp +msgid "Lisp interface to Ryu d2s (specifically d2s_buffered" +msgstr "" + #: src/code/print.lisp msgid "" +"Convert F, a single-float or double-float, to a string of the shortest\n" +" form." msgstr "" #: src/code/print.lisp ===================================== tests/ryu.lisp ===================================== @@ -602,3 +602,184 @@ ;; follow CLHS literally. (assert-equal "3.14 " (lisp::format-g 3.14d0 3 nil nil 1 #\* nil #\d nil))) + + +;;;; Single-float tests for format-e, format-f, format-g. +;;;; +;;;; The shortest-form (d-nil) paths use f2s and may produce different +;;;; digits than d2s would for the corresponding double-float value, +;;;; since the shortest round-trip representation depends on float +;;;; precision. The d-given paths widen to double and use d2fixed/ +;;;; d2exp; results match the double-float case at that precision. + +(define-test format-e.single-basic + (:tag :format-e :single-float) + ;; Default ~E exponent marker for single-floats is 'f' (matches + ;; CL's single-float-format default). + (assert-equal "3.1415927f+0" + (lisp::format-e 3.1415927f0 nil nil nil 1 nil nil #\f nil)) + (assert-equal "-3.1415927f+0" + (lisp::format-e -3.1415927f0 nil nil nil 1 nil nil #\f nil)) + (assert-equal "1.0f+0" + (lisp::format-e 1f0 nil nil nil 1 nil nil #\f nil)) + (assert-equal "1.0f-1" + (lisp::format-e 0.1f0 nil nil nil 1 nil nil #\f nil))) + +(define-test format-e.single-d-given + (:tag :format-e :single-float) + ;; d-given path: widens to double, calls d2exp. At precision 5, + ;; matches what d2exp produces for the exact double representation + ;; of the single value. + (assert-equal "3.14159f+0" + (lisp::format-e 3.1415927f0 nil 5 nil 1 nil nil #\f nil)) + (assert-equal "5.00000f-1" + (lisp::format-e 0.5f0 nil 5 nil 1 nil nil #\f nil))) + +(define-test format-e.single-shortest-differs-from-double + (:tag :format-e :single-float) + ;; The single-float path uses f2s, which gives the shortest form + ;; for the single-precision value. Widening to double first would + ;; produce a different (longer) shortest form because the widened + ;; value 0.10000000149011612d0 is not the same as 0.1d0. + (assert-equal "1.0f-1" + (lisp::format-e 0.1f0 nil nil nil 1 nil nil #\f nil)) + ;; Confirm: if you widened first, d2s on the result would give: + (assert-equal "1.0000000149011612f-1" + (lisp::format-e 0.10000000149011612d0 nil nil nil 1 nil nil #\f nil))) + + +(define-test format-e.single-boundary + (:tag :format-e :single-float) + ;; Single-float bounds. + (let ((maxs (lisp::format-e most-positive-single-float + nil nil nil 1 nil nil #\f nil))) + (assert-true (search "f+38" maxs) maxs)) + (let ((mins (lisp::format-e least-positive-single-float + nil nil nil 1 nil nil #\f nil))) + (assert-true (search "f-45" mins) mins))) + +(define-test format-e.single-negative-zero + (:tag :format-e :single-float) + (assert-equal "-0.0f+0" + (lisp::format-e (- 0f0) nil nil nil 1 nil nil #\f nil)) + (assert-equal "+0.0f+0" + (lisp::format-e 0f0 nil nil nil 1 nil nil #\f t))) + +;;; ---------------------------------------------------------------------- +;;; ~F single-float + +(define-test format-f.single-basic + (:tag :format-f :single-float) + (assert-equal "3.14" + (lisp::format-f 3.14159f0 nil 2 0 nil nil nil)) + (assert-equal "-3.14" + (lisp::format-f -3.14159f0 nil 2 0 nil nil nil)) + (assert-equal "1.00000" + (lisp::format-f 1f0 nil 5 0 nil nil nil))) + +(define-test format-f.single-d-nil + (:tag :format-f :single-float) + ;; Shortest path: f2s output for single-floats is shorter than + ;; d2s would be for the widened value. + (assert-equal "3.1415927" + (lisp::format-f 3.1415927f0 nil nil 0 nil nil nil)) + (assert-equal "1.0" + (lisp::format-f 1f0 nil nil 0 nil nil nil)) + (assert-equal "0.1" + (lisp::format-f 0.1f0 nil nil 0 nil nil nil)) + (assert-equal "0.5" + (lisp::format-f 0.5f0 nil nil 0 nil nil nil))) + +(define-test format-f.single-d-nil-vs-double + (:tag :format-f :single-float) + ;; Confirm that the single-float path uses f2s, not d2s on a + ;; widened value. For 0.1f0, f2s gives "1" at exp -1, so output + ;; is "0.1". If we widened first, d2s on the resulting double + ;; would give a longer shortest form. + (assert-equal "0.1" + (lisp::format-f 0.1f0 nil nil 0 nil nil nil)) + ;; Same numeric value, but as a double-float literal -- d2s gives + ;; the long shortest form that round-trips through double. + (assert-equal "0.10000000149011612" + (lisp::format-f 0.10000000149011612d0 nil nil 0 nil nil nil)) + ;; And 0.1d0 (the double literal nearest to 0.1) has its own + ;; shortest form, which IS "0.1" since 0.1d0 is the canonical + ;; double for that decimal. + (assert-equal "0.1" + (lisp::format-f 0.1d0 nil nil 0 nil nil nil))) + + +(define-test format-f.single-leading-zeros + (:tag :format-f :single-float) + ;; Small singles still need leading-zero handling. + (assert-equal "0.001" + (lisp::format-f 0.001f0 nil nil 0 nil nil nil)) + (assert-equal "0.00001" + (lisp::format-f 0.00001f0 nil nil 0 nil nil nil))) + +(define-test format-f.single-integer-valued + (:tag :format-f :single-float) + ;; Integer-valued singles get ".0" forced. + (assert-equal "1.0" + (lisp::format-f 1f0 nil nil 0 nil nil nil)) + (assert-equal "100.0" + (lisp::format-f 100f0 nil nil 0 nil nil nil)) + (assert-equal "1000000.0" + (lisp::format-f 1000000f0 nil nil 0 nil nil nil))) + +(define-test format-f.single-width-fits + (:tag :format-f :single-float) + (assert-equal " 3.14" + (lisp::format-f 3.14f0 10 nil 0 nil nil nil))) + +(define-test format-f.single-negative-zero + (:tag :format-f :single-float) + (assert-equal "-0.0" + (lisp::format-f (- 0f0) nil nil 0 nil nil nil)) + (assert-equal "+0.0" + (lisp::format-f 0f0 nil nil 0 nil nil t))) + +;;; ---------------------------------------------------------------------- +;;; ~G single-float + +(define-test format-g.single-basic + (:tag :format-g :single-float) + ;; ~F-form path for value in normal range. + (assert-equal "3.1415927 " + (lisp::format-g 3.1415927f0 nil nil nil 1 nil nil #\f nil)) + (assert-equal "0. " + (lisp::format-g 0f0 nil nil nil 1 nil nil #\f nil)) + (assert-equal "-0. " + (lisp::format-g (- 0f0) nil nil nil 1 nil nil #\f nil))) + +(define-test format-g.single-large-uses-e + (:tag :format-g :single-float) + ;; Large values fall to ~E form. effective-d for f2s shortest + ;; depends on the digit count, but for 1e10f0 it's small. + ;; 1e10f0 has n=11, q small, dd negative -> ~E form. + (let ((s (lisp::format-g 1f10 nil nil nil 1 nil nil #\f nil))) + (assert-true (search "f+10" s) s))) + +(define-test format-g.single-small-uses-e + (:tag :format-g :single-float) + (let ((s (lisp::format-g 1f-5 nil nil nil 1 nil nil #\f nil))) + (assert-true (search "f-5" s) s))) + +(define-test format-g.single-d-given + (:tag :format-g :single-float) + ;; d-given uses the double path internally. + (assert-equal "3.1416 " + (lisp::format-g 3.1415927f0 nil 5 nil 1 nil nil #\f nil))) + +;;; ---------------------------------------------------------------------- +;;; Mixed-type sanity checks + +(define-test format-e.mixed-types + (:tag :format-e :single-float) + ;; Same nominal value, different float types -- should produce + ;; different shortest forms. + (let ((single-out (lisp::format-e 3.14f0 nil nil nil 1 nil nil #\f nil)) + (double-out (lisp::format-e 3.14d0 nil nil nil 1 nil nil #\d nil))) + (assert-true (search "f" single-out) single-out) + (assert-true (search "d" double-out) double-out))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/2722dfe9cdf6d53245a76d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/2722dfe9cdf6d53245a76d… 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-ryu-printf] Remove old code that was nil'ed out
by Raymond Toy (＠rtoy) 24 May '26

24 May '26

Raymond Toy pushed to branch rtoy-ryu-printf at cmucl / cmucl Commits: 2722dfe9 by Raymond Toy at 2026-05-24T08:02:46-07:00 Remove old code that was nil'ed out - - - - - 1 changed file: - src/code/print.lisp Changes: ===================================== src/code/print.lisp ===================================== @@ -2107,7 +2107,8 @@ radix-R. If you have a power-list then pass it in as PL." ((< n 100) 2) (t 3))) -(defun compute-exp-output-length (mantissa actual-exp k e is-negative-p at-sign-p drop-leading-zero-p) +(defun compute-exp-output-length (mantissa actual-exp k e is-negative-p at-sign-p + drop-leading-zero-p) ;; Compute length of the ~E result with the given parameters, but ;; don't build the string. MANTISSA is "d[.dddd]" from d2exp or d2s. ;; ACTUAL-EXP is the exponent with scaling factor applied. If @@ -2138,77 +2139,6 @@ radix-R. If you have a power-list then pass it in as PL." ;; +2 for the exponent marker and sign (+ sign-len mantissa-len exp-digits 2))) -#+nil -(defun reshape-format-e (mantissa-text k drop-leading-zero-p) - "Reshape MANTISSA-TEXT of the form 'd[.dddd]Eee' from d2s or d2exp into - the displayed mantissa for ~E with scale factor K. If - DROP-LEADING-ZERO-P is non-NIL, the leading 0 that would have been - printed is dropped." - (declare (type simple-string mantissa-text) - (fixnum k)) - ;; Fast path: K=1 covers the overwhelmingly common case since K=1 is - ;; the default. - (when (= k 1) - (return-from reshape-format-e - (cond - ((find #\. mantissa-text) - mantissa-text) ; verbatim - (t - (concatenate 'string mantissa-text ".0"))))) ; single digit -> "D.0" - (let* ((has-dot (find #\. mantissa-text)) - (lead-char (char mantissa-text 0)) - ;; Where the stuff after the dot starts - (tail-start (if has-dot 2 1)) - (tail-len (- (length mantissa-text) tail-start)) - (digit-count (1+ tail-len))) - ;; Several cases to consider: - ;; - ;; * k is negative so the new dot preceeds the mantissa. Pad with - ;; zeroes. - ;; * k is so large that the dot is past the rightmost part of the - ;; mantissa. Append enough zeroes and then add ".0" - ;; * k is somewhere in the mantissa. Handling of this case - ;; depends on if the new dot is to the left or to the right of - ;; the original dot. - (with-output-to-string (s) - (cond - ;; Case 2: new dot at or before position 0. - ((<= k 0) - (unless drop-leading-zero-p - (write-char #\0 s)) - (write-char #\. s) - ;; Insert zeros after the decimal but before the mantissa. - (loop repeat (- k) - do (write-char #\0 s)) - ;; Insert the mantissa, skipping the existing dot. - (write-char lead-char s) - (when (plusp tail-len) - (write-string mantissa-text s :start tail-start))) - ;; Case 1b: 1 < k < digit-count. Move dot right by (k-1). - ((< k digit-count) - ;; Output the original mantissa up to the original dot. - (write-char lead-char s) - (write-string mantissa-text s - :start tail-start - :end (+ tail-start k -1)) - ;; Output the new dot. - (write-char #\. s) - ;; Output everything after the original dot. - (write-string mantissa-text s - :start (+ tail-start k -1))) - ;; Case 3: k >= digit-count. Pad with zeros, force ".0". - (t - ;; Output the original mantissa, then everything after the - ;; dot (if there was one). - (write-char lead-char s) - (when (plusp tail-len) - (write-string mantissa-text s :start tail-start)) - ;; Pad with 0's - (loop repeat (- k digit-count) - do (write-char #\0 s)) - ;; Finish with ".0". - (write-string ".0" s)))))) - (defun scale-mantissa (stream mantissa-text k drop-leading-zero-p) "Write MANTISSA-TEXT to STREAM, shifting the decimal point so that the new dot lands K digits in from the start of the digit string. @@ -2292,56 +2222,6 @@ radix-R. If you have a power-list then pass it in as PL." ;; d - |k| - 1 digits after the decimal point. (max (+ d k -1) 0)))) -#+nil -(defun format-e-string (mantissa exponent is-negative-p w e k - overflowchar padchar exponentchar at-sign-p - drop-leading-zero-p) - (declare (type simple-string mantissa) - (fixnum exponent k)) - (let* ((shown-exp (- exponent (1- k))) - (exp-sign (if (minusp shown-exp) #\- #\+)) - (exp-abs (abs shown-exp)) - (exp-marker (or exponentchar #\d)) - (exp-string - (with-output-to-string (s) - (write-char exp-marker s) - (write-char exp-sign s) - #+nil - (let ((digits (princ-to-string exp-abs))) - (when e - (loop repeat (- e (length digits)) - do (write-char #\0 s))) - (write-string digits s)) - (let ((d (count-decimal-digits exp-abs))) - (when e - (loop repeat (- e d) - do (write-char #\0 s))) - (princ exp-abs s)))) - (sign-mantissa (cond (is-negative-p "-") - (at-sign-p "+") - (t ""))) - ;; Reshape once, reuse everywhere. - (reshaped (reshape-format-e mantissa k drop-leading-zero-p)) - (field-len (+ (length sign-mantissa) - (length reshaped) - (length exp-string)))) - (flet ((write-field (s) - (write-string sign-mantissa s) - (write-string reshaped s) - (write-string exp-string s))) - (with-output-to-string (s) - (cond - ((null w) - (write-field s)) - ((> field-len w) - (if overflowchar - (loop repeat w do (write-char overflowchar s)) - (write-field s))) - (t - (let ((pad-char (or padchar #\Space))) - (loop repeat (- w field-len) do (write-char pad-char s)) - (write-field s)))))))) - (defun format-e-string (stream mantissa exponent is-negative-p w e k overflowchar padchar exponentchar at-sign-p drop-leading-zero-p) @@ -2379,64 +2259,6 @@ radix-R. If you have a power-list then pass it in as PL." (declare (dynamic-extent #'write-field)) (pad-overflow stream field-len w overflowchar padchar #'write-field)))) -#+nil -(defun format-e (value w d e k overflowchar padchar exponentchar at-sign-p) - (declare (double-float value) - (fixnum k) - (type (or null (and unsigned-byte fixnum)) w d e) - (optimize (speed 3))) - (let* ((is-negative-p (minusp (float-sign value))) - (abs-value (abs value))) - (cond - (d - ;; Fixed precision path. Leading 0 is kept. - (multiple-value-bind (mantissa exponent) - (parsed-exp-form (d2exp abs-value (d2exp-precision d k))) - (format-e-string mantissa exponent is-negative-p - w e k overflowchar padchar exponentchar at-sign-p nil))) - (t - ;; Free-format path. Use d2s to find the shortest result. If - ;; it won't fit in the given format parameters, compute a new d - ;; value to make it fit in the given width if possible. - ;; Otherwise, overflow. - (multiple-value-bind (mantissa exponent) - (parsed-exp-form (d2s abs-value)) - (let* ((actual-exp (- exponent (1- k))) - (full-len (compute-exp-output-length mantissa actual-exp k e is-negative-p at-sign-p - nil))) - #+nil - (format t "mantissa = ~A exponent = ~D actual-exp = ~D full-len = ~D w = ~D~%" - mantissa exponent actual-exp full-len w) - (cond - ((or (null w) (<= full-len w)) - ;; Shortest fits. Emit it. Drop the leading 0 whenever - ;; k <= 0 so the actual emitted legnth matches the - ;; predicted one. - (format-e-string mantissa exponent is-negative-p - w e k overflowchar padchar exponentchar at-sign-p - (not (plusp k)))) - (t - ;; Doesn't fit. Compute the largest fitting d and - ;; recompute the result via d2exp. For backwards - ;; compatibility, drop the leading 0 when k <= 0 to - ;; maximize d, the number of digits shown. - (let* ((d-fit (compute-d-for-width w e k actual-exp is-negative-p at-sign-p)) - (drop-zero-p (and d-fit (<= k 0)))) - #+nil - (format t "d-fit = ~A, drop = ~A~%" d-fit drop-zero-p) - (if d-fit - (multiple-value-bind (mantissa exponent) - (parsed-exp-form (d2exp abs-value (d2exp-precision d-fit k))) - (format-e-string mantissa exponent is-negative-p - w e k overflowchar padchar exponentchar at-sign-p - drop-zero-p)) - ;; Even with d = 0, the result won't fit. Let - ;; FORMAT-E-STRING overflow with the overflow - ;; character. - (format-e-string mantissa exponent is-negative-p - w e k overflowchar padchar exponentchar at-sign-p - nil))))))))))) - (defun format-e (value w d e k overflowchar padchar exponentchar at-sign-p) (declare (double-float value) (fixnum k) @@ -2478,23 +2300,6 @@ radix-R. If you have a power-list then pass it in as PL." nil)))))))))))) ;;; Ryu ~F -#+nil -(defun format-f-fixed (stream abs-value is-negative-p w d overflowchar padchar at-sign-p) - (let* ((raw-string (let ((f (d2fixed abs-value d))) - ;; If precision = 0, d2fixed doesn't have a - ;; dot. We need it. - (if (zerop d) - (concatenate 'string f ".") - f))) - (field - (with-output-to-string (s) - (cond (is-negative-p - (write-char #\- s)) - (at-sign-p - (write-char #\+ s))) - (write-string raw-string s)))) - (format-f-pad-overflow field w overflowchar padchar))) - (declaim (inline pad-overflow)) (defun pad-overflow (stream field-len w overflowchar padchar field-writer) "Apply width/pad/overflow rules. FIELD-WRITER is a thunk of zero @@ -2565,34 +2370,6 @@ radix-R. If you have a power-list then pass it in as PL." (declare (dynamic-extent #'write-field)) (pad-overflow stream field-len w overflowchar padchar #'write-field)))) -#+nil -(defun format-f-free (abs-value is-negative-p w overflowchar padchar at-sign-p) - ;; We need to call d2s to get the shortest. - (multiple-value-bind (mantissa exponent) - (parsed-exp-form (d2s abs-value)) - (let* ((has-dot (find #\. mantissa)) - (digit-count (if has-dot (1- (length mantissa)) (length 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)) - (d-fit (and w (- w sign-len int-len 1)))) - (cond - ((or (null w) - (>= d-fit shortest-d)) - ;; Shortest fits or no width bound - (emit-shortest mantissa exponent is-negative-p w overflowchar padchar at-sign-p)) - ((minusp d-fit) - ;; Integer part alone exceeds w--overflow path - (if overflowchar - (make-string w :initial-element overflowchar) - ;; No overflow; emit shortest at natural width, overflow w. - (emit-shortest mantissa exponent is-negative-p - w overflowchar padchar at-sign-p))) - (t - ;; d-fit between 0 and shortest-d. Shrink via d2fixed. - (format-f-fixed abs-value is-negative-p - w d-fit overflowchar padchar at-sign-p)))))) - (defun format-f-free (stream abs-value is-negative-p w overflowchar padchar at-sign-p) (multiple-value-bind (mantissa exponent) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2722dfe9cdf6d53245a76d0… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2722dfe9cdf6d53245a76d0… 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-ryu-printf] Fix confusion in compute-exp-output-length
by Raymond Toy (＠rtoy) 24 May '26

24 May '26

Raymond Toy pushed to branch rtoy-ryu-printf at cmucl / cmucl Commits: 0f57e85c by Raymond Toy at 2026-05-24T07:38:28-07:00 Fix confusion in compute-exp-output-length Previously the parameter was leading-zero-p, but it's now being used with drop-leading-zero-p. Update compute-exp-output-length to use drop-leading-zero-p. The confusing inversion no longer exists and the test suite passes. - - - - - 2 changed files: - src/code/print.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/print.lisp ===================================== @@ -2107,36 +2107,34 @@ radix-R. If you have a power-list then pass it in as PL." ((< n 100) 2) (t 3))) -(defun compute-exp-output-length (mantissa actual-exp k e is-negative-p at-sign-p leading-zero-p) +(defun compute-exp-output-length (mantissa actual-exp k e is-negative-p at-sign-p drop-leading-zero-p) ;; Compute length of the ~E result with the given parameters, but - ;; don't build the string. MANTISSA is "d.dddEee" from d2exp or - ;; d2s. ACTUAL-EXP is the exponent with scaling factor applied. If - ;; LEADING-ZERO-P is not NIL, the leading "0" will be kept when K <= - ;; 0. Otherwise it's ignored. + ;; don't build the string. MANTISSA is "d[.dddd]" from d2exp or d2s. + ;; ACTUAL-EXP is the exponent with scaling factor applied. If + ;; DROP-LEADING-ZERO-P is non-NIL, the leading "0" before the dot + ;; (in the K <= 0 form) is omitted from the length. (let* ((sign-len (if (or is-negative-p at-sign-p) 1 0)) - (exp-digits (max (or e 1) - #+nil - (length (princ-to-string (abs actual-exp))) - (count-decimal-digits (abs actual-exp)))) - (dotp (find #\. mantissa)) - (raw-digits (let ((len (length mantissa))) - (if dotp (1- len) len))) - (mantissa-len - (cond - ((plusp k) - ;; k digits before, raw-digits - k after the dot. If - ;; raw-digitis <= k no dot and pad with zeroes before. - (if (> raw-digits k) - ;; "d.dddd" so raw-dits with dot. - (1+ raw-digits) - ;; "dddd" no dot, possibly padded. - (max raw-digits k))) - (t - ;; "0.000ddd" or ".000ddd" - (+ (if leading-zero-p 1 0) - 1 - (- k) - raw-digits))))) + (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))) + (mantissa-len + (cond + ((plusp k) + (cond + ((> raw-digits k) + (1+ raw-digits)) ; "D.DDDD" + ((and (= k 1) (= raw-digits 1)) + 3) ; "D.0" forced + (t + (max raw-digits k)))) ; "DDDD" + (t + ;; "0.000DDD" or ".000DDD" + (+ (if drop-leading-zero-p 0 1) + 1 ; the dot + (- k) ; leading zeros after the dot + raw-digits))))) ;; +2 for the exponent marker and sign (+ sign-len mantissa-len exp-digits 2))) @@ -2279,10 +2277,6 @@ radix-R. If you have a power-list then pass it in as PL." ;; Finish with ".0" (write-string ".0" stream))))) -(defun reshape-format-e (mantissa-text k drop-leading-zero-p) - (with-output-to-string (s) - (scale-mantissa s mantissa-text k drop-leading-zero-p))) - (defun d2exp-precision (d k) ;; Compute precision for d2exp when CL requests D digits and the ;; scale factor is K." @@ -2298,6 +2292,7 @@ radix-R. If you have a power-list then pass it in as PL." ;; d - |k| - 1 digits after the decimal point. (max (+ d k -1) 0)))) +#+nil (defun format-e-string (mantissa exponent is-negative-p w e k overflowchar padchar exponentchar at-sign-p drop-leading-zero-p) @@ -2347,6 +2342,44 @@ radix-R. If you have a power-list then pass it in as PL." (loop repeat (- w field-len) do (write-char pad-char s)) (write-field s)))))))) +(defun format-e-string (stream mantissa exponent is-negative-p w e k + overflowchar padchar exponentchar at-sign-p + drop-leading-zero-p) + (declare (type simple-string mantissa) + (fixnum exponent k)) + (let* ((shown-exp (- exponent (1- k))) + (exp-sign (if (minusp shown-exp) + #\- #\+)) + (exp-abs (abs shown-exp)) + (exp-marker (or exponentchar #\d)) + (exp-digits (count-decimal-digits exp-abs)) + (exp-width (max (or e 1) + exp-digits)) + (sign-len (if (or is-negative-p at-sign-p) + 1 0)) + ;; Full output length: sign + reshaped + marker + exp-sign + + ;; exp-width. compute-exp-output-length gives reshape + exp + ;; body (marker + exp-sign + max(e, exp-digits)), but it also + ;; includes sign, so use it directly. Wait, it doesn't + ;; account for drop-leading-zero, so we use it carefully. + (field-len (compute-exp-output-length mantissa shown-exp k e + is-negative-p at-sign-p + drop-leading-zero-p))) + (flet ((write-field () + (cond (is-negative-p + (write-char #\- stream)) + (at-sign-p + (write-char #\+ stream))) + (scale-mantissa stream mantissa k drop-leading-zero-p) + (write-char exp-marker stream) + (write-char exp-sign stream) + (loop repeat (- exp-width exp-digits) + do (write-char #\0 stream)) + (princ exp-abs stream))) + (declare (dynamic-extent #'write-field)) + (pad-overflow stream field-len w overflowchar padchar #'write-field)))) + +#+nil (defun format-e (value w d e k overflowchar padchar exponentchar at-sign-p) (declare (double-float value) (fixnum k) @@ -2404,6 +2437,46 @@ radix-R. If you have a power-list then pass it in as PL." w e k overflowchar padchar exponentchar at-sign-p nil))))))))))) +(defun format-e (value w d e k overflowchar padchar exponentchar at-sign-p) + (declare (double-float value) + (fixnum k) + (type (or null (and unsigned-byte fixnum)) w d e) + (optimize (speed 3))) + (let* ((is-negative-p (minusp (float-sign value))) + (abs-value (abs value))) + (with-output-to-string (stream) + (cond + (d + (multiple-value-bind (mantissa exponent) + (parsed-exp-form (d2exp abs-value (d2exp-precision d k))) + (format-e-string stream mantissa exponent is-negative-p + w e k overflowchar padchar exponentchar at-sign-p nil))) + (t + (multiple-value-bind (mantissa exponent) + (parsed-exp-form (d2s abs-value)) + (let* ((actual-exp (- exponent (1- k))) + (full-len (compute-exp-output-length mantissa actual-exp k e + is-negative-p at-sign-p + nil))) + (cond + ((or (null w) + (<= full-len w)) + (format-e-string stream mantissa exponent is-negative-p + w e k overflowchar padchar exponentchar at-sign-p + (not (plusp k)))) + (t + (let* ((d-fit (compute-d-for-width w e k actual-exp is-negative-p at-sign-p)) + (drop-zero-p (and d-fit (<= k 0)))) + (if d-fit + (multiple-value-bind (mantissa exponent) + (parsed-exp-form (d2exp abs-value (d2exp-precision d-fit k))) + (format-e-string stream mantissa exponent is-negative-p + w e k overflowchar padchar exponentchar at-sign-p + drop-zero-p)) + (format-e-string stream mantissa exponent is-negative-p + w e k overflowchar padchar exponentchar at-sign-p + nil)))))))))))) + ;;; Ryu ~F #+nil (defun format-f-fixed (stream abs-value is-negative-p w d overflowchar padchar at-sign-p) @@ -2457,13 +2530,6 @@ radix-R. If you have a power-list then pass it in as PL." (declare (dynamic-extent #'writ-field)) (pad-overflow stream field-len w overflowchar padchar #'write-field)))) -(defun reshape-fixed (stream mantissa-text exponent) - "Adjust MANTISSA-TEXT is scaled exactly by 10^{EXPONENT} by moving the - decimal point. MANTISSA-TEXT is of the form 'd[.dddd]' from d2exp - or d2s. The scaled value is written to STREAM." - (scale-mantissa stream mantissa-text (1+ exponent) nil)) - - (defun reshape-fixed-length (digit-count exponent) (let ((k (1+ exponent))) (cond ((zerop exponent) @@ -2491,9 +2557,11 @@ radix-R. If you have a power-list then pass it in as PL." (reshaped-len (reshape-fixed-length digit-count exponent)) (field-len (+ sign-len reshaped-len))) (flet ((write-field () - (cond (is-negative-p (write-char #\- stream)) - (at-sign-p (write-char #\+ stream))) - (reshape-fixed stream mantissa exponent))) + (cond (is-negative-p + (write-char #\- stream)) + (at-sign-p + (write-char #\+ stream))) + (scale-mantissa stream mantissa (1+ exponent) nil))) (declare (dynamic-extent #'write-field)) (pad-overflow stream field-len w overflowchar padchar #'write-field)))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -7737,13 +7737,6 @@ msgid "" " arguments that writes the field characters to STREAM." msgstr "" -#: src/code/print.lisp -msgid "" -"Adjust MANTISSA-TEXT is scaled exactly by 10^{EXPONENT} by moving the\n" -" decimal point. MANTISSA-TEXT is of the form 'd[.dddd]' from d2exp\n" -" or d2s. The scaled value is written to STREAM." -msgstr "" - #: src/code/print.lisp msgid "Weak Pointer: " msgstr "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0f57e85ca08d48aa6d2a101… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0f57e85ca08d48aa6d2a101… 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-ryu-printf] Remove old code that's commented out
by Raymond Toy (＠rtoy) 24 May '26

24 May '26

Raymond Toy pushed to branch rtoy-ryu-printf at cmucl / cmucl Commits: 0f4741bc by Raymond Toy at 2026-05-24T07:13:55-07:00 Remove old code that's commented out Update cmucl.pot. - - - - - 2 changed files: - src/code/print.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/print.lisp ===================================== @@ -2457,135 +2457,6 @@ radix-R. If you have a power-list then pass it in as PL." (declare (dynamic-extent #'writ-field)) (pad-overflow stream field-len w overflowchar padchar #'write-field)))) - -#+nil -(defun reshape-fixed (raw-digits exponent) - ;; RAW-DIGITS is a string of digits with no sign or decimal point. - (declare (simple-string raw-digits) - (fixnu exponent)) - (let* ((digit-count (length raw-digits)) - (left-count (1+ exponent))) - (cond ((>= left-count digit-count) - ;; All digits go in the integer part; pad with trailing - ;; zeros - (concatenate 'string - raw-digits - (make-string (- left-count digit-count) - :initial-element #\0) - ".0")) - ((plusp left-count) - (concatenate 'string - (subseq raw-digits 0 left-count) - "." - (subseq raw-digits left-count))) - (t - ;; All digits go in the fractional part; prepend "0." and - ;; any needed leading zeroes. - (concatenate 'string - "0." - (make-string (- left-count) :initial-element #\0) - raw-digits))))) - -#+nil -(defun reshape-fixed (raw-digits exponent) - ;; RAW-DIGITS is a string of digits with no sign or decimal point. - (declare (simple-string raw-digits) - (fixnum exponent)) - (let* ((digit-count (length raw-digits)) - (left-count (1+ exponent))) - (with-output-to-string (s) - (cond ((>= left-count digit-count) - ;; All digits go in the integer part; pad with trailing - ;; zeros - (write-string raw-digits s) - (loop for k from 0 below (- left-count digit-count) - do (write-char #\0 s)) - (write-string ".0" s)) - ((plusp left-count) - (write-string raw-digits s :start 0 :end left-count) - (write-char #\. s) - (write-string raw-digits s :start left-count)) - (t - ;; All digits go in the fractional part; prepend "0." and - ;; any needed leading zeroes. - (write-string "0." s) - (loop for k from 0 below (- left-count) - do (write-char #\0 s)) - (write-string raw-digits s)))))) - -#+nil -(defun reshape-fixed (mantissa-text exponent) - (declare (type simple-string mantissa-text) - (fixnum exponent)) - (reshape-format-e mantissa-text (1+ exponent) nil)) - -#+nil -(defun reshape-fixed (stream mantissa-text exponent) - "Adjust MANTISSA-TEXT is scaled exactly by 10^{EXPONENT} by moving the - decimal point. MANTISSA-TEXT is of the form 'd[.dddd]' from d2exp - or d2s. The scaled value is written to STREAM." - (declare (type simple-string mantissa-text) - (fixnum exponent)) - (let ((k (1+ exponent))) - ;; If exponent = 0, the mantissa is already the right value, but - ;; we need to append ".0" if there's not dot in the mantissa. - ;; This happens when d2s is given a small exact integral value. - (when (zerop exponent) - (write-string mantissa-text stream) - (unless (find #\. mantissa-text) - (write-string ".0" stream)) - (return-from reshape-fixed)) - (let* ((has-dot (find #\. mantissa-text)) - (lead-char (char mantissa-text 0)) - ;; Where the stuff after the dot starts - (tail-start (if has-dot 2 1)) - (tail-len (- (length mantissa-text) tail-start)) - (digit-count (1+ tail-len))) - ;; Several cases to consider: - ;; - ;; * k is negative so the new dot preceeds the mantissa. Pad with - ;; zeroes. - ;; * k is so large that the dot is past the rightmost part of the - ;; mantissa. Append enough zeroes and then add ".0" - ;; * k is somewhere in the mantissa. Handling of this case - ;; depends on if the new dot is to the left or to the right of - ;; the original dot. - (cond - ;; Case 2: new dot at or before position 0. - ((<= k 0) - (write-string "0." stream) - ;; Insert zeros after the decimal but before the mantissa. - (loop repeat (- k) - do (write-char #\0 stream)) - ;; Insert the mantissa, skipping the existing dot. - (write-char lead-char stream) - (when (plusp tail-len) - (write-string mantissa-text stream :start tail-start))) - ;; Case 1b: 1 < k < digit-count. Move dot right by (k-1). - ((< k digit-count) - ;; Output the original mantissa up to the original dot. - (write-char lead-char stream) - (write-string mantissa-text stream - :start tail-start - :end (+ tail-start k -1)) - ;; Output the new dot. - (write-char #\. stream) - ;; Output everything after the original dot. - (write-string mantissa-text stream - :start (+ tail-start k -1))) - ;; Case 3: k >= digit-count. Pad with zeros, force ".0". - (t - ;; Output the original mantissa, then everything after the - ;; dot (if there was one). - (write-char lead-char stream) - (when (plusp tail-len) - (write-string mantissa-text stream :start tail-start)) - ;; Pad with 0's - (loop repeat (- k digit-count) - do (write-char #\0 stream)) - ;; Finish with ".0". - (write-string ".0" stream)))))) - (defun reshape-fixed (stream mantissa-text exponent) "Adjust MANTISSA-TEXT is scaled exactly by 10^{EXPONENT} by moving the decimal point. MANTISSA-TEXT is of the form 'd[.dddd]' from d2exp @@ -2593,15 +2464,6 @@ radix-R. If you have a power-list then pass it in as PL." (scale-mantissa stream mantissa-text (1+ exponent) nil)) -#+nil -(defun emit-shortest (mantissa-text exponent is-negative-p w overflowchar padchar at-sign-p) - (let* ((reshaped (reshape-fixed mantissa-text exponent)) - (sign-text (cond (is-negative-p "-") - (at-sign-p "+") - (t ""))) - (field (concatenate 'string sign-text reshaped))) - (format-f-pad-overflow field w overflowchar padchar))) - (defun reshape-fixed-length (digit-count exponent) (let ((k (1+ exponent))) (cond ((zerop exponent) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -7731,10 +7731,6 @@ msgid "" " before all digits; K=1 leaves it at the original position." msgstr "" -#: src/code/print.lisp -msgid "Execution of a form compiled with errors:~% ~S" -msgstr "" - #: src/code/print.lisp msgid "" "Apply width/pad/overflow rules. FIELD-WRITER is a thunk of zero\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0f4741bc6989c434177786c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0f4741bc6989c434177786c… 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-ryu-printf] Refactor reshaping code to the new SCALE-MANTISSA function.
by Raymond Toy (＠rtoy) 24 May '26

24 May '26

Raymond Toy pushed to branch rtoy-ryu-printf at cmucl / cmucl Commits: 065ece94 by Raymond Toy at 2026-05-24T07:06:07-07:00 Refactor reshaping code to the new SCALE-MANTISSA function. `reshape-fixed` and `reshape-format-e` did almost exactly the same thing. Refactor the code in a few function `scale-mantissa` that basically replaces `reshape-fixed` and `reshape-format-e`. However, still need a thin wrapper for `reshape-format-e` until the callers get a stream that `reshape-format-e` can use so it can be replaced by `scale-mantissa`. - - - - - 2 changed files: - src/code/print.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/print.lisp ===================================== @@ -2140,6 +2140,7 @@ radix-R. If you have a power-list then pass it in as PL." ;; +2 for the exponent marker and sign (+ sign-len mantissa-len exp-digits 2))) +#+nil (defun reshape-format-e (mantissa-text k drop-leading-zero-p) "Reshape MANTISSA-TEXT of the form 'd[.dddd]Eee' from d2s or d2exp into the displayed mantissa for ~E with scale factor K. If @@ -2210,6 +2211,78 @@ radix-R. If you have a power-list then pass it in as PL." ;; Finish with ".0". (write-string ".0" s)))))) +(defun scale-mantissa (stream mantissa-text k drop-leading-zero-p) + "Write MANTISSA-TEXT to STREAM, shifting the decimal point so that + the new dot lands K digits in from the start of the digit string. + MANTISSA-TEXT is 'D' or 'D.DDDD' from d2s/d2exp. + DROP-LEADING-ZERO-P controls whether the leading '0' before the dot + is emitted when the result starts with '0.'. K=0 puts the dot + before all digits; K=1 leaves it at the original position." + (declare (type simple-string mantissa-text) + (fixnum k)) + ;; Fast path: k=1, mantissa already in target form. + (when (= k 1) + (write-string mantissa-text stream) + (unless (find #\. mantissa-text) + (write-string ".0" stream)) + (return-from scale-mantissa)) + (let* ((has-dot (find #\. mantissa-text)) + (lead-char (char mantissa-text 0)) + ;; Where the stuff after the dot starts + (tail-start (if has-dot 2 1)) + (tail-len (- (length mantissa-text) tail-start)) + (digit-count (1+ tail-len))) + ;; Several cases to consider: + ;; + ;; * k is negative so the new dot preceeds the mantissa. Pad with + ;; zeroes. + ;; * k is so large that the dot is past the rightmost part of the + ;; mantissa. Append enough zeroes and then add ".0" + ;; * k is somewhere in the mantissa. Handling of this case + ;; depends on if the new dot is to the left or to the right of + ;; the original dot. + (cond + ;; Case 2: new dot at or before position 0. + ((<= k 0) + ;; Write "0." or "." + (unless drop-leading-zero-p + (write-char #\0 stream)) + (write-char #\. stream) + ;; Insert zeros after the decimal but before the mantissa. + (loop repeat (- k) + do (write-char #\0 stream)) + ;; Add the mantissa, skipping any existing dot. + (write-char lead-char stream) + (when (plusp tail-len) + (write-string mantissa-text stream :start tail-start))) + ;; Case 1b: 1 < k < digit-count. + ((< k digit-count) + ;; Output the original mantissa up to the original dot. + (write-char lead-char stream) + (write-string mantissa-text stream + :start tail-start + :end (+ tail-start k -1)) + ;; Output the dot at the new position. + (write-char #\. stream) + ;; Output everything after the original dot. + (write-string mantissa-text stream :start (+ tail-start k -1))) + ;; Case 3: k >= digit-count. + (t + ;; Output the original mantissa, then everything after the + ;; dot (if there was one). + (write-char lead-char stream) + (when (plusp tail-len) + (write-string mantissa-text stream :start tail-start)) + ;; Pad with 0's + (loop repeat (- k digit-count) + do (write-char #\0 stream)) + ;; Finish with ".0" + (write-string ".0" stream))))) + +(defun reshape-format-e (mantissa-text k drop-leading-zero-p) + (with-output-to-string (s) + (scale-mantissa s mantissa-text k drop-leading-zero-p))) + (defun d2exp-precision (d k) ;; Compute precision for d2exp when CL requests D digits and the ;; scale factor is K." @@ -2446,6 +2519,7 @@ radix-R. If you have a power-list then pass it in as PL." (fixnum exponent)) (reshape-format-e mantissa-text (1+ exponent) nil)) +#+nil (defun reshape-fixed (stream mantissa-text exponent) "Adjust MANTISSA-TEXT is scaled exactly by 10^{EXPONENT} by moving the decimal point. MANTISSA-TEXT is of the form 'd[.dddd]' from d2exp @@ -2511,6 +2585,12 @@ radix-R. If you have a power-list then pass it in as PL." do (write-char #\0 stream)) ;; Finish with ".0". (write-string ".0" stream)))))) + +(defun reshape-fixed (stream mantissa-text exponent) + "Adjust MANTISSA-TEXT is scaled exactly by 10^{EXPONENT} by moving the + decimal point. MANTISSA-TEXT is of the form 'd[.dddd]' from d2exp + or d2s. The scaled value is written to STREAM." + (scale-mantissa stream mantissa-text (1+ exponent) nil)) #+nil ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -7723,10 +7723,16 @@ msgstr "" #: src/code/print.lisp msgid "" -"Reshape MANTISSA-TEXT of the form 'd[.dddd]Eee' from d2s or d2exp into\n" -" the displayed mantissa for ~E with scale factor K. If\n" -" DROP-LEADING-ZERO-P is non-NIL, the leading 0 that would have been\n" -" printed is dropped." +"Write MANTISSA-TEXT to STREAM, shifting the decimal point so that\n" +" the new dot lands K digits in from the start of the digit string.\n" +" MANTISSA-TEXT is 'D' or 'D.DDDD' from d2s/d2exp.\n" +" DROP-LEADING-ZERO-P controls whether the leading '0' before the dot\n" +" is emitted when the result starts with '0.'. K=0 puts the dot\n" +" before all digits; K=1 leaves it at the original position." +msgstr "" + +#: src/code/print.lisp +msgid "Execution of a form compiled with errors:~% ~S" msgstr "" #: src/code/print.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/065ece94d3dde4f524fc502… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/065ece94d3dde4f524fc502… 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-ryu-printf] Improve time and consing for format-f
by Raymond Toy (＠rtoy) 24 May '26

24 May '26

Raymond Toy pushed to branch rtoy-ryu-printf at cmucl / cmucl Commits: 49fc1f77 by Raymond Toy at 2026-05-24T06:39:55-07:00 Improve time and consing for format-f `reshape-fixed` consed a new string with any decimal removed. That's gone now by doing basically what reshape-format-e does. `emit-shortest` and `reshape-fixed` now accept a stream where the result is written. All the intermediate allocations are gone now. Added `reshape-fixed-length` so that `emit-shortest` can compute the appropriate field length without running reshape. Profile results: format-f is 11% faster. Consing for non-nil d is just 2% better, but d nil is 22% better. 10000 iterations × 11 sample values = 110000 format-f calls per impl. | metric | original | after stream refactor | improvement | |--------|---------:|----------------------:|------------:| | format-f-fixed bytes/call | 368 | 87 | -76% | | total time | 0.55 s | 0.49 s | -11% | | total bytes | 56 MB | 55 MB | -2% | | metric | original | after all changes | improvement | |--------|---------:|------------------:|------------:| | reshape-fixed bytes/call | 769 | 423 | -45% | | emit-shortest bytes/call | 195 | 8 | **-96%** | | format-f-free bytes/call | 109 | 24 | -78% | | total time | 1.28 s | 1.14 s | -11% | | total bytes | 135 MB | 105 MB | -22% | - d-given: **4.5 µs/call** - d-nil: **10.4 µs/call** - - - - - 2 changed files: - src/code/print.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/print.lisp ===================================== @@ -2440,11 +2440,79 @@ radix-R. If you have a power-list then pass it in as PL." do (write-char #\0 s)) (write-string raw-digits s)))))) +#+nil (defun reshape-fixed (mantissa-text exponent) (declare (type simple-string mantissa-text) (fixnum exponent)) (reshape-format-e mantissa-text (1+ exponent) nil)) +(defun reshape-fixed (stream mantissa-text exponent) + "Adjust MANTISSA-TEXT is scaled exactly by 10^{EXPONENT} by moving the + decimal point. MANTISSA-TEXT is of the form 'd[.dddd]' from d2exp + or d2s. The scaled value is written to STREAM." + (declare (type simple-string mantissa-text) + (fixnum exponent)) + (let ((k (1+ exponent))) + ;; If exponent = 0, the mantissa is already the right value, but + ;; we need to append ".0" if there's not dot in the mantissa. + ;; This happens when d2s is given a small exact integral value. + (when (zerop exponent) + (write-string mantissa-text stream) + (unless (find #\. mantissa-text) + (write-string ".0" stream)) + (return-from reshape-fixed)) + (let* ((has-dot (find #\. mantissa-text)) + (lead-char (char mantissa-text 0)) + ;; Where the stuff after the dot starts + (tail-start (if has-dot 2 1)) + (tail-len (- (length mantissa-text) tail-start)) + (digit-count (1+ tail-len))) + ;; Several cases to consider: + ;; + ;; * k is negative so the new dot preceeds the mantissa. Pad with + ;; zeroes. + ;; * k is so large that the dot is past the rightmost part of the + ;; mantissa. Append enough zeroes and then add ".0" + ;; * k is somewhere in the mantissa. Handling of this case + ;; depends on if the new dot is to the left or to the right of + ;; the original dot. + (cond + ;; Case 2: new dot at or before position 0. + ((<= k 0) + (write-string "0." stream) + ;; Insert zeros after the decimal but before the mantissa. + (loop repeat (- k) + do (write-char #\0 stream)) + ;; Insert the mantissa, skipping the existing dot. + (write-char lead-char stream) + (when (plusp tail-len) + (write-string mantissa-text stream :start tail-start))) + ;; Case 1b: 1 < k < digit-count. Move dot right by (k-1). + ((< k digit-count) + ;; Output the original mantissa up to the original dot. + (write-char lead-char stream) + (write-string mantissa-text stream + :start tail-start + :end (+ tail-start k -1)) + ;; Output the new dot. + (write-char #\. stream) + ;; Output everything after the original dot. + (write-string mantissa-text stream + :start (+ tail-start k -1))) + ;; Case 3: k >= digit-count. Pad with zeros, force ".0". + (t + ;; Output the original mantissa, then everything after the + ;; dot (if there was one). + (write-char lead-char stream) + (when (plusp tail-len) + (write-string mantissa-text stream :start tail-start)) + ;; Pad with 0's + (loop repeat (- k digit-count) + do (write-char #\0 stream)) + ;; Finish with ".0". + (write-string ".0" stream)))))) + + #+nil (defun emit-shortest (mantissa-text exponent is-negative-p w overflowchar padchar at-sign-p) (let* ((reshaped (reshape-fixed mantissa-text exponent)) @@ -2454,15 +2522,36 @@ radix-R. If you have a power-list then pass it in as PL." (field (concatenate 'string sign-text reshaped))) (format-f-pad-overflow field w overflowchar padchar))) +(defun reshape-fixed-length (digit-count exponent) + (let ((k (1+ exponent))) + (cond ((zerop exponent) + ;; Fast path + (if (= digit-count 1) + 3 + (1+ digit-count))) + ((<= k 0) + ;; "0." + |k| zeros + digits + (+ 2 (- k) digit-count)) + ((< k digit-count) + ;; "ddd.ddd"; add one for the dot. + (1+ digit-count)) + (t + ;; "ddddd.0"; k digits + ".0" + (+ k 2))))) + (defun emit-shortest (stream mantissa exponent is-negative-p w overflowchar padchar at-sign-p) - (let* ((reshaped (reshape-fixed mantissa exponent)) + (let* ((has-dot (find #\. mantissa)) + ;; Number of digits, not including the decimal point. + (digit-count (- (length mantissa) + (if has-dot 1 0))) (sign-len (if (or is-negative-p at-sign-p) 1 0)) - (field-len (+ sign-len (length reshaped)))) + (reshaped-len (reshape-fixed-length digit-count exponent)) + (field-len (+ sign-len reshaped-len))) (flet ((write-field () (cond (is-negative-p (write-char #\- stream)) (at-sign-p (write-char #\+ stream))) - (write-string reshaped stream))) + (reshape-fixed stream mantissa exponent))) (declare (dynamic-extent #'write-field)) (pad-overflow stream field-len w overflowchar padchar #'write-field)))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -7729,6 +7729,19 @@ msgid "" " printed is dropped." msgstr "" +#: src/code/print.lisp +msgid "" +"Apply width/pad/overflow rules. FIELD-WRITER is a thunk of zero\n" +" arguments that writes the field characters to STREAM." +msgstr "" + +#: src/code/print.lisp +msgid "" +"Adjust MANTISSA-TEXT is scaled exactly by 10^{EXPONENT} by moving the\n" +" decimal point. MANTISSA-TEXT is of the form 'd[.dddd]' from d2exp\n" +" or d2s. The scaled value is written to STREAM." +msgstr "" + #: src/code/print.lisp msgid "Weak Pointer: " msgstr "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/49fc1f77da6bca498fa846f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/49fc1f77da6bca498fa846f… 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][master] 2 commits: Fix #502: char-equal docstring indented incorrectly
by Raymond Toy (＠rtoy) 05 May '26

05 May '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 916b4bda by Raymond Toy at 2026-05-04T19:17:52-07:00 Fix #502: char-equal docstring indented incorrectly - - - - - 8544d3eb by Raymond Toy at 2026-05-04T19:17:52-07:00 Merge branch 'issue-502-fix-char-equal-docstring-indentation' into 'master' Fix #502: char-equal docstring indented incorrectly Closes #502 See merge request cmucl/cmucl!379 - - - - - 2 changed files: - src/code/char.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/char.lisp ===================================== @@ -421,7 +421,7 @@ (defun char-equal (character &rest more-characters) "Returns T if all of its arguments are the same character. - Case is ignored." + Case is ignored." (do ((clist more-characters (cdr clist))) ((atom clist) T) (unless (= (equal-char-code (car clist)) @@ -431,7 +431,7 @@ (defun char-not-equal (character &rest more-characters) "Returns T if no two of its arguments are the same character. - Case is ignored." + Case is ignored." (do* ((head character (car list)) (list more-characters (cdr list))) ((atom list) T) @@ -445,7 +445,7 @@ (defun char-lessp (character &rest more-characters) "Returns T if its arguments are in strictly increasing alphabetic order. - Case is ignored." + Case is ignored." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) @@ -456,7 +456,7 @@ (defun char-greaterp (character &rest more-characters) "Returns T if its arguments are in strictly decreasing alphabetic order. - Case is ignored." + Case is ignored." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) @@ -467,7 +467,7 @@ (defun char-not-greaterp (character &rest more-characters) "Returns T if its arguments are in strictly non-decreasing alphabetic order. - Case is ignored." + Case is ignored." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) @@ -478,7 +478,7 @@ (defun char-not-lessp (character &rest more-characters) "Returns T if its arguments are in strictly non-increasing alphabetic order. - Case is ignored." + Case is ignored." (do* ((c character (car list)) (list more-characters (cdr list))) ((atom list) T) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -5644,37 +5644,37 @@ msgstr "" #: src/code/char.lisp msgid "" "Returns T if all of its arguments are the same character.\n" -" Case is ignored." +" Case is ignored." msgstr "" #: src/code/char.lisp msgid "" "Returns T if no two of its arguments are the same character.\n" -" Case is ignored." +" Case is ignored." msgstr "" #: src/code/char.lisp msgid "" "Returns T if its arguments are in strictly increasing alphabetic order.\n" -" Case is ignored." +" Case is ignored." msgstr "" #: src/code/char.lisp msgid "" "Returns T if its arguments are in strictly decreasing alphabetic order.\n" -" Case is ignored." +" Case is ignored." msgstr "" #: src/code/char.lisp msgid "" "Returns T if its arguments are in strictly non-decreasing alphabetic order.\n" -" Case is ignored." +" Case is ignored." msgstr "" #: src/code/char.lisp msgid "" "Returns T if its arguments are in strictly non-increasing alphabetic order.\n" -" Case is ignored." +" Case is ignored." msgstr "" #: src/code/char.lisp View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/526bc7d8ad5d3475ff7e18… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/526bc7d8ad5d3475ff7e18… 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] Pushed new branch issue-502-fix-char-equal-docstring-indentation
by Raymond Toy (＠rtoy) 05 May '26

05 May '26

Raymond Toy pushed new branch issue-502-fix-char-equal-docstring-indentation at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-502-fix-char-equal-… 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][master] 2 commits: Fix #501: unix-tests::mkstemp.name-returned sometimes fails
by Raymond Toy (＠rtoy) 05 May '26

05 May '26

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 70be84be by Raymond Toy at 2026-05-04T17:20:45-07:00 Fix #501: unix-tests::mkstemp.name-returned sometimes fails - - - - - 526bc7d8 by Raymond Toy at 2026-05-04T17:20:46-07:00 Merge branch 'issue-501-mkstemp-name-returned-test-fails' into 'master' Fix #501: unix-tests::mkstemp.name-returned sometimes fails Closes #501 See merge request cmucl/cmucl!378 - - - - - 1 changed file: - tests/unix.lisp Changes: ===================================== tests/unix.lisp ===================================== @@ -16,7 +16,7 @@ (assert-true fd) (assert-true (equalp (length filename) (length template))) (assert-false (equalp filename template)) - (assert-true (>= 5 (mismatch filename template)) + (assert-true (string/= filename template) filename template)))) (when fd View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/523b8fc34dfac4b6c91065… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/523b8fc34dfac4b6c91065… 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] Pushed new branch issue-501-mkstemp-name-returned-test-fails
by Raymond Toy (＠rtoy) 04 May '26

04 May '26

Raymond Toy pushed new branch issue-501-mkstemp-name-returned-test-fails at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-501-mkstemp-name-re… 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