Raymond Toy pushed to branch issue-480-double-double-hex-printer at cmucl / cmucl

Commits:

3 changed files:

Changes:

  • src/code/ext-code.lisp
    ... ... @@ -23,10 +23,6 @@
    23 23
    24 24 
     ;;;; C-style hex float printer and parser
    25 25
    26 
    -;;; FLOAT-TO-HEX-STRING  -- Public
    27 
    -;;;
    28 
    -;;; Return a string representing a single and double-floats in C-style
    29 
    -;;; hex format.
    30 26 
     (defun trim-trailing-zeros (s)
    31 27 
       "Remove trailing zero characters from string S, preserving internal zeros."
    32 28 
       (let ((last-nonzero (position #\0 s :test #'char/= :from-end t)))
    ... ... @@ -35,70 +31,65 @@
    35 31 
             "")))
    36 32
    37 33
    38 
    -(defun write-hex-float-double (x stream mantissa-bits type)
    39 
    -  "Print a single- or double-float in hex format onto STREAM.
    40 
    -   MANTISSA-BITS is 23 for single, 52 for double (excluding implicit leading 1).
    41 
    -   X must be the original float of the appropriate type; do not pre-coerce."
    42 
    -  (when (and (not (float-nan-p x)) (minusp (float-sign x)))
    43 
    -    (write-char #\- stream))
    44 
    -  (let ((x (abs x)))
    45 
    -    (cond
    46 
    -      ((float-nan-p x)
    47 
    -       (write-string "0x0.0p+nan" stream)
    48 
    -       (ecase type
    49 
    -         (:single (write-char #\f stream))
    50 
    -         (:double (values))))
    34 
    +(defun write-hex-float-double (x stream)
    35 
    +  "Print a single-float or double-float in hex format onto STREAM."
    36 
    +  ;; Float type and mantissa width are derived from the type of X.
    37 
    +  (multiple-value-bind (mantissa-bits suffix-char min-c-exp)
    38 
    +      (etypecase x
    39 
    +        (single-float (values 23 #\f -126))
    40 
    +        (double-float (values 52 nil -1022)))
    41 
    +    (when (and (not (float-nan-p x)) (minusp (float-sign x)))
    42 
    +      (write-char #\- stream))
    43 
    +    (let ((x (abs x)))
    44 
    +      (cond
    45 
    +        ((float-nan-p x)
    46 
    +         (write-string "0x0.0p+nan" stream)
    47 
    +         (when suffix-char (write-char suffix-char stream)))
    51 48
    52 
    -      ((float-infinity-p x)
    53 
    -       (write-string "0x1.0p+inf" stream)
    54 
    -       (ecase type
    55 
    -         (:single (write-char #\f stream))
    56 
    -         (:double (values))))
    49 
    +        ((float-infinity-p x)
    50 
    +         (write-string "0x1.0p+inf" stream)
    51 
    +         (when suffix-char (write-char suffix-char stream)))
    57 52
    58 
    -      ((zerop x)
    59 
    -       (write-string "0x0p+0" stream)
    60 
    -       (ecase type
    61 
    -         (:single (write-char #\f stream))
    62 
    -         (:double (values))))
    53 
    +        ((zerop x)
    54 
    +         (write-string "0x0p+0" stream)
    55 
    +         (when suffix-char (write-char suffix-char stream)))
    63 56
    64 
    -      (t
    65 
    -       (multiple-value-bind (significand exponent sign)
    66 
    -           (integer-decode-float x)
    67 
    -         (declare (ignore sign))
    68 
    -         (let* ((c-exp      (+ exponent mantissa-bits))
    69 
    -                (min-c-exp  (ecase type
    70 
    -                              (:double -1022)
    71 
    -                              (:single  -126)))
    72 
    -                (denormalp  (< c-exp min-c-exp))
    73 
    -                (hex-digits (ceiling mantissa-bits 4))
    74 
    -                (frac-shift (- (* 4 hex-digits) mantissa-bits))
    75 
    -                (frac       (if denormalp
    76 
    -                                (ash significand
    77 
    -                                     (+ (- c-exp min-c-exp) frac-shift))
    78 
    -                                (ash (logand significand
    79 
    -                                             (1- (ash 1 mantissa-bits)))
    80 
    -                                     frac-shift)))
    81 
    -                (out-exp    (if denormalp min-c-exp c-exp))
    82 
    -                (frac-str   (trim-trailing-zeros
    83 
    -                              (format nil "~v,'0X" hex-digits frac))))
    84 
    -           (write-string "0x" stream)
    85 
    -           (write-char (if denormalp #\0 #\1) stream)
    86 
    -           (unless (zerop (length frac-str))
    87 
    -             (write-char #\. stream)
    88 
    -             (write-string frac-str stream))
    89 
    -           (write-char #\p stream)
    90 
    -           (when (>= out-exp 0) (write-char #\+ stream))
    91 
    -           (write-string (format nil "~D" out-exp) stream)
    92 
    -           (ecase type
    93 
    -             (:single (write-char #\f stream))
    94 
    -             (:double (values))))))))
    95 
    -  (values))
    57 
    +        (t
    58 
    +         (multiple-value-bind (significand exponent sign)
    59 
    +             (integer-decode-float x)
    60 
    +           (declare (ignore sign))
    61 
    +           (let* ((c-exp      (+ exponent mantissa-bits))
    62 
    +                  (denormalp  (< c-exp min-c-exp))
    63 
    +                  (hex-digits (ceiling mantissa-bits 4))
    64 
    +                  (frac-shift (- (* 4 hex-digits) mantissa-bits))
    65 
    +                  (frac       (if denormalp
    66 
    +                                  (ash significand
    67 
    +                                       (+ (- c-exp min-c-exp) frac-shift))
    68 
    +                                  (ash (logand significand
    69 
    +                                               (1- (ash 1 mantissa-bits)))
    70 
    +                                       frac-shift)))
    71 
    +                  (out-exp    (if denormalp min-c-exp c-exp))
    72 
    +                  (frac-str   (trim-trailing-zeros
    73 
    +                               (format nil "~v,'0X" hex-digits frac))))
    74 
    +             (write-string "0x" stream)
    75 
    +             (write-char (if denormalp #\0 #\1) stream)
    76 
    +             (unless (zerop (length frac-str))
    77 
    +               (write-char #\. stream)
    78 
    +               (write-string frac-str stream))
    79 
    +             (write-char #\p stream)
    80 
    +             (when (>= out-exp 0)
    81 
    +	       (write-char #\+ stream))
    82 
    +             (write-string (format nil "~D" out-exp) stream)
    83 
    +             (when suffix-char
    84 
    +	       (write-char suffix-char stream)))))))
    85 
    +    (values)))
    96 86
    97 87
    88 
    +#+double-double
    98 89 
     (defun write-hex-float-double-double (x stream)
    99 
    -  "Print a double-double-float in hex format onto STREAM.
    100 
    -   Reconstructs the full significand from hi and lo components
    101 
    -   using exact integer arithmetic before formatting."
    90 
    +  "Print a double-double-float in hex format onto STREAM."
    91 
    +  ;; Reconstructs the full significand from hi and lo components using
    92 
    +  ;; exact integer arithmetic before formatting."
    102 93 
       (let* ((hi  (kernel:double-double-hi x))
    103 94 
              (lo  (kernel:double-double-lo x))
    104 95 
              (hi  (abs hi)))
    ... ... @@ -125,7 +116,8 @@
    125 116 
                       (denormalp      (< c-exp min-c-exp))
    126 117 
                       (raw-frac-bits  (if (zerop lo)
    127 118 
                                           52
    128 
    -                                      (+ (- exp-hi exp-lo) 52)))
    119 
    +                                      (+ (- exp-hi exp-lo)
    120 
    +					 52)))
    129 121 
                       (frac-bits      (* 4 (ceiling raw-frac-bits 4)))
    130 122 
                       (hex-digits     (/ frac-bits 4))
    131 123 
                       (shift          (if denormalp
    ... ... @@ -145,25 +137,16 @@
    145 137 
                    (write-char #\. stream)
    146 138 
                    (write-string frac-str stream))
    147 139 
                  (write-char #\p stream)
    148 
    -             (when (>= out-exp 0) (write-char #\+ stream))
    140 
    +             (when (>= out-exp 0)
    141 
    +	       (write-char #\+ stream))
    149 142 
                  (write-string (format nil "~D" out-exp) stream)
    150 143 
                  (write-char #\w stream))))))
    151 144 
       (values)))
    152 145
    153 
    -(defun write-hex-float (x &optional (stream *standard-output*))
    154 
    -  "Write float X to STREAM in C-style hex format.
    155 
    -   STREAM defaults to *standard-output*.
    156 
    -   single-float        => 0x<mantissa>p<exp>f
    157 
    -   double-float        => 0x<mantissa>p<exp>
    158 
    -   double-double-float => 0x<mantissa>p<exp>w
    159 
    -   Negative zero is printed with a leading minus sign."
    160 
    -  (let ((*print-case* :downcase))
    161 
    -    (etypecase x
    162 
    -      (double-double-float (write-hex-float-double-double x stream))
    163 
    -      (double-float        (write-hex-float-double x stream 52 :double))
    164 
    -      (single-float        (write-hex-float-double x stream 23 :single))))
    165 
    -  (values))
    166 
    -
    146 
    +;;; FLOAT-TO-HEX-STRING  -- Public
    147 
    +;;;
    148 
    +;;; Return a string representing a single and double-floats in C-style
    149 
    +;;; hex format.
    167 150 
     (defun float-to-hex-string (x)
    168 151 
       "Return a string containing the C-style hex float representation of X.
    169 152 
        single-float        => \"0x<mantissa>p<exp>f\"
    ... ... @@ -173,6 +156,30 @@
    173 156 
         (write-hex-float x s)))
    174 157
    175 158
    159 
    +;;; WRITE-HEX-FLOAT  -- Public
    160 
    +;;;
    161 
    +;;; Writes a float value (single, double, or double-double) in hex
    162 
    +;;; format to a stream, defaulting to *standard-output*.
    163 
    +(defun write-hex-float (x &optional (stream *standard-output*))
    164 
    +  "Write float X to STREAM in C-style hex format. STREAM defaults to *standard-output*.
    165 
    +
    166 
    +   single-float        => 0x<mantissa>p<exp>f
    167 
    +   double-float        => 0x<mantissa>p<exp>
    168 
    +   double-double-float => 0x<mantissa>p<exp>w
    169 
    +
    170 
    +  Negative zero is printed with a leading minus sign."
    171 
    +  (let ((*print-case* :downcase))
    172 
    +    (etypecase x
    173 
    +      (single-float
    174 
    +       (write-hex-float-double x stream))
    175 
    +      (double-float
    176 
    +       (write-hex-float-double x stream))
    177 
    +      #+double-double
    178 
    +      (double-double-float
    179 
    +       (write-hex-float-double-double x stream))))
    180 
    +  (values))
    181 
    +
    182 
    +
    176 183 
     ;;; FORMAT-HEX-FLOAT -- Public
    177 184 
     ;;;
    178 185 
     ;;; Function that can be used in a FORMAT ~/
    ... ... @@ -180,18 +187,15 @@
    180 187 
       "Format function for use with ~/package:format-hex-float/.
    181 188 
        Ignores colon modifier.
    182 189 
        At-sign modifier forces a leading + sign on non-negative values.
    183 
    -   Example: (format t \"~@/format-hex-float/\" 3.0d0) => +0x1.8p+1"
    190 
    +   Example: (format t \"~@/ext:format-hex-float/\" 3.0d0) => +0x1.8p+1"
    184 191 
       (declare (ignore colonp args))
    185 192 
       (when (and atsignp
    186 
    -             (not (float-nan-p (if (typep x 'ext:double-double-float)
    187 
    -                                   (kernel:double-double-hi x)
    188 
    -                                   x)))
    189 
    -             (not (minusp (float-sign (if (typep x 'ext:double-double-float)
    190 
    -                                          (kernel:double-double-hi x)
    191 
    -                                          x)))))
    193 
    +             (not (float-nan-p x))
    194 
    +             (not (minusp (float-sign x))))
    192 195 
         (write-char #\+ stream))
    193 196 
       (write-hex-float x stream))
    194 197
    198 
    +
    195 199 
     (define-condition hex-parse-error (parse-error)
    196 200 
       ((text :initarg :text :reader hex-parse-error-text)
    197 201 
        (message :initarg :message :reader hex-parse-error-message))

  • src/i18n/locale/cmucl.pot
    No preview for this file type
  • tests/extensions.lisp
    ... ... @@ -10,6 +10,8 @@
    10 10 
       (assert-equal "0x1.8p+1w"  (ext:float-to-hex-string 3.0w0))
    11 11 
       (assert-equal "-0x1.8p+1"  (ext:float-to-hex-string -3.0d0)))
    12 12
    13 
    +;;; ---- write-hex-float / float-to-hex-string tests -------------------------
    14 
    +
    13 15 
     (define-test write-double-zero
    14 16 
       (assert-equal "0x0p+0"  (ext:float-to-hex-string 0.0d0))
    15 17 
       (assert-equal "-0x0p+0" (ext:float-to-hex-string -0.0d0)))
    ... ... @@ -19,12 +21,12 @@
    19 21 
       (assert-equal "-0x1p+0" (ext:float-to-hex-string -1.0d0)))
    20 22
    21 23 
     (define-test write-double-powers-of-two
    22 
    -  (assert-equal "0x1p+1"    (ext:float-to-hex-string 2.0d0))
    23 
    -  (assert-equal "0x1p-1"    (ext:float-to-hex-string 0.5d0))
    24 
    -  (assert-equal "0x1p+52"   (ext:float-to-hex-string (expt 2.0d0 52)))
    25 
    -  (assert-equal "0x1p-52"   (ext:float-to-hex-string (expt 2.0d0 -52)))
    26 
    -  (assert-equal "0x1p+1023" (ext:float-to-hex-string (expt 2.0d0 1023)))
    27 
    -  (assert-equal "0x1p-1022" (ext:float-to-hex-string (expt 2.0d0 -1022))))
    24 
    +  (assert-equal "0x1p+1"    (ext:float-to-hex-string (scale-float 1.0d0 1)))
    25 
    +  (assert-equal "0x1p-1"    (ext:float-to-hex-string (scale-float 1.0d0 -1)))
    26 
    +  (assert-equal "0x1p+52"   (ext:float-to-hex-string (scale-float 1.0d0 52)))
    27 
    +  (assert-equal "0x1p-52"   (ext:float-to-hex-string (scale-float 1.0d0 -52)))
    28 
    +  (assert-equal "0x1p+1023" (ext:float-to-hex-string (scale-float 1.0d0 1023)))
    29 
    +  (assert-equal "0x1p-1022" (ext:float-to-hex-string (scale-float 1.0d0 -1022))))
    28 30
    29 31 
     (define-test write-double-fractions
    30 32 
       (assert-equal "0x1.8p+1"             (ext:float-to-hex-string 3.0d0))
    ... ... @@ -33,8 +35,8 @@
    33 35 
       (assert-equal "0x1.921fb54442d18p+1" (ext:float-to-hex-string pi)))
    34 36
    35 37 
     (define-test write-double-denormals
    36 
    -  (assert-equal "0x0.8p-1022"             (ext:float-to-hex-string (expt 2.0d0 -1023)))
    37 
    -  (assert-equal "0x0.0000000000001p-1022" (ext:float-to-hex-string (expt 2.0d0 -1074))))
    38 
    +  (assert-equal "0x0.8p-1022"             (ext:float-to-hex-string (scale-float 1.0d0 -1023)))
    39 
    +  (assert-equal "0x0.0000000000001p-1022" (ext:float-to-hex-string (scale-float 1.0d0 -1074))))
    38 40
    39 41 
     (define-test write-double-special
    40 42 
       (assert-equal "0x1.0p+inf"
    ... ... @@ -58,10 +60,10 @@
    58 60 
       (assert-equal "0x1.8p+1f"        (ext:float-to-hex-string 3.0f0))
    59 61 
       (assert-equal "0x1.555556p-2f"   (ext:float-to-hex-string (/ 1.0f0 3.0f0)))
    60 62 
       (assert-equal "0x1.fffffep+127f" (ext:float-to-hex-string most-positive-single-float))
    61 
    -  (assert-equal "0x1p-126f"        (ext:float-to-hex-string (expt 2.0f0 -126))))
    63 
    +  (assert-equal "0x1p-126f"        (ext:float-to-hex-string (scale-float 1.0f0 -126))))
    62 64
    63 65 
     (define-test write-single-denormals
    64 
    -  (assert-equal "0x0.000002p-126f" (ext:float-to-hex-string (expt 2.0f0 -149))))
    66 
    +  (assert-equal "0x0.000002p-126f" (ext:float-to-hex-string (scale-float 1.0f0 -149))))
    65 67
    66 68 
     (define-test write-single-special
    67 69 
       (assert-equal "0x1.0p+inff"
    ... ... @@ -82,11 +84,13 @@
    82 84 
       (assert-equal "0x1p+0w"                (ext:float-to-hex-string 1.0w0))
    83 85 
       (assert-equal "-0x1p+0w"               (ext:float-to-hex-string -1.0w0))
    84 86 
       (assert-equal "0x1.8p+1w"              (ext:float-to-hex-string 3.0w0))
    85 
    -  (assert-equal "0x1p+64w"               (ext:float-to-hex-string (expt 2.0w0 64)))
    87 
    +  (assert-equal "0x1p+64w"               (ext:float-to-hex-string (scale-float 1.0w0 64)))
    86 88 
       (assert-equal "0x1.921fb54442d18p+1w"
    87 89 
                     (ext:float-to-hex-string (coerce pi 'ext:double-double-float)))
    88 90 
       (assert-equal "0x1.fffffffffffff8p-1w"
    89 
    -                (ext:float-to-hex-string (- 1.0w0 (expt 2.0w0 -54)))))
    91 
    +                (ext:float-to-hex-string (- 1.0w0 (scale-float 1.0w0 -54)))))
    92 
    +
    93 
    +
    90 94
    91 95 
     (defun get-double-bits (val)
    92 96 
       (multiple-value-bind (hi lo) (kernel:double-float-bits val)

    • —
    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/9ac58853a31d60a157e02b08033f0513e5906bb6...d948a386f79541704657c5c3b964cb2e94456250 at 1773007318