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

Commits:

2 changed files:

Changes:

  • src/code/ext-code.lisp
    ... ... @@ -23,39 +23,53 @@
    23 23
    24 24 
     ;;; C-style hex float printer and parser
    25 25 
     (defun print-hex-single-float (val)
    26 
    -  "Prints a single-float in bit-perfect C-style hex using raw bits."
    27 
    -  (cond ((float-nan-p val) "nan")
    28 
    -        ((float-infinity-p val) (if (plusp val) "inf" "-inf"))
    29 
    -        ((zerop val) (if (eql val -0.0f0) "-0x0.0p+0" "0x0.0p+0"))
    26 
    +  "Prints a single-float in C-style hex format."
    27 
    +  (cond ((float-nan-p val)
    28 
    +	 "nan")
    29 
    +        ((float-infinity-p val)
    30 
    +	 (if (plusp val) "inf" "-inf"))
    31 
    +        ((zerop val)
    32 
    +	 (if (eql val -0.0f0)
    33 
    +	     "-0x0.0p+0f" "0x0.0p+0f"))
    30 34 
             (t
    31 35 
              (let* ((bits (ldb (byte 32 0) (kernel:single-float-bits val)))
    32 36 
                     (sign (ldb (byte 1 31) bits))
    33 37 
                     (exp-bits (ldb (byte 8 23) bits))
    34 
    -                (mantissa (ldb (byte 23 0) bits)))
    38 
    +                (mantissa (ldb (byte 23 0) bits))
    39 
    +		;; Print lower-case hex digits.
    40 
    +		(*print-case* :downcase))
    35 41 
                (if (zerop exp-bits)
    36 42 
                    ;; Subnormal: Leading digit 0, exponent fixed at -126
    37 
    -               (format nil "~A0x0.~6,'0Xp-126"
    43 
    +               (format nil "~A0x0.~6,'0Xp-126f"
    38 44 
                            (if (= sign 1) "-" "")
    39 45 
                            (ash mantissa 1)) ; Align 23 bits to 24 bits (6 hex digits)
    40 46 
                    ;; Normalized: Leading digit 1, exponent bias 127
    41 
    -               (format nil "~A0x1.~6,'0Xp~A"
    47 
    +               (format nil "~A0x1.~6,'0Xp~Af"
    42 48 
                            (if (= sign 1) "-" "")
    43 49 
                            (ash mantissa 1) ; Align 23 bits to 24 bits (6 hex digits)
    44 50 
                            (- exp-bits 127)))))))
    45 51
    46 52 
     (defun print-hex-double-float (val)
    47 
    -  "Prints a double-float in bit-perfect C-style hex using raw bits."
    48 
    -  (cond ((float-nan-p val) "nan")
    49 
    -        ((float-infinity-p val) (if (plusp val) "inf" "-inf"))
    50 
    -        ((zerop val) (if (eql val -0.0d0) "-0x0.0p+0" "0x0.0p+0"))
    53 
    +  "Prints a double-float in C-style hex format."
    54 
    +  (cond ((float-nan-p val)
    55 
    +	 "nan")
    56 
    +        ((float-infinity-p val)
    57 
    +	 (if (plusp val) "inf" "-inf"))
    58 
    +        ((zerop val)
    59 
    +	 (if (eql val -0.0d0)
    60 
    +	     "-0x0.0p+0" "0x0.0p+0"))
    51 61 
             (t
    52 
    -         (multiple-value-bind (hi-bits lo-bits) (kernel:double-float-bits val)
    62 
    +         (multiple-value-bind (hi-bits lo-bits)
    63 
    +	     (kernel:double-float-bits val)
    53 64 
                (let* ((hi (ldb (byte 32 0) hi-bits))
    54 65 
                       (lo (ldb (byte 32 0) lo-bits))
    55 66 
                       (sign (ldb (byte 1 31) hi))
    56 67 
                       (exp-bits (ldb (byte 11 20) hi))
    57 68 
                       ;; Combine 20 bits from high word and 32 bits from low word
    58 
    -                  (mantissa (logior (ash (ldb (byte 20 0) hi) 32) lo)))
    69 
    +                  (mantissa (logior (ash (ldb (byte 20 0) hi) 32)
    70 
    +				    lo))
    71 
    +		  ;; Print lower-case hex digits.
    72 
    +		  (*print-case* :downcase))
    59 73 
                  (if (zerop exp-bits)
    60 74 
                      ;; Subnormal: Leading digit 0, exponent fixed at -1022
    61 75 
                      (format nil "~A0x0.~13,'0Xp-1022"
    ... ... @@ -82,38 +96,52 @@
    82 96 
     ;;; FORMAT-HEX-FLOAT -- Public
    83 97 
     ;;;
    84 98 
     ;;; Function that can be used in a FORMAT ~/
    85 
    -(defun format-hex-float (stream val &optional colon-p at-p &rest params)
    86 
    -  "Format ~/ directive supporting @ (sign) modifier for single/double floats."
    87 
    -  (declare (ignore colon-p params))
    88 
    -  (write-string
    89 
    -   (typecase val
    90 
    -     (single-float (print-hex-single-float val at-p))
    91 
    -     (double-float (print-hex-double-float val at-p))
    92 
    -     (t (format nil "~A" val)))
    93 
    -   stream))
    99 
    +(defun format-hex-float (stream arg colon-p at-sign-p &optional width)
    100 
    +  "Formatter for ~/ext:format-hex-float/.
    101 
    +   @ forces sign (+/-). Colon modifier is ignored as per request."
    102 
    +  (declare (ignore width colon-p))
    103 
    +  (let ((str (if (typep arg 'single-float)
    104 
    +                 (print-hex-single-float arg)
    105 
    +                 (print-hex-double-float arg))))
    106 
    +    ;; Prepend '+' if @ is used and number isn't negative or special
    107 
    +    (when (and at-sign-p
    108 
    +               (not (ext:float-nan-p arg))
    109 
    +               (not (ext:float-infinity-p arg))
    110 
    +               (not (char= (char str 0) #\-)))
    111 
    +      (write-char #\+ stream))
    112 
    +    (write-string str stream)))
    94 113
    95 114 
     ;;; PARSE-HEX-FLOAT -- Public
    96 115 
     ;;;
    97 116 
     ;;; Parse a C-style float hex strings.  Always returns a double-float.
    98 117 
     ;;; Error-checking is enabled for malformed strings.
    99 
    -(define-condition hex-parse-error (error)
    118 
    +(define-condition hex-parse-error (parse-error)
    100 119 
       ((text :initarg :text :reader hex-parse-error-text)
    101 120 
        (message :initarg :message :reader hex-parse-error-message))
    102 121 
       (:report (lambda (c s)
    103 122 
                  (format s "Hex float parse error in ~S: ~A"
    104 123 
                          (hex-parse-error-text c) (hex-parse-error-message c)))))
    105 124
    125 
    +#+nil
    106 126 
     (defun parse-hex-float (str)
    107 127 
       "Parses hex floats using scale-float for the exponent. Strictly hex-literal only."
    108 
    -  (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str)))
    128 
    +  (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return)
    129 
    +			   (string-downcase str)))
    109 130 
              (len (length str)))
    110 
    -    (when (zerop len) (error 'hex-parse-error :text str :message "Empty string"))
    131 
    +    (when (zerop len)
    132 
    +      (error 'hex-parse-error :text str :message "Empty string"))
    111 133
    112 
    -    (let* ((ends-with-f (and (> len 1) (char= (char str (1- len)) #\f)))
    113 
    -           (effective-len (if ends-with-f (1- len) len))
    114 
    -           (prototype (if ends-with-f 1.0f0 1.0d0))
    115 
    -           (has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+)))
    116 
    -           (sign (if (and has-sign (char= (char str 0) #\-)) -1 1))
    134 
    +    (let* ((ends-with-f (and (> len 1)
    135 
    +			     (char= (char str (1- len)) #\f)))
    136 
    +           (effective-len (if ends-with-f
    137 
    +			      (1- len) len))
    138 
    +           (prototype (if ends-with-f
    139 
    +			  1.0f0 1.0d0))
    140 
    +           (has-sign (or (char= (char str 0) #\-)
    141 
    +			 (char= (char str 0) #\+)))
    142 
    +           (sign (if (and has-sign
    143 
    +			  (char= (char str 0) #\-))
    144 
    +		     -1 1))
    117 145 
                (start (if has-sign 1 0)))
    118 146
    119 147 
           (unless (and (<= (+ start 2) effective-len)
    ... ... @@ -121,7 +149,8 @@
    121 149 
             (error 'hex-parse-error :text str :message "Missing '0x' prefix"))
    122 150
    123 151 
           (let ((p-pos (position #\p str :start start :end effective-len)))
    124 
    -        (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'"))
    152 
    +        (unless p-pos
    153 
    +	  (error 'hex-parse-error :text str :message "Missing exponent 'p'"))
    125 154
    126 155 
             (let* ((sig-start (+ start 2))
    127 156 
                    (dot-pos (position #\. str :start sig-start :end p-pos))
    ... ... @@ -130,7 +159,8 @@
    130 159 
                    (leading-str (subseq str sig-start (or dot-pos p-pos)))
    131 160 
                    ;; Trailing hex: digits after the dot
    132 161 
                    (trailing-str (if dot-pos (subseq str (1+ dot-pos) p-pos) ""))
    133 
    -               (has-digits (or (plusp (length leading-str)) (plusp (length trailing-str)))))
    162 
    +               (has-digits (or (plusp (length leading-str))
    163 
    +			       (plusp (length trailing-str)))))
    134 164
    135 165 
               (unless has-digits
    136 166 
                 (error 'hex-parse-error :text str :message "No hex digits in significand"))
    ... ... @@ -149,4 +179,78 @@
    149 179 
                          (raw-exponent (parse-integer str :start exp-start :end effective-len)))
    150 180 
                     ;; Use scale-float to apply the binary exponent efficiently
    151 181 
                     (* sign (scale-float significand raw-exponent)))
    152 
    -            (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c)))))))))
    182 
    +            (error (c)
    183 
    +	      (error 'hex-parse-error :text str :message (format nil "~A" c)))))))))
    184 
    +
    185 
    +(defun parse-hex-float-from-stream (stream)
    186 
    +  "Reads hex float from stream using double-float accumulation and a 6-character exponent buffer."
    187 
    +  (let* ((sign 1.0d0)
    188 
    +         (char (peek-char t stream))) ; Skip whitespace
    189 
    +
    190 
    +    ;; 1. Handle Sign
    191 
    +    (when (member char '(#\+ #\-))
    192 
    +      (when (char= (read-char stream) #\-) (setf sign -1.0d0))
    193 
    +      (setf char (peek-char nil stream)))
    194 
    +
    195 
    +    ;; 2. Verify '0x' Prefix
    196 
    +    (unless (and (char-equal (read-char stream) #\0)
    197 
    +                 (char-equal (read-char stream) #\x))
    198 
    +      (error 'hex-parse-error :text "Stream" :message "Missing '0x' prefix"))
    199 
    +
    200 
    +    ;; 3. Read Significand
    201 
    +    (let ((val 0.0d0)
    202 
    +          (digits-read 0))
    203 
    +      ;; Integer part loop
    204 
    +      (loop for c = (peek-char nil stream nil nil)
    205 
    +            for digit = (and c (digit-char-p c 16))
    206 
    +            while digit
    207 
    +            do (read-char stream)
    208 
    +               (setf val (+ (* val 16.0d0) digit))
    209 
    +               (incf digits-read))
    210 
    +
    211 
    +      ;; Fractional part loop
    212 
    +      (when (eql (peek-char nil stream nil nil) #\.)
    213 
    +        (read-char stream) ; Consume #\.
    214 
    +        (loop with weight = (/ 1.0d0 16.0d0)
    215 
    +              for c = (peek-char nil stream nil nil)
    216 
    +              for digit = (and c (digit-char-p c 16))
    217 
    +              while digit
    218 
    +              do (read-char stream)
    219 
    +                 (setf val (+ val (* digit weight)))
    220 
    +                 (setf weight (/ weight 16.0d0))
    221 
    +                 (incf digits-read)))
    222 
    +
    223 
    +      (unless (plusp digits-read)
    224 
    +        (error 'hex-parse-error :text "Stream" :message "No hex digits in significand"))
    225 
    +
    226 
    +      ;; 4. Handle Exponent 'p'
    227 
    +      (let ((p-char (read-char stream nil)))
    228 
    +        (unless (and p-char (char-equal p-char #\p))
    229 
    +          (error 'hex-parse-error :text "Stream" :message "Missing exponent 'p'"))
    230 
    +
    231 
    +        ;; Size 6 handles sign + 3-4 digits + buffer
    232 
    +        (let ((exp-str (make-array 6 :element-type 'character
    233 
    +                                     :fill-pointer 0
    234 
    +                                     :adjustable t)))
    235 
    +          (loop for c = (peek-char nil stream nil nil)
    236 
    +                while (and c (find c "+-0123456789"))
    237 
    +                do (vector-push-extend (read-char stream) exp-str))
    238 
    +
    239 
    +          (when (zerop (length exp-str))
    240 
    +            (error 'hex-parse-error :text "Stream" :message "Invalid or missing exponent"))
    241 
    +
    242 
    +          (let* ((raw-exp (parse-integer exp-str))
    243 
    +                 (suffix (peek-char nil stream nil #\Space))
    244 
    +                 (is-single (char-equal suffix #\f))
    245 
    +                 ;; Final Construction
    246 
    +                 (result (* sign (scale-float val raw-exp))))
    247 
    +
    248 
    +            (when is-single (read-char stream)) ; Consume 'f'
    249 
    +
    250 
    +            (if is-single
    251 
    +                (float result 1.0f0)
    252 
    +                result)))))))
    253 
    +
    254 
    +(defun parse-hex-float (str)
    255 
    +  (with-input-from-string (s str)
    256 
    +    (parse-hex-float-from-stream s)))

  • tests/extensions.lisp
    ... ... @@ -37,6 +37,19 @@
    37 37 
       (assert-equal #x80000000         (get-single-bits (ext:parse-hex-float "-0x0.0p+0f")))
    38 38 
       (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f") 'single-float)))
    39 39
    40 
    +(define-test test-subnormal-boundaries
    41 
    +  (:tag :edge)
    42 
    +  ;; Test smallest single-float subnormal
    43 
    +  (let* ((val (kernel:make-single-float 1))
    44 
    +         (str (ext::print-hex-single-float val))
    45 
    +         (parsed (ext:parse-hex-float str)))
    46 
    +    (assert-equal (get-single-bits val) (get-single-bits parsed)))
    47 
    +  ;; Test smallest double-float subnormal
    48 
    +  (let* ((val (kernel:make-double-float 0 1))
    49 
    +         (str (ext::print-hex-double-float val))
    50 
    +         (parsed (ext:parse-hex-float str)))
    51 
    +    (assert-equal (get-double-bits val) (get-double-bits parsed))))
    52 
    +
    40 53 
     (define-test test-double-roundtrip
    41 54 
       (:tag :stress)
    42 55 
       (loop repeat 10000 do

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help Notification message regarding https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b32b761d8abf7d62fb04c3770a13fddff8444360...71da2451e58a3fb02bc9a386f25b227243042c30 at 1771866877