GitLab

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.

@@ -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"))

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

Raymond Toy pushed to branch issue-474-print-parse-hex-floats at cmucl / cmucl

Commits:

3 changed files:

Changes:

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