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

Commits:

2 changed files:

Changes:

  • src/code/ext-code.lisp
    ... ... @@ -22,94 +22,50 @@
    22 22
    23 23
    24 24 
     ;;; C-style hex float printer and parser
    25 
    -(defun print-hex-single-float (val &optional force-sign)
    26 
    -  (let* ((bits (kernel:single-float-bits val))
    27 
    -         (u-bits (ldb (byte 32 0) bits))
    28 
    -         (sign-bit (ldb (byte 1 31) u-bits))
    29 
    -         (biased-exp (ldb (byte 8 23) u-bits))
    30 
    -         (fraction (ldb (byte 23 0) u-bits))
    31 
    -         (sign-str (cond ((= sign-bit 1) "-") (force-sign "+") (t ""))))
    32 
    -    (cond
    33 
    -      ((= biased-exp 255) (if (zerop fraction) (format nil "~Ainf" sign-str) "nan"))
    34 
    -      ((and (zerop biased-exp) (zerop fraction)) (format nil "~A0x0.000000p+0" sign-str))
    35 
    -      ((zerop biased-exp) (format nil "~A0x0.~6,'0xp-126" sign-str fraction))
    36 
    -      (t (let ((exponent (- biased-exp 127)))
    37 
    -           (format nil "~A0x1.~6,'0xp~:[~;+~]~D" sign-str fraction (not (minusp exponent)) exponent))))))
    38 
    -
    39 
    -(defun print-hex-double-float (val &optional force-sign)
    40 
    -  (multiple-value-bind (hi lo) (kernel:double-float-bits val)
    41 
    -    (let* ((u-hi (ldb (byte 32 0) hi))
    42 
    -           (sign-bit (ldb (byte 1 31) u-hi))
    43 
    -           (biased-exp (ldb (byte 11 20) u-hi))
    44 
    -           (fraction (logior (ash (ldb (byte 20 0) u-hi) 32) lo))
    45 
    -           (sign-str (cond ((= sign-bit 1) "-") (force-sign "+") (t ""))))
    46 
    -      (cond
    47 
    -        ((= biased-exp #x7FF) (if (zerop fraction) (format nil "~Ainf" sign-str) "nan"))
    48 
    -        ((and (zerop biased-exp) (zerop fraction)) (format nil "~A0x0.0000000000000p+0" sign-str))
    49 
    -        ((zerop biased-exp) (format nil "~A0x0.~13,'0xp-1022" sign-str fraction))
    50 
    -        (t (let ((exponent (- biased-exp 1023)))
    51 
    -             (format nil "~A0x1.~13,'0xp~:[~;+~]~D" sign-str fraction (not (minusp exponent)) exponent)))))))
    52 
    -
    53 
    -#+nil
    54 
    -(defun print-hex-single-float (val &optional force-sign)
    55 
    -  "Converts a single-float to a C-style hex string (32-bit)."
    56 
    -  (let* ((bits (kernel:single-float-bits val))
    57 
    -         (u-bits (ldb (byte 32 0) bits))
    58 
    -         (sign-bit (ldb (byte 1 31) u-bits))
    59 
    -         (biased-exp (ldb (byte 8 23) u-bits))
    60 
    -         (fraction (ldb (byte 23 0) u-bits))
    61 
    -         (sign-str (cond ((= sign-bit 1)
    62 
    -                          "-")
    63 
    -                         (force-sign
    64 
    -                          "+")
    65 
    -                         (t
    66 
    -                          ""))))
    67 
    -    (cond
    68 
    -      ((= biased-exp 255)
    69 
    -       (if (zerop fraction)
    70 
    -           (format nil "~Ainf" sign-str)
    71 
    -           "nan"))
    72 
    -      ((and (zerop biased-exp)
    73 
    -            (zerop fraction))
    74 
    -       (format nil "~A0x0.000000p+0" sign-str))
    75 
    -      ((zerop biased-exp)
    76 
    -       (let ((*print-case* :downcase))
    77 
    -	 (format nil "~A0x0.~6,'0xp-126" sign-str fraction)))
    78 
    -      (t
    79 
    -       (let ((*print-case* :downcase)
    80 
    -	     (exponent (- biased-exp 127)))
    81 
    -         (format nil "~A0x1.~6,'0xp~:[~;+~]~D"
    82 
    -                 sign-str fraction (not (minusp exponent)) exponent))))))
    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"))
    30 
    +        (t
    31 
    +         (let* ((bits (ldb (byte 32 0) (kernel:single-float-bits val)))
    32 
    +                (sign (ldb (byte 1 31) bits))
    33 
    +                (exp-bits (ldb (byte 8 23) bits))
    34 
    +                (mantissa (ldb (byte 23 0) bits)))
    35 
    +           (if (zerop exp-bits)
    36 
    +               ;; Subnormal: Leading digit 0, exponent fixed at -126
    37 
    +               (format nil "~A0x0.~6,'0Xp-126"
    38 
    +                       (if (= sign 1) "-" "")
    39 
    +                       (ash mantissa 1)) ; Align 23 bits to 24 bits (6 hex digits)
    40 
    +               ;; Normalized: Leading digit 1, exponent bias 127
    41 
    +               (format nil "~A0x1.~6,'0Xp~A"
    42 
    +                       (if (= sign 1) "-" "")
    43 
    +                       (ash mantissa 1) ; Align 23 bits to 24 bits (6 hex digits)
    44 
    +                       (- exp-bits 127)))))))
    83 45
    84 
    -#+nil
    85 
    -(defun print-hex-double-float (val &optional force-sign)
    86 
    -  "Converts a double-float to a C-style hex string (64-bit)."
    87 
    -  (multiple-value-bind (hi lo)
    88 
    -      (kernel:double-float-bits val)
    89 
    -    (let* ((u-hi (ldb (byte 32 0) hi))
    90 
    -           (sign-bit (ldb (byte 1 31) u-hi))
    91 
    -           (biased-exp (ldb (byte 11 20) u-hi))
    92 
    -           (fraction (logior (ash (ldb (byte 20 0) u-hi) 32) lo))
    93 
    -           (sign-str (cond ((= sign-bit 1)
    94 
    -                            "-")
    95 
    -                           (force-sign "+")
    96 
    -                           (t ""))))
    97 
    -      (cond
    98 
    -        ((= biased-exp #x7FF)
    99 
    -         (if (zerop fraction)
    100 
    -             (format nil "~Ainf" sign-str)
    101 
    -             "nan"))
    102 
    -        ((and (zerop biased-exp)
    103 
    -              (zerop fraction))
    104 
    -         (format nil "~A0x0.0000000000000p+0" sign-str))
    105 
    -        ((zerop biased-exp)
    106 
    -	 (let ((*print-case* :downcase))
    107 
    -           (format nil "~A0x0.~13,'0xp-1022" sign-str fraction)))
    46 
    +(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"))
    108 51 
             (t
    109 
    -         (let ((*print-case* :downcase)
    110 
    -	       (exponent (- biased-exp 1023)))
    111 
    -           (format nil "~A0x1.~13,'0xp~:[~;+~]~D"
    112 
    -                   sign-str fraction (not (minusp exponent)) exponent)))))))
    52 
    +         (multiple-value-bind (hi-bits lo-bits) (kernel:double-float-bits val)
    53 
    +           (let* ((hi (ldb (byte 32 0) hi-bits))
    54 
    +                  (lo (ldb (byte 32 0) lo-bits))
    55 
    +                  (sign (ldb (byte 1 31) hi))
    56 
    +                  (exp-bits (ldb (byte 11 20) hi))
    57 
    +                  ;; Combine 20 bits from high word and 32 bits from low word
    58 
    +                  (mantissa (logior (ash (ldb (byte 20 0) hi) 32) lo)))
    59 
    +             (if (zerop exp-bits)
    60 
    +                 ;; Subnormal: Leading digit 0, exponent fixed at -1022
    61 
    +                 (format nil "~A0x0.~13,'0Xp-1022"
    62 
    +                         (if (= sign 1) "-" "")
    63 
    +                         mantissa)
    64 
    +                 ;; Normalized: Leading digit 1, exponent bias 1023
    65 
    +                 (format nil "~A0x1.~13,'0Xp~A"
    66 
    +                         (if (= sign 1) "-" "")
    67 
    +                         mantissa ; 52 bits fits 13 hex digits perfectly
    68 
    +                         (- exp-bits 1023))))))))
    113 69
    114 70 
     ;;; PRINT-HEX-FLOAT  -- Public
    115 71 
     ;;;
    ... ... @@ -147,104 +103,50 @@
    147 103 
                  (format s "Hex float parse error in ~S: ~A"
    148 104 
                          (hex-parse-error-text c) (hex-parse-error-message c)))))
    149 105
    150 
    -#+nil
    151 106 
     (defun parse-hex-float (str)
    152 
    -  "Parses hex strings by converting the significand to a float, then scaling."
    107 
    +  "Parses hex floats using scale-float for the exponent. Strictly hex-literal only."
    153 108 
       (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str)))
    154 109 
              (len (length str)))
    155 110 
         (when (zerop len) (error 'hex-parse-error :text str :message "Empty string"))
    156 
    -    (let* ((has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+)))
    111 
    +
    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) #\+)))
    157 116 
                (sign (if (and has-sign (char= (char str 0) #\-)) -1 1))
    158 117 
                (start (if has-sign 1 0)))
    159 
    -      (cond
    160 
    -        ((string= str "inf" :start1 start)
    161 
    -         (if (= sign 1) double-float-positive-infinity double-float-negative-infinity))
    162 
    -        ((string= str "nan" :start1 start) :nan)
    163 
    -        (t
    164 
    -         (unless (and (<= (+ start 2) len) (string= str "0x" :start1 start :end1 (+ start 2)))
    165 
    -           (error 'hex-parse-error :text str :message "Missing '0x' prefix"))
    166 
    -         (let ((p-pos (position #\p str :start start)))
    167 
    -           (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'"))
    168 
    -
    169 
    -           ;; Check for internal whitespace
    170 
    -           (loop for i from start below len
    171 
    -                 when (member (char str i) '(#\Space #\Tab #\Newline #\Return))
    172 
    -                 do (error 'hex-parse-error :text str :message "Internal whitespace detected"))
    173 
    -
    174 
    -           (let* ((sig-start (+ start 2))
    175 
    -                  (dot-pos (position #\. str :start sig-start :end p-pos))
    176 
    -                  (exp-start (1+ p-pos)))
    177 
    -
    178 
    -             (handler-case
    179 
    -                 (let* ((frac-hex-len (if dot-pos (- p-pos (1+ dot-pos)) 0))
    180 
    -                        ;; 1. Combine leading and trailing into one large integer
    181 
    -                        (significand-int
    182 
    -                         (if (null dot-pos)
    183 
    -                             (parse-integer str :start sig-start :end p-pos :radix 16)
    184 
    -                             (let ((leading (if (= sig-start dot-pos) 0
    185 
    -                                                (parse-integer str :start sig-start :end dot-pos :radix 16)))
    186 
    -                                   (trailing (if (= (1+ dot-pos) p-pos) 0
    187 
    -                                                 (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16))))
    188 
    -                               (+ (ash leading (* 4 frac-hex-len)) trailing))))
    189 
    -                        ;; 2. Parse decimal exponent
    190 
    -                        (raw-exponent (parse-integer str :start exp-start :end len))
    191 
    -                        ;; 3. Handle the "cliff" logic for 0x0. vs 0x1.
    192 
    -                        (starts-with-zero (char= (char str sig-start) #\0))
    193 
    -                        (actual-exponent (if (and starts-with-zero (not (zerop significand-int)))
    194 
    -                                             -1022
    195 
    -                                             raw-exponent)))
    196 
    -
    197 
    -                   ;; 4. Convert integer to float and scale by (exponent - fractional bits)
    198 
    -                   ;; scale-float is bit-exact for binary scaling.
    199 
    -                   (* sign (scale-float (float significand-int 1.0d0)
    200 
    -                                        (- actual-exponent (* 4 frac-hex-len)))))
    201 
    -               (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c)))))))))))
    118 
    +
    119 
    +      (unless (and (<= (+ start 2) effective-len)
    120 
    +                   (string= str "0x" :start1 start :end1 (+ start 2)))
    121 
    +        (error 'hex-parse-error :text str :message "Missing '0x' prefix"))
    122 
    +
    123 
    +      (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'"))
    202 125
    203 
    -(defun parse-hex-float (str)
    204 
    -  "Parses C-style hex strings via an exact rational. Strictly validates digit presence."
    205 
    -  (let* ((str (string-trim '(#\Space #\Tab #\Newline #\Return) (string-downcase str)))
    206 
    -         (len (length str)))
    207 
    -    (when (zerop len) (error 'hex-parse-error :text str :message "Empty string"))
    208 
    -    (let* ((has-sign (or (char= (char str 0) #\-) (char= (char str 0) #\+)))
    209 
    -           (sign (if (and has-sign (char= (char str 0) #\-)) -1 1))
    210 
    -           (start (if has-sign 1 0)))
    211 
    -      (cond
    212 
    -        ((string= str "inf" :start1 start)
    213 
    -         (if (= sign 1) double-float-positive-infinity double-float-negative-infinity))
    214 
    -        ((string= str "nan" :start1 start) :nan)
    215 
    -        (t
    216 
    -         (unless (and (<= (+ start 2) len) (string= str "0x" :start1 start :end1 (+ start 2)))
    217 
    -           (error 'hex-parse-error :text str :message "Missing '0x' prefix"))
    218 
    -         (let ((p-pos (position #\p str :start start)))
    219 
    -           (unless p-pos (error 'hex-parse-error :text str :message "Missing exponent 'p'"))
    220 
    -
    221 
    -           (loop for i from start below len
    222 
    -                 when (member (char str i) '(#\Space #\Tab #\Newline #\Return))
    223 
    -                 do (error 'hex-parse-error :text str :message "Internal whitespace detected"))
    126 
    +        (let* ((sig-start (+ start 2))
    127 
    +               (dot-pos (position #\. str :start sig-start :end p-pos))
    128 
    +               (exp-start (1+ p-pos))
    129 
    +               ;; Leading hex: digits before the dot
    130 
    +               (leading-str (subseq str sig-start (or dot-pos p-pos)))
    131 
    +               ;; Trailing hex: digits after the dot
    132 
    +               (trailing-str (if dot-pos (subseq str (1+ dot-pos) p-pos) ""))
    133 
    +               (has-digits (or (plusp (length leading-str)) (plusp (length trailing-str)))))
    134 
    +
    135 
    +          (unless has-digits
    136 
    +            (error 'hex-parse-error :text str :message "No hex digits in significand"))
    224 137
    225 
    -           (let* ((sig-start (+ start 2))
    226 
    -                  (dot-pos (position #\. str :start sig-start :end p-pos))
    227 
    -                  (exp-start (1+ p-pos))
    228 
    -                  ;; Strict Validation: Ensure there is at least one digit in the significand
    229 
    -                  (has-leading (and (not (eql sig-start dot-pos)) (not (eql sig-start p-pos))))
    230 
    -                  (has-trailing (and dot-pos (not (eql (1+ dot-pos) p-pos)))))
    231 
    -
    232 
    -             (unless (or has-leading has-trailing)
    233 
    -               (error 'hex-parse-error :text str :message "No hex digits in significand"))
    234 
    -
    235 
    -             (handler-case
    236 
    -                 (let* ((frac-hex-len (if dot-pos (- p-pos (1+ dot-pos)) 0))
    237 
    -                        (significand-int
    238 
    -                         (if (null dot-pos)
    239 
    -                             (parse-integer str :start sig-start :end p-pos :radix 16)
    240 
    -                             (let ((leading (if (not has-leading) 0
    241 
    -                                                (parse-integer str :start sig-start :end dot-pos :radix 16)))
    242 
    -                                   (trailing (if (not has-trailing) 0
    243 
    -                                                 (parse-integer str :start (1+ dot-pos) :end p-pos :radix 16))))
    244 
    -                               (+ (ash leading (* 4 frac-hex-len)) trailing))))
    245 
    -                        (raw-exponent (parse-integer str :start exp-start :end len))
    246 
    -                        ;; significand * 2^(exp - 4*frac_len)
    247 
    -                        (rational-val (* significand-int
    248 
    -                                         (expt 2 (- raw-exponent (* 4 frac-hex-len))))))
    249 
    -                   (* sign (float rational-val 1.0d0)))
    250 
    -               (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c)))))))))))
    138 
    +          (handler-case
    139 
    +              (let* ((leading-int (if (string= leading-str "") 0
    140 
    +                                      (parse-integer leading-str :radix 16)))
    141 
    +                     (trailing-len (length trailing-str))
    142 
    +                     (trailing-int (if (string= trailing-str "") 0
    143 
    +                                       (parse-integer trailing-str :radix 16)))
    144 
    +                     ;; Calculate the significand as a float: leading + (trailing / 16^len)
    145 
    +                     (significand (float (+ leading-int
    146 
    +                                            (/ trailing-int (expt 16 trailing-len)))
    147 
    +                                         prototype))
    148 
    +                     ;; The exponent after 'p'
    149 
    +                     (raw-exponent (parse-integer str :start exp-start :end effective-len)))
    150 
    +                ;; Use scale-float to apply the binary exponent efficiently
    151 
    +                (* sign (scale-float significand raw-exponent)))
    152 
    +            (error (c) (error 'hex-parse-error :text str :message (format nil "~A" c)))))))))

  • tests/extensions.lisp
    ... ... @@ -4,153 +4,58 @@
    4 4
    5 5 
     (in-package "EXTENSIONS-TESTS")
    6 6
    7 
    -#+nil
    8 
    -(defun test-invalid-strings ()
    9 
    -  (format t "Testing invalid strings...~%")
    10 
    -  (let ((invalid-cases '("" "1.0" "0x1.0" "0x1.0p" "0x1.zp+0" "0x.p+0" "0x1 .0p+0")))
    11 
    -    (dolist (case invalid-cases)
    12 
    -      (handler-case
    13 
    -          (progn (parse-hex-float case) (error "Failed to trap ~S" case))
    14 
    -        (hex-parse-error () (format t "  Caught expected error for: ~S~%" case)))))
    15 
    -  (format t "Invalid string tests passed.~%"))
    16 
    -
    17 
    -(define-test parse-hex.invalid-strings
    18 
    -  (dolist (case '("" "1.0" "0x1.0" "0x1.0p" "0x1.zp+0" "0x.p+0" "0x1 .0p+0"))
    19 
    -    (assert-error 'ext:hex-parse-error
    20 
    -		  (ext:parse-hex-float case)
    21 
    -		  case)))
    22 
    -
    23 
    -#+nil
    24 
    -(defun run-hex-float-tests (&key (iterations 20000))
    25 
    -  "Validates bit-consistency for double floats."
    26 
    -  (format t "Testing ~D random bit patterns (Double Precision)...~%" iterations)
    27 
    -  (loop repeat iterations do
    28 
    -    (let* ((hi-bits (random (expt 2 32)))
    29 
    -           (hi (if (logbitp 31 hi-bits)
    30 
    -                   (- hi-bits (expt 2 32))
    31 
    -                   hi-bits))
    32 
    -           (lo (random (expt 2 32)))
    33 
    -           (d-float (kernel:make-double-float hi lo))
    34 
    -           (d-str (print-hex-double-float d-float))
    35 
    -           (d-parsed (parse-hex-float d-str)))
    36 
    -      (cond
    37 
    -        ((eq d-parsed :nan)
    38 
    -         (assert (float-nan-p d-float)))
    39 
    -        (t
    40 
    -         (multiple-value-bind (n-hi n-lo)
    41 
    -             (kernel:double-float-bits d-parsed)
    42 
    -           (assert (and (= (ldb (byte 32 0) hi)
    43 
    -                           (ldb (byte 32 0) n-hi))
    44 
    -                        (= lo n-lo))))))))
    45 
    -  (format t "Bit verification passed.~%"))
    46 
    -
    47 
    -(define-test hex-parse-print-consistency
    48 
    -  (loop repeat 20000 do
    49 
    -        (let* ((hi-bits (random (expt 2 32)))
    50 
    -           (hi (if (logbitp 31 hi-bits)
    51 
    -                   (- hi-bits (expt 2 32))
    52 
    -                   hi-bits))
    53 
    -           (lo (random (expt 2 32)))
    54 
    -           (d-float (kernel:make-double-float hi lo))
    55 
    -           (d-str (ext:print-hex-float d-float))
    56 
    -           (d-parsed (ext:parse-hex-float d-str)))
    57 
    -      (cond
    58 
    -        ((eq d-parsed :nan)
    59 
    -         (assert-true (ext:float-nan-p d-float)
    60 
    -		      d-float d-parsed))
    61 
    -        (t
    62 
    -         (multiple-value-bind (n-hi n-lo)
    63 
    -             (kernel:double-float-bits d-parsed)
    64 
    -           (assert-true (= (ldb (byte 32 0) hi)
    65 
    -                           (ldb (byte 32 0) n-hi))
    66 
    -			hi n-hi)
    67 
    -	   (assert-true (= lo n-lo)
    68 
    -			lo n-lo)))))))
    69 
    -
    70 
    -
    71 
    -#+nil
    72 
    -(defun run-subnormal-stress-test ()
    73 
    -  (format t "Running subnormal stress tests...~%")
    74 
    -  (let* ((s-str "0x0.10534ec00dae8p-1022")
    75 
    -         (parsed (parse-hex-float s-str)))
    76 
    -    ;; Using assumed builtin float-denormalized-p
    77 
    -    (assert (float-denormalized-p parsed))
    78 
    -    (multiple-value-bind (hi lo) (kernel:double-float-bits parsed)
    79 
    -      (assert (= (logior (ash (ldb (byte 20 0) hi) 32) lo) #x10534ec00dae8))))
    80 
    -  (loop repeat 5000 do
    81 
    -    (let* ((lo (random (expt 2 32)))
    82 
    -           (hi (random (expt 2 20))) ; biased exponent is 0
    83 
    -           (val (kernel:make-double-float hi lo))
    84 
    -           (str (ext::print-hex-double-float val))
    85 
    -           (parsed (parse-hex-float str)))
    86 
    -      (unless (zerop val)
    87 
    -        (multiple-value-bind (new-hi new-lo) (kernel:double-float-bits parsed)
    88 
    -          (assert (and (= hi new-hi) (= lo new-lo)))))))
    89 
    -  (format t "Subnormal stress test passed.~%"))
    90 
    -
    91 
    -(define-test hex-parse-denormals.1
    92 
    -  (let* ((s-str "0x0.10534ec00dae8p-1022")
    93 
    -         (parsed (ext:parse-hex-float s-str)))
    94 
    -    (assert-true (ext:float-denormalized-p parsed))
    95 
    -    (multiple-value-bind (hi lo)
    96 
    -	(kernel:double-float-bits parsed)
    97 
    -      (assert-true (= (logior (ash (ldb (byte 20 0) hi) 32) lo)
    98 
    -		      #x10534ec00dae8)))))
    7 
    +(defun get-double-bits (val)
    8 
    +  (multiple-value-bind (hi lo) (kernel:double-float-bits val)
    9 
    +    (logior (ash (ldb (byte 32 0) hi) 32) (ldb (byte 32 0) lo))))
    10 
    +
    11 
    +(defun get-single-bits (val)
    12 
    +  (ldb (byte 32 0) (kernel:single-float-bits val)))
    13 
    +
    14 
    +(define-test test-hex-syntax
    15 
    +  (:tag :validation)
    16 
    +  (assert-error 'ext:hex-parse-error (ext:parse-hex-float "inf"))
    17 
    +  (assert-error 'ext:hex-parse-error (ext:parse-hex-float "0x.p+0"))
    18 
    +  (assert-error 'ext:hex-parse-error (ext:parse-hex-float "0x1.0p")))
    19 
    +
    20 
    +(define-test test-cliff-boundaries
    21 
    +  (:tag :precision)
    22 
    +  ;; Double Precision (-1022 Cliff)
    99 23
    100 
    -(define-test hex-parse-denormals.random
    101 
    -  (loop repeat 5000 do
    102 
    -    (let* ((lo (random (expt 2 32)))
    103 
    -           (hi (random (expt 2 20))) ; biased exponent is 0
    104 
    -           (val (kernel:make-double-float hi lo))
    105 
    -           (str (ext::print-hex-double-float val))
    106 
    -           (parsed (ext:parse-hex-float str)))
    107 
    -      (unless (zerop val)
    108 
    -        (multiple-value-bind (new-hi new-lo)
    109 
    -	    (kernel:double-float-bits parsed)
    110 
    -          (assert-true (and (= hi new-hi) (= lo new-lo))))))))
    111 
    -
    112 
    -#+nil
    113 
    -(defun run-cliff-tests ()
    114 
    -  "Tests precision around the smallest normalized and largest subnormal boundary."
    115 
    -  (format t "Running boundary (cliff) tests...~%")
    116 
    -  (let ((cases '(;; Smallest normalized number (2^-1022)
    117 
    -                 ("0x1.0000000000000p-1022" #x0010000000000000)
    118 
    -                 ;; Smallest normalized + 1 ULP
    119 
    -                 ("0x1.0000000000001p-1022" #x0010000000000001)
    120 
    -                 ;; Smallest normalized - 1 ULP (Largest subnormal)
    121 
    -                 ("0x0.fffffffffffffp-1022" #x000fffffffffffff)
    122 
    -                 ;; The user reported failing case
    123 
    -                 ("0x1.f0195cb356b8fp-1022" #x001f0195cb356b8f))))
    124 
    -    (dolist (test cases)
    125 
    -      (destructuring-bind (str expected-bits) test
    126 
    -        (let* ((parsed (parse-hex-float str))
    127 
    -               (actual-bits (multiple-value-bind (hi lo) (kernel:double-float-bits parsed)
    128 
    -                              (logior (ash (ldb (byte 32 0) hi) 32) lo))))
    129 
    -          (format t "  Testing ~A...~%" str)
    130 
    -          (unless (= actual-bits expected-bits)
    131 
    -            (error "Cliff Mismatch!~%Str: ~A~%Expected: ~16,'0X~%Actual:   ~16,'0X"
    132 
    -                   str expected-bits actual-bits))))))
    133 
    -  (format t "Cliff tests passed.~%"))
    134 
    -
    135 
    -;; Test precision around the smallest normalized and larges denormal boundary.
    136 
    -(define-test hex-parse-denormal-boundary
    137 
    -  (let ((cases '(;; Smallest normalized number (2^-1022)
    138 
    -                 ("0x1.0000000000000p-1022" #x0010000000000000)
    139 
    -                 ;; Smallest normalized + 1 ULP
    140 
    -                 ("0x1.0000000000001p-1022" #x0010000000000001)
    141 
    -                 ;; Smallest normalized - 1 ULP (Largest subnormal)
    142 
    -                 ("0x0.fffffffffffffp-1022" #x000fffffffffffff)
    143 
    -                 ;; The user reported failing case
    144 
    -                 ("0x1.f0195cb356b8fp-1022" #x001f0195cb356b8f)
    145 
    -		 ;; Failing case 1: 0x0.10534ec00dae8p-1022
    146 
    -                 ("0x0.10534ec00dae8p-1022" #x00010534ec00dae8)
    147 
    -                 ;; Failing case 2: 0x0.49df16729d954p-1022
    148 
    -                 ("0x0.49df16729d954p-1022" #x00049df16729d954))))
    149 
    -    (dolist (test cases)
    150 
    -      (destructuring-bind (str expected-bits) test
    151 
    -        (let* ((parsed (ext:parse-hex-float str))
    152 
    -               (actual-bits (multiple-value-bind (hi lo)
    153 
    -				(kernel:double-float-bits parsed)
    154 
    -                              (logior (ash (ldb (byte 32 0) hi) 32) lo))))
    155 
    -	  (assert-equal expected-bits actual-bits
    156 
    -			str))))))
    24 
    +  (assert-equal #x0010000000000000 (get-double-bits (ext:parse-hex-float "0x1.0000000000000p-1022")))
    25 
    +  (assert-equal #x000fffffffffffff (get-double-bits (ext:parse-hex-float "0x0.fffffffffffffp-1022")))
    26 
    +  (assert-equal #x001f0195cb356b8f (get-double-bits (ext:parse-hex-float "0x1.f0195cb356b8fp-1022")))
    27 
    +
    28 
    +  ;; Single Precision (-126 Cliff)
    29 
    +
    30 
    +  (assert-equal #x00800000 (get-single-bits (ext:parse-hex-float "0x1.000000p-126f")))
    31 
    +  (assert-equal #x00400000 (get-single-bits (ext:parse-hex-float "0x0.800000p-126f")))
    32 
    +  (assert-equal #x7f7fffff (get-single-bits (ext:parse-hex-float "0x1.fffffep+127f"))))
    33 
    +
    34 
    +(define-test test-negative-zero
    35 
    +  (:tag :edge-cases)
    36 
    +  (assert-equal #x8000000000000000 (get-double-bits (ext:parse-hex-float "-0x0.0p+0")))
    37 
    +  (assert-equal #x80000000         (get-single-bits (ext:parse-hex-float "-0x0.0p+0f")))
    38 
    +  (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f") 'single-float)))
    39 
    +
    40 
    +(define-test test-double-roundtrip
    41 
    +  (:tag :stress)
    42 
    +  (loop repeat 10000 do
    43 
    +    (let* ((hi-bits (random #x100000000))
    44 
    +           (hi (if (logbitp 31 hi-bits) (- hi-bits #x100000000) hi-bits))
    45 
    +           (lo (random #x100000000))
    46 
    +           (val (kernel:make-double-float hi lo)))
    47 
    +      (unless (or (ext:float-nan-p val) (ext:float-infinity-p val))
    48 
    +        (let* ((str (ext::print-hex-double-float val))
    49 
    +               (parsed (ext:parse-hex-float str)))
    50 
    +          (assert-equal (get-double-bits val) (get-double-bits parsed)))))))
    51 
    +
    52 
    +(define-test test-single-roundtrip
    53 
    +  (:tag :stress)
    54 
    +  (loop repeat 10000 do
    55 
    +    (let* ((bits-raw (random #x100000000))
    56 
    +           (bits (if (logbitp 31 bits-raw) (- bits-raw #x100000000) bits-raw))
    57 
    +           (val (kernel:make-single-float bits)))
    58 
    +      (unless (or (ext:float-nan-p val) (ext:float-infinity-p val))
    59 
    +        (let* ((str (concatenate 'string (ext::print-hex-single-float val) "f"))
    60 
    +               (parsed (ext:parse-hex-float str)))
    61 
    +          (assert-equal (get-single-bits val) (get-single-bits parsed)))))))

    • —
    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/-/commit/b32b761d8abf7d62fb04c3770a13fddff8444360 at 1771823629