Raymond Toy pushed to branch issue-480-double-double-hex-printer at cmucl / cmucl Commits: 38972cfe by Raymond Toy at 2026-03-08T15:01:33-07:00 Update cmucl.pot for new/changed docstrings - - - - - d948a386 by Raymond Toy at 2026-03-08T15:01:41-07:00 Clean up code and tests a bit. - - - - - 3 changed files: - src/code/ext-code.lisp - src/i18n/locale/cmucl.pot - tests/extensions.lisp Changes: ===================================== src/code/ext-code.lisp ===================================== @@ -23,10 +23,6 @@ ;;;; C-style hex float printer and parser -;;; FLOAT-TO-HEX-STRING -- Public -;;; -;;; Return a string representing a single and double-floats in C-style -;;; hex format. (defun trim-trailing-zeros (s) "Remove trailing zero characters from string S, preserving internal zeros." (let ((last-nonzero (position #\0 s :test #'char/= :from-end t))) @@ -35,70 +31,65 @@ ""))) -(defun write-hex-float-double (x stream mantissa-bits type) - "Print a single- or double-float in hex format onto STREAM. - MANTISSA-BITS is 23 for single, 52 for double (excluding implicit leading 1). - X must be the original float of the appropriate type; do not pre-coerce." - (when (and (not (float-nan-p x)) (minusp (float-sign x))) - (write-char #\- stream)) - (let ((x (abs x))) - (cond - ((float-nan-p x) - (write-string "0x0.0p+nan" stream) - (ecase type - (:single (write-char #\f stream)) - (:double (values)))) +(defun write-hex-float-double (x stream) + "Print a single-float or double-float in hex format onto STREAM." + ;; Float type and mantissa width are derived from the type of X. + (multiple-value-bind (mantissa-bits suffix-char min-c-exp) + (etypecase x + (single-float (values 23 #\f -126)) + (double-float (values 52 nil -1022))) + (when (and (not (float-nan-p x)) (minusp (float-sign x))) + (write-char #\- stream)) + (let ((x (abs x))) + (cond + ((float-nan-p x) + (write-string "0x0.0p+nan" stream) + (when suffix-char (write-char suffix-char stream))) - ((float-infinity-p x) - (write-string "0x1.0p+inf" stream) - (ecase type - (:single (write-char #\f stream)) - (:double (values)))) + ((float-infinity-p x) + (write-string "0x1.0p+inf" stream) + (when suffix-char (write-char suffix-char stream))) - ((zerop x) - (write-string "0x0p+0" stream) - (ecase type - (:single (write-char #\f stream)) - (:double (values)))) + ((zerop x) + (write-string "0x0p+0" stream) + (when suffix-char (write-char suffix-char stream))) - (t - (multiple-value-bind (significand exponent sign) - (integer-decode-float x) - (declare (ignore sign)) - (let* ((c-exp (+ exponent mantissa-bits)) - (min-c-exp (ecase type - (:double -1022) - (:single -126))) - (denormalp (< c-exp min-c-exp)) - (hex-digits (ceiling mantissa-bits 4)) - (frac-shift (- (* 4 hex-digits) mantissa-bits)) - (frac (if denormalp - (ash significand - (+ (- c-exp min-c-exp) frac-shift)) - (ash (logand significand - (1- (ash 1 mantissa-bits))) - frac-shift))) - (out-exp (if denormalp min-c-exp c-exp)) - (frac-str (trim-trailing-zeros - (format nil "~v,'0X" hex-digits frac)))) - (write-string "0x" stream) - (write-char (if denormalp #\0 #\1) stream) - (unless (zerop (length frac-str)) - (write-char #\. stream) - (write-string frac-str stream)) - (write-char #\p stream) - (when (>= out-exp 0) (write-char #\+ stream)) - (write-string (format nil "~D" out-exp) stream) - (ecase type - (:single (write-char #\f stream)) - (:double (values)))))))) - (values)) + (t + (multiple-value-bind (significand exponent sign) + (integer-decode-float x) + (declare (ignore sign)) + (let* ((c-exp (+ exponent mantissa-bits)) + (denormalp (< c-exp min-c-exp)) + (hex-digits (ceiling mantissa-bits 4)) + (frac-shift (- (* 4 hex-digits) mantissa-bits)) + (frac (if denormalp + (ash significand + (+ (- c-exp min-c-exp) frac-shift)) + (ash (logand significand + (1- (ash 1 mantissa-bits))) + frac-shift))) + (out-exp (if denormalp min-c-exp c-exp)) + (frac-str (trim-trailing-zeros + (format nil "~v,'0X" hex-digits frac)))) + (write-string "0x" stream) + (write-char (if denormalp #\0 #\1) stream) + (unless (zerop (length frac-str)) + (write-char #\. stream) + (write-string frac-str stream)) + (write-char #\p stream) + (when (>= out-exp 0) + (write-char #\+ stream)) + (write-string (format nil "~D" out-exp) stream) + (when suffix-char + (write-char suffix-char stream))))))) + (values))) +#+double-double (defun write-hex-float-double-double (x stream) - "Print a double-double-float in hex format onto STREAM. - Reconstructs the full significand from hi and lo components - using exact integer arithmetic before formatting." + "Print a double-double-float in hex format onto STREAM." + ;; Reconstructs the full significand from hi and lo components using + ;; exact integer arithmetic before formatting." (let* ((hi (kernel:double-double-hi x)) (lo (kernel:double-double-lo x)) (hi (abs hi))) @@ -125,7 +116,8 @@ (denormalp (< c-exp min-c-exp)) (raw-frac-bits (if (zerop lo) 52 - (+ (- exp-hi exp-lo) 52))) + (+ (- exp-hi exp-lo) + 52))) (frac-bits (* 4 (ceiling raw-frac-bits 4))) (hex-digits (/ frac-bits 4)) (shift (if denormalp @@ -145,25 +137,16 @@ (write-char #\. stream) (write-string frac-str stream)) (write-char #\p stream) - (when (>= out-exp 0) (write-char #\+ stream)) + (when (>= out-exp 0) + (write-char #\+ stream)) (write-string (format nil "~D" out-exp) stream) (write-char #\w stream)))))) (values))) -(defun write-hex-float (x &optional (stream *standard-output*)) - "Write float X to STREAM in C-style hex format. - STREAM defaults to *standard-output*. - single-float => 0x<mantissa>p<exp>f - double-float => 0x<mantissa>p<exp> - double-double-float => 0x<mantissa>p<exp>w - Negative zero is printed with a leading minus sign." - (let ((*print-case* :downcase)) - (etypecase x - (double-double-float (write-hex-float-double-double x stream)) - (double-float (write-hex-float-double x stream 52 :double)) - (single-float (write-hex-float-double x stream 23 :single)))) - (values)) - +;;; FLOAT-TO-HEX-STRING -- Public +;;; +;;; Return a string representing a single and double-floats in C-style +;;; hex format. (defun float-to-hex-string (x) "Return a string containing the C-style hex float representation of X. single-float => \"0x<mantissa>p<exp>f\" @@ -173,6 +156,30 @@ (write-hex-float x s))) +;;; WRITE-HEX-FLOAT -- Public +;;; +;;; Writes a float value (single, double, or double-double) in hex +;;; format to a stream, defaulting to *standard-output*. +(defun write-hex-float (x &optional (stream *standard-output*)) + "Write float X to STREAM in C-style hex format. STREAM defaults to *standard-output*. + + single-float => 0x<mantissa>p<exp>f + double-float => 0x<mantissa>p<exp> + double-double-float => 0x<mantissa>p<exp>w + + Negative zero is printed with a leading minus sign." + (let ((*print-case* :downcase)) + (etypecase x + (single-float + (write-hex-float-double x stream)) + (double-float + (write-hex-float-double x stream)) + #+double-double + (double-double-float + (write-hex-float-double-double x stream)))) + (values)) + + ;;; FORMAT-HEX-FLOAT -- Public ;;; ;;; Function that can be used in a FORMAT ~/ @@ -180,18 +187,15 @@ "Format function for use with ~/package:format-hex-float/. Ignores colon modifier. At-sign modifier forces a leading + sign on non-negative values. - Example: (format t \"~@/format-hex-float/\" 3.0d0) => +0x1.8p+1" + Example: (format t \"~@/ext:format-hex-float/\" 3.0d0) => +0x1.8p+1" (declare (ignore colonp args)) (when (and atsignp - (not (float-nan-p (if (typep x 'ext:double-double-float) - (kernel:double-double-hi x) - x))) - (not (minusp (float-sign (if (typep x 'ext:double-double-float) - (kernel:double-double-hi x) - x))))) + (not (float-nan-p x)) + (not (minusp (float-sign x)))) (write-char #\+ stream)) (write-hex-float x stream)) + (define-condition hex-parse-error (parse-error) ((text :initarg :text :reader hex-parse-error-text) (message :initarg :message :reader hex-parse-error-message)) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6066,28 +6066,11 @@ msgid "" msgstr "" #: src/code/ext-code.lisp -msgid "" -"Print a single- or double-float in hex format onto STREAM.\n" -" MANTISSA-BITS is 23 for single, 52 for double (excluding implicit " -"leading 1).\n" -" X must be the original float of the appropriate type; do not pre-coerce." -msgstr "" - -#: src/code/ext-code.lisp -msgid "" -"Print a double-double-float in hex format onto STREAM.\n" -" Reconstructs the full significand from hi and lo components\n" -" using exact integer arithmetic before formatting." +msgid "Print a single-float or double-float in hex format onto STREAM." msgstr "" #: src/code/ext-code.lisp -msgid "" -"Write float X to STREAM in C-style hex format.\n" -" STREAM defaults to *standard-output*.\n" -" single-float => 0x<mantissa>p<exp>f\n" -" double-float => 0x<mantissa>p<exp>\n" -" double-double-float => 0x<mantissa>p<exp>w\n" -" Negative zero is printed with a leading minus sign." +msgid "Print a double-double-float in hex format onto STREAM." msgstr "" #: src/code/ext-code.lisp @@ -6098,12 +6081,24 @@ msgid "" " double-double-float => \"0x<mantissa>p<exp>w\"" msgstr "" +#: src/code/ext-code.lisp +msgid "" +"Write float X to STREAM in C-style hex format. STREAM defaults to *standard-" +"output*.\n" +"\n" +" single-float => 0x<mantissa>p<exp>f\n" +" double-float => 0x<mantissa>p<exp>\n" +" double-double-float => 0x<mantissa>p<exp>w\n" +"\n" +" Negative zero is printed with a leading minus sign." +msgstr "" + #: src/code/ext-code.lisp msgid "" "Format function for use with ~/package:format-hex-float/.\n" " Ignores colon modifier.\n" " At-sign modifier forces a leading + sign on non-negative values.\n" -" Example: (format t \"~@/format-hex-float/\" 3.0d0) => +0x1.8p+1" +" Example: (format t \"~@/ext:format-hex-float/\" 3.0d0) => +0x1.8p+1" msgstr "" #: src/code/ext-code.lisp ===================================== tests/extensions.lisp ===================================== @@ -10,6 +10,8 @@ (assert-equal "0x1.8p+1w" (ext:float-to-hex-string 3.0w0)) (assert-equal "-0x1.8p+1" (ext:float-to-hex-string -3.0d0))) +;;; ---- write-hex-float / float-to-hex-string tests ------------------------- + (define-test write-double-zero (assert-equal "0x0p+0" (ext:float-to-hex-string 0.0d0)) (assert-equal "-0x0p+0" (ext:float-to-hex-string -0.0d0))) @@ -19,12 +21,12 @@ (assert-equal "-0x1p+0" (ext:float-to-hex-string -1.0d0))) (define-test write-double-powers-of-two - (assert-equal "0x1p+1" (ext:float-to-hex-string 2.0d0)) - (assert-equal "0x1p-1" (ext:float-to-hex-string 0.5d0)) - (assert-equal "0x1p+52" (ext:float-to-hex-string (expt 2.0d0 52))) - (assert-equal "0x1p-52" (ext:float-to-hex-string (expt 2.0d0 -52))) - (assert-equal "0x1p+1023" (ext:float-to-hex-string (expt 2.0d0 1023))) - (assert-equal "0x1p-1022" (ext:float-to-hex-string (expt 2.0d0 -1022)))) + (assert-equal "0x1p+1" (ext:float-to-hex-string (scale-float 1.0d0 1))) + (assert-equal "0x1p-1" (ext:float-to-hex-string (scale-float 1.0d0 -1))) + (assert-equal "0x1p+52" (ext:float-to-hex-string (scale-float 1.0d0 52))) + (assert-equal "0x1p-52" (ext:float-to-hex-string (scale-float 1.0d0 -52))) + (assert-equal "0x1p+1023" (ext:float-to-hex-string (scale-float 1.0d0 1023))) + (assert-equal "0x1p-1022" (ext:float-to-hex-string (scale-float 1.0d0 -1022)))) (define-test write-double-fractions (assert-equal "0x1.8p+1" (ext:float-to-hex-string 3.0d0)) @@ -33,8 +35,8 @@ (assert-equal "0x1.921fb54442d18p+1" (ext:float-to-hex-string pi))) (define-test write-double-denormals - (assert-equal "0x0.8p-1022" (ext:float-to-hex-string (expt 2.0d0 -1023))) - (assert-equal "0x0.0000000000001p-1022" (ext:float-to-hex-string (expt 2.0d0 -1074)))) + (assert-equal "0x0.8p-1022" (ext:float-to-hex-string (scale-float 1.0d0 -1023))) + (assert-equal "0x0.0000000000001p-1022" (ext:float-to-hex-string (scale-float 1.0d0 -1074)))) (define-test write-double-special (assert-equal "0x1.0p+inf" @@ -58,10 +60,10 @@ (assert-equal "0x1.8p+1f" (ext:float-to-hex-string 3.0f0)) (assert-equal "0x1.555556p-2f" (ext:float-to-hex-string (/ 1.0f0 3.0f0))) (assert-equal "0x1.fffffep+127f" (ext:float-to-hex-string most-positive-single-float)) - (assert-equal "0x1p-126f" (ext:float-to-hex-string (expt 2.0f0 -126)))) + (assert-equal "0x1p-126f" (ext:float-to-hex-string (scale-float 1.0f0 -126)))) (define-test write-single-denormals - (assert-equal "0x0.000002p-126f" (ext:float-to-hex-string (expt 2.0f0 -149)))) + (assert-equal "0x0.000002p-126f" (ext:float-to-hex-string (scale-float 1.0f0 -149)))) (define-test write-single-special (assert-equal "0x1.0p+inff" @@ -82,11 +84,13 @@ (assert-equal "0x1p+0w" (ext:float-to-hex-string 1.0w0)) (assert-equal "-0x1p+0w" (ext:float-to-hex-string -1.0w0)) (assert-equal "0x1.8p+1w" (ext:float-to-hex-string 3.0w0)) - (assert-equal "0x1p+64w" (ext:float-to-hex-string (expt 2.0w0 64))) + (assert-equal "0x1p+64w" (ext:float-to-hex-string (scale-float 1.0w0 64))) (assert-equal "0x1.921fb54442d18p+1w" (ext:float-to-hex-string (coerce pi 'ext:double-double-float))) (assert-equal "0x1.fffffffffffff8p-1w" - (ext:float-to-hex-string (- 1.0w0 (expt 2.0w0 -54))))) + (ext:float-to-hex-string (- 1.0w0 (scale-float 1.0w0 -54))))) + + (defun get-double-bits (val) (multiple-value-bind (hi lo) (kernel:double-float-bits val) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9ac58853a31d60a157e02b0... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9ac58853a31d60a157e02b0... You're receiving this email because of your account on gitlab.common-lisp.net.