GitLab

at 2026-05-24T14:39:00-07:00

Refactor some common code

Add get-sign-and-absolute-value to extract the sign and absolute value
of the given float.  The absolute value is a double-float.

Move pad-overflow before first use.

        ;; Finish with ".0"

        (write-string ".0" stream)))))

+(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

+   arguments that writes the field characters to STREAM."

+  (declare (function field-writer))

+  (cond

+    ((null w)

+     (funcall field-writer))

+    ((and (> field-len w)

+	  overflowchar)

+     (loop repeat w do

+       (write-char overflowchar stream)))

+    ((> field-len w)

+     (funcall field-writer))

+    (t

+     (let ((pad (or padchar #\space)))

+       (loop repeat (- w field-len)

+             do (write-char pad stream)))

+     (funcall field-writer))))

+

+(declaim (inline get-sign-and-absolute-value))

+(defun get-sign-and-absolute-value (value)

+  "Returns two values for the float VALUE: T if the value is negative and

+  the double-float absolute value of VALUE."

+  (declare (type (or single-float double-float) value))

+  (etypecase value

+    (double-float

+     (values (minusp (float-sign value))

+	     (abs value)))

+    (single-float

+     (values (minusp (float-sign value))

+	     (abs (float (value 1d0)))))))

+     

 (defun d2exp-precision (d k)

   ;; Compute precision for d2exp when CL requests D digits and the

   ;; scale factor is K."

            (type (or null (and unsigned-byte fixnum)) w d e)

            (optimize (speed 3)))

   (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)))))

+      (get-sign-and-absolute-value value)

     (with-output-to-string (stream)

       (cond

         (d

                                        nil))))))))))))

 ;;; Ryu ~F

-(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

-   arguments that writes the field characters to STREAM."

-  (declare (function field-writer))

-  (cond

-    ((null w)

-     (funcall field-writer))

-    ((and (> field-len w)

-	  overflowchar)

-     (loop repeat w do

-       (write-char overflowchar stream)))

-    ((> field-len w)

-     (funcall field-writer))

-    (t

-     (let ((pad (or padchar #\space)))

-       (loop repeat (- w field-len)

-             do (write-char pad stream)))

-     (funcall field-writer))))

-

 (defun format-f-fixed (stream abs-value is-negative-p w d

                        overflowchar padchar at-sign-p)

   (declare (double-float abs-value))

                    (at-sign-p     (write-char #\+ stream)))

              (write-string raw-string stream)

              (when need-dot (write-char #\. stream))))

-      (declare (dynamic-extent #'writ-field))

+      (declare (dynamic-extent #'write-field))

       (pad-overflow stream field-len w overflowchar padchar #'write-field))))

 (defun reshape-fixed-length (digit-count exponent)

                 (emit-shortest stream mantissa exponent is-negative-p w

                                overflowchar padchar at-sign-p))))

         (t

-	 (let ((abs-value (etypecase value

-			    (double-float (abs value))

-			    (single-float (abs value)))))

+	 (multiple-value-bind (is-negative-p abs-value)

+	     (get-sign-and-absolute-value value)

            (format-f-fixed stream abs-value is-negative-p w d-fit

                            overflowchar padchar at-sign-p)))))))

 	   (fixnum k)

 	   (type (or null (and unsigned-byte fixnum)) w d))

   (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)))))

+      (get-sign-and-absolute-value value)

     (with-output-to-string (s)

       (cond ((not (zerop k))

 	     ;;  Complex case that doesn't fit with what d2s and d2fixed

Raymond Toy pushed to branch rtoy-ryu-printf at cmucl / cmucl

Commits:

1 changed file:

Changes: