Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl Commits: 029170e8 by Raymond Toy at 2026-02-23T19:11:09-05:00 Refactoring and renaming for final API Merged the separate single and double hex printer into FLOAT-TO-HEX-STRING. Added WRITE-HEX-FLOAT that writes a float to the given stream, like WRITE-STRING, except for hex floats. FORMAT-HEX-FLOAT simplified to use FLOAT-TO-HEX-STRING. PARSE-HEX-FLOAT converts a hex float number from either a string or a stream. - - - - - 03794011 by Raymond Toy at 2026-02-23T19:14:14-05:00 Update exports for new API - - - - - 68e2a5c2 by Raymond Toy at 2026-02-23T19:14:33-05:00 Update tests to use the new names. - - - - - 3 changed files: - src/code/exports.lisp - src/code/ext-code.lisp - tests/extensions.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -1370,7 +1370,8 @@ "REMOVE-PACKAGE-LOCAL-NICKNAME" "PACKAGE-LOCALLY-NICKNAMED-BY-LIST") ;; Printing and parsing of C-style hex floats - (:export "PRINT-HEX-FLOAT" + (:export "FLOAT-TO-HEX-STRING" + "WRITE-HEX-FLOAT" "FORMAT-HEX-FLOAT" "HEX-PARSE-ERROR" "PARSE-HEX-FLOAT")) ===================================== src/code/ext-code.lisp ===================================== @@ -21,100 +21,69 @@ (intl:textdomain "cmucl") -;;; C-style hex float printer and parser -(defun print-hex-single-float (val) - "Prints a single-float in C-style hex format." - (cond ((float-nan-p val) - "nan") - ((float-infinity-p val) - (if (plusp val) "inf" "-inf")) - ((zerop val) - (if (eql val -0.0f0) - "-0x0.0p+0f" "0x0.0p+0f")) - (t - (let* ((bits (ldb (byte 32 0) (kernel:single-float-bits val))) - (sign (ldb (byte 1 31) bits)) - (exp-bits (ldb (byte 8 23) bits)) - (mantissa (ldb (byte 23 0) bits)) - ;; Print lower-case hex digits. - (*print-case* :downcase)) - (if (zerop exp-bits) - ;; Subnormal: Leading digit 0, exponent fixed at -126 - (format nil "~A0x0.~6,'0Xp-126f" - (if (= sign 1) "-" "") - (ash mantissa 1)) ; Align 23 bits to 24 bits (6 hex digits) - ;; Normalized: Leading digit 1, exponent bias 127 - (format nil "~A0x1.~6,'0Xp~Af" - (if (= sign 1) "-" "") - (ash mantissa 1) ; Align 23 bits to 24 bits (6 hex digits) - (- exp-bits 127))))))) - -(defun print-hex-double-float (val) - "Prints a double-float in C-style hex format." - (cond ((float-nan-p val) - "nan") - ((float-infinity-p val) - (if (plusp val) "inf" "-inf")) - ((zerop val) - (if (eql val -0.0d0) - "-0x0.0p+0" "0x0.0p+0")) - (t - (multiple-value-bind (hi-bits lo-bits) - (kernel:double-float-bits val) - (let* ((hi (ldb (byte 32 0) hi-bits)) - (lo (ldb (byte 32 0) lo-bits)) - (sign (ldb (byte 1 31) hi)) - (exp-bits (ldb (byte 11 20) hi)) - ;; Combine 20 bits from high word and 32 bits from low word - (mantissa (logior (ash (ldb (byte 20 0) hi) 32) - lo)) - ;; Print lower-case hex digits. - (*print-case* :downcase)) - (if (zerop exp-bits) - ;; Subnormal: Leading digit 0, exponent fixed at -1022 - (format nil "~A0x0.~13,'0Xp-1022" - (if (= sign 1) "-" "") - mantissa) - ;; Normalized: Leading digit 1, exponent bias 1023 - (format nil "~A0x1.~13,'0Xp~A" - (if (= sign 1) "-" "") - mantissa ; 52 bits fits 13 hex digits perfectly - (- exp-bits 1023)))))))) +;;;; C-style hex float printer and parser -;;; PRINT-HEX-FLOAT -- Public +;;; FLOAT-TO-HEX-STRING -- Public ;;; ;;; Return a string representing a single and double-floats in C-style ;;; hex format. -(defun print-hex-float (float) - "Convert FLOAT to C-style hex string. Infinities are printed as \"-inf\" - and \"inf\". NaN is printed as \"nan\"." +(defun float-to-hex-string (val &optional at-p) + "Prints a single or double float in bit-perfect C-style hex. + If AT-P is true, prepends '+' for non-negative finite values." + (cond ((ext:float-nan-p val) "nan") + ((ext:float-infinity-p val) + (if (plusp val) (if at-p "+inf" "inf") "-inf")) + (t + (multiple-value-bind (sign exp-bits mantissa bias precision suffix) + (typecase val + (single-float + (let ((bits (ldb (byte 32 0) (kernel:single-float-bits val)))) + (values (ldb (byte 1 31) bits) + (ldb (byte 8 23) bits) + (ash (ldb (byte 23 0) bits) 1) ; Align 23 to 6 hex digits + 127 6 "f"))) + (double-float + (multiple-value-bind (hi lo) (kernel:double-float-bits val) + (values (ldb (byte 1 31) hi) + (ldb (byte 11 20) hi) + (logior (ash (ldb (byte 20 0) hi) 32) (ldb (byte 32 0) lo)) + 1023 13 ""))) + (t (error "Unsupported float type: ~S" (type-of val)))) + + (let ((sign-str (cond ((= sign 1) "-") + (at-p "+") + (t "")))) + (if (and (zerop exp-bits) (zerop mantissa)) + (format nil "~A0x0.0p+0~A" sign-str suffix) + (format nil "~A0x~A.~V,'0Xp~A~A" + sign-str + (if (zerop exp-bits) "0" "1") + precision + mantissa + (if (zerop exp-bits) (1+ (- bias)) (- exp-bits bias)) + suffix))))))) + +;;; WRITE-HEX-FLOAT -- Public +;;; +;;; Writes a float number in C-style hex format to the given stream. +(defun write-hex-float (float &optional (stream *standard-output*)) + "Convert FLOAT to C-style hex string and write it to STREAM. + Infinities are printed as \"-inf\" and \"inf\". NaN is printed as + \"nan\"." (declare (float float)) - (etypecase float - (single-float (print-hex-single-float float)) - (double-float (print-hex-double-float float)))) + (write-string (float-to-hex-string float) + stream)) ;;; FORMAT-HEX-FLOAT -- Public ;;; ;;; Function that can be used in a FORMAT ~/ (defun format-hex-float (stream arg colon-p at-sign-p &optional width) "Formatter for ~/ext:format-hex-float/. - @ forces sign (+/-). Colon modifier is ignored as per request." + Uses AT-SIGN-P (@) to force the sign. COLON-P (:) is currently ignored." (declare (ignore width colon-p)) - (let ((str (if (typep arg 'single-float) - (print-hex-single-float arg) - (print-hex-double-float arg)))) - ;; Prepend '+' if @ is used and number isn't negative or special - (when (and at-sign-p - (not (ext:float-nan-p arg)) - (not (ext:float-infinity-p arg)) - (not (char= (char str 0) #\-))) - (write-char #\+ stream)) - (write-string str stream))) + (write-string (float-to-hex-string arg at-sign-p) + stream)) -;;; PARSE-HEX-FLOAT -- Public -;;; -;;; Parse a C-style float hex strings. Always returns a double-float. -;;; Error-checking is enabled for malformed strings. (define-condition hex-parse-error (parse-error) ((text :initarg :text :reader hex-parse-error-text) (message :initarg :message :reader hex-parse-error-message)) @@ -122,68 +91,14 @@ (format s "Hex float parse error in ~S: ~A" (hex-parse-error-text c) (hex-parse-error-message c))))) -#+nil -(defun parse-hex-float (str) - "Parses hex floats using scale-float for the exponent. Strictly hex-literal only." - (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) - (string-downcase str))) - (len (length str))) - (when (zerop len) - (error 'hex-parse-error :text str :message "Empty string")) - - (let* ((ends-with-f (and (> len 1) - (char= (char str (1- len)) #\f))) - (effective-len (if ends-with-f - (1- len) len)) - (prototype (if ends-with-f - 1.0f0 1.0d0)) - (has-sign (or (char= (char str 0) #\-) - (char= (char str 0) #\+))) - (sign (if (and has-sign - (char= (char str 0) #\-)) - -1 1)) - (start (if has-sign 1 0))) - - (unless (and (<= (+ start 2) effective-len) - (string= str "0x" :start1 start :end1 (+ start 2))) - (error 'hex-parse-error :text str :message "Missing '0x' prefix")) - - (let ((p-pos (position #\p str :start start :end effective-len))) - (unless p-pos - (error 'hex-parse-error :text str :message "Missing exponent 'p'")) - - (let* ((sig-start (+ start 2)) - (dot-pos (position #\. str :start sig-start :end p-pos)) - (exp-start (1+ p-pos)) - ;; Leading hex: digits before the dot - (leading-str (subseq str sig-start (or dot-pos p-pos))) - ;; Trailing hex: digits after the dot - (trailing-str (if dot-pos (subseq str (1+ dot-pos) p-pos) "")) - (has-digits (or (plusp (length leading-str)) - (plusp (length trailing-str))))) - - (unless has-digits - (error 'hex-parse-error :text str :message "No hex digits in significand")) - - (handler-case - (let* ((leading-int (if (string= leading-str "") 0 - (parse-integer leading-str :radix 16))) - (trailing-len (length trailing-str)) - (trailing-int (if (string= trailing-str "") 0 - (parse-integer trailing-str :radix 16))) - ;; Calculate the significand as a float: leading + (trailing / 16^len) - (significand (float (+ leading-int - (/ trailing-int (expt 16 trailing-len))) - prototype)) - ;; The exponent after 'p' - (raw-exponent (parse-integer str :start exp-start :end effective-len))) - ;; Use scale-float to apply the binary exponent efficiently - (* sign (scale-float significand raw-exponent))) - (error (c) - (error 'hex-parse-error :text str :message (format nil "~A" c))))))))) - +;;; PARSE-HEX-FLOAT-FROM-STREAM -- Public +;;; +;;; Parse a C-style float hex string from a stream. Invalid formats +;;; signal an error. A single-float or double-float may be returned. (defun parse-hex-float-from-stream (stream) - "Reads hex float from stream using double-float accumulation and a 6-character exponent buffer." + "Reads a C-style hex float number from STREAM. A single-float or + double-float number is returned. A HEX-PARSE-ERROR is signaled for + an invalid format." (let* ((sign 1.0d0) (char (peek-char t stream))) ; Skip whitespace @@ -251,6 +166,15 @@ (float result 1.0f0) result))))))) -(defun parse-hex-float (str) - (with-input-from-string (s str) - (parse-hex-float-from-stream s))) +;;; PARSE-HEX-FLOAT -- Public +;;; +;;; Parse a C-style hex float number from either a string or a stream. +(defun parse-hex-float (obj) + "Parse a C-style hex float number from OBJ which is either a string or a stream." + (declare (type (or string stream) obj)) + (etypecase obj + (string + (with-input-from-string (s obj) + (parse-hex-float-from-stream s))) + (stream + (parse-hex-float-from-stream obj)))) ===================================== tests/extensions.lisp ===================================== @@ -21,34 +21,45 @@ (:tag :precision) ;; Double Precision (-1022 Cliff) - (assert-equal #x0010000000000000 (get-double-bits (ext:parse-hex-float "0x1.0000000000000p-1022"))) - (assert-equal #x000fffffffffffff (get-double-bits (ext:parse-hex-float "0x0.fffffffffffffp-1022"))) - (assert-equal #x001f0195cb356b8f (get-double-bits (ext:parse-hex-float "0x1.f0195cb356b8fp-1022"))) + (assert-equal #x0010000000000000 + (get-double-bits (ext:parse-hex-float "0x1.0000000000000p-1022"))) + (assert-equal #x000fffffffffffff + (get-double-bits (ext:parse-hex-float "0x0.fffffffffffffp-1022"))) + (assert-equal #x001f0195cb356b8f + (get-double-bits (ext:parse-hex-float "0x1.f0195cb356b8fp-1022"))) ;; Single Precision (-126 Cliff) - (assert-equal #x00800000 (get-single-bits (ext:parse-hex-float "0x1.000000p-126f"))) - (assert-equal #x00400000 (get-single-bits (ext:parse-hex-float "0x0.800000p-126f"))) - (assert-equal #x7f7fffff (get-single-bits (ext:parse-hex-float "0x1.fffffep+127f")))) + (assert-equal #x00800000 + (get-single-bits (ext:parse-hex-float "0x1.000000p-126f"))) + (assert-equal #x00400000 + (get-single-bits (ext:parse-hex-float "0x0.800000p-126f"))) + (assert-equal #x7f7fffff + (get-single-bits (ext:parse-hex-float "0x1.fffffep+127f")))) (define-test test-negative-zero (:tag :edge-cases) - (assert-equal #x8000000000000000 (get-double-bits (ext:parse-hex-float "-0x0.0p+0"))) - (assert-equal #x80000000 (get-single-bits (ext:parse-hex-float "-0x0.0p+0f"))) - (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f") 'single-float))) + (assert-equal #x8000000000000000 + (get-double-bits (ext:parse-hex-float "-0x0.0p+0"))) + (assert-equal #x80000000 + (get-single-bits (ext:parse-hex-float "-0x0.0p+0f"))) + (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f") + 'single-float))) (define-test test-subnormal-boundaries (:tag :edge) ;; Test smallest single-float subnormal (let* ((val (kernel:make-single-float 1)) - (str (ext::print-hex-single-float val)) + (str (ext:float-to-hex-string val)) (parsed (ext:parse-hex-float str))) - (assert-equal (get-single-bits val) (get-single-bits parsed))) + (assert-equal (get-single-bits val) (get-single-bits parsed) + val str parsed)) ;; Test smallest double-float subnormal (let* ((val (kernel:make-double-float 0 1)) - (str (ext::print-hex-double-float val)) + (str (ext:float-to-hex-string val)) (parsed (ext:parse-hex-float str))) - (assert-equal (get-double-bits val) (get-double-bits parsed)))) + (assert-equal (get-double-bits val) (get-double-bits parsed) + val str parsed))) (define-test test-double-roundtrip (:tag :stress) @@ -58,9 +69,11 @@ (lo (random #x100000000)) (val (kernel:make-double-float hi lo))) (unless (or (ext:float-nan-p val) (ext:float-infinity-p val)) - (let* ((str (ext::print-hex-double-float val)) + (let* ((str (ext:float-to-hex-string val)) (parsed (ext:parse-hex-float str))) - (assert-equal (get-double-bits val) (get-double-bits parsed))))))) + (assert-equal (get-double-bits val) + (get-double-bits parsed) + val str parsed)))))) (define-test test-single-roundtrip (:tag :stress) @@ -69,6 +82,8 @@ (bits (if (logbitp 31 bits-raw) (- bits-raw #x100000000) bits-raw)) (val (kernel:make-single-float bits))) (unless (or (ext:float-nan-p val) (ext:float-infinity-p val)) - (let* ((str (concatenate 'string (ext::print-hex-single-float val) "f")) + (let* ((str (concatenate 'string (ext:float-to-hex-string val) "f")) (parsed (ext:parse-hex-float str))) - (assert-equal (get-single-bits val) (get-single-bits parsed))))))) + (assert-equal (get-single-bits val) + (get-single-bits parsed) + val str parsed)))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/71da2451e58a3fb02bc9a38... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/71da2451e58a3fb02bc9a38... You're receiving this email because of your account on gitlab.common-lisp.net.