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

Commits:

4 changed files:

Changes:

  • src/code/ext-code.lisp
    ... ... @@ -47,15 +47,18 @@
    47 47 
           (cond
    48 48 
             ((float-nan-p x)
    49 49 
              (write-string "0x0.0p+nan" stream)
    50 
    -         (when suffix-char (write-char suffix-char stream)))
    50 
    +         (when suffix-char
    51 
    +	   (write-char suffix-char stream)))
    51 52
    52 53 
             ((float-infinity-p x)
    53 54 
              (write-string "0x1.0p+inf" stream)
    54 
    -         (when suffix-char (write-char suffix-char stream)))
    55 
    +         (when suffix-char
    56 
    +	   (write-char suffix-char stream)))
    55 57
    56 58 
             ((zerop x)
    57 59 
              (write-string "0x0p+0" stream)
    58 
    -         (when suffix-char (write-char suffix-char stream)))
    60 
    +         (when suffix-char
    61 
    +	   (write-char suffix-char stream)))
    59 62
    60 63 
             (t
    61 64 
              (multiple-value-bind (significand exponent sign)
    ... ... @@ -75,14 +78,15 @@
    75 78 
                       (frac-str   (trim-trailing-zeros
    76 79 
                                    (format nil "~v,'0X" hex-digits frac))))
    77 80 
                  (write-string "0x" stream)
    78 
    -             (write-char (if denormalp #\0 #\1) stream)
    81 
    +             (write-char (if denormalp #\0 #\1)
    82 
    +			 stream)
    79 83 
                  (unless (zerop (length frac-str))
    80 84 
                    (write-char #\. stream)
    81 85 
                    (write-string frac-str stream))
    82 86 
                  (write-char #\p stream)
    83 87 
                  (when (>= out-exp 0)
    84 88 
     	       (write-char #\+ stream))
    85 
    -             (write-string (format nil "~D" out-exp) stream)
    89 
    +             (format stream "~D" out-exp)
    86 90 
                  (when suffix-char
    87 91 
     	       (write-char suffix-char stream)))))))
    88 92 
         (values)))
    ... ... @@ -141,7 +145,7 @@
    141 145 
                  (write-char #\p stream)
    142 146 
                  (when (>= out-exp 0)
    143 147 
     	       (write-char #\+ stream))
    144 
    -             (write-string (format nil "~D" out-exp) stream)
    148 
    +             (format stream "~D" out-exp)
    145 149 
                  (write-char #\w stream))))))
    146 150 
       (values)))
    147 151
    ... ... @@ -185,9 +189,9 @@
    185 189 
     ;;; Function that can be used in a FORMAT ~/
    186 190 
     (defun format-hex-float (stream x colonp atsignp &rest args)
    187 191 
       "Format function for use with ~/package:format-hex-float/.
    188 
    -   Ignores colon modifier.
    189 
    -   At-sign modifier forces a leading + sign on non-negative values.
    190 
    -   Example: (format t \"~@/ext:format-hex-float/\" 3.0d0) => +0x1.8p+1"
    192 
    +  Ignores colon modifier.  At-sign modifier forces a leading + sign on
    193 
    +  non-negative values. Example: (format t \"~@/ext:format-hex-float/\"
    194 
    +  3.0d0) => +0x1.8p+1"
    191 195 
       (declare (ignore colonp args))
    192 196 
       (when (and atsignp
    193 197 
                  (not (float-nan-p x))
    ... ... @@ -203,20 +207,20 @@
    203 207 
       ((input    :initarg :input    :reader hex-float-parse-error-input)
    204 208 
        (position :initarg :position :reader hex-float-parse-error-position)
    205 209 
        (message  :initarg :message  :reader hex-float-parse-error-message))
    206 
    -  (:report (lambda (c s)
    207 
    -             (format s "Hex float parse error~@[ at position ~D~]: ~A~@[ (input: ~S)~]"
    208 
    -                     (hex-float-parse-error-position c)
    209 
    -                     (hex-float-parse-error-message c)
    210 
    -                     (hex-float-parse-error-input c)))))
    210 
    +  (:report #'(lambda (c s)
    211 
    +               (format s "Hex float parse error~@[ at position ~D~]: ~A~@[ (input: ~S)~]"
    212 
    +                       (hex-float-parse-error-position c)
    213 
    +                       (hex-float-parse-error-message c)
    214 
    +                       (hex-float-parse-error-input c)))))
    211 215
    212 216 
     (defun read-hex-float-from-stream (stream)
    213 217 
       "Read a C-style hex float from STREAM and return a float value.
    214 
    -   Format: [sign] 0x <hex-mantissa> [. <hex-fraction>] p <exp> [f|w]
    218 
    +  Format: [sign] 0x <hex-mantissa> [. <hex-fraction>] p <exp> [f|w]
    215 219 
        'f' suffix => single-float
    216 
    -   'w' suffix => double-double-float (CMUCL native)
    217 
    -   no suffix   => double-float
    218 
    -   The binary exponent (p or P) is required.
    219 
    -   Signals HEX-FLOAT-PARSE-ERROR on malformed input."
    220 
    +   'w' suffix => double-double-float
    221 
    +   no suffix  => double-float
    222 
    +  The binary exponent (p or P) is required.
    223 
    +  Signals HEX-FLOAT-PARSE-ERROR on malformed input."
    220 224 
       (flet ((parse-error (pos msg &rest args)
    221 225 
                (error 'ext:hex-float-parse-error
    222 226 
                       :position pos
    ... ... @@ -247,8 +251,11 @@
    247 251 
           (let ((c (peek-char nil stream nil nil)))
    248 252 
             (cond ((null c)
    249 253 
                    (parse-error (pos) "Unexpected end of input, expected hex float"))
    250 
    -              ((char= c #\-) (setf sign -1) (read-char stream))
    251 
    -              ((char= c #\+) (read-char stream))))
    254 
    +              ((char= c #\-)
    255 
    +	       (setf sign -1)
    256 
    +	       (read-char stream))
    257 
    +              ((char= c #\+)
    258 
    +	       (read-char stream))))
    252 259
    253 260 
           ;; Expect "0"
    254 261 
           (let ((c (read-char stream nil nil)))
    ... ... @@ -277,7 +284,8 @@
    277 284 
                           n-frac count)
    278 285 
                     (when (and (zerop count)
    279 286 
                                (peek-char nil stream nil nil)
    280 
    -                           (not (member (peek-char nil stream nil nil) '(#\p #\P))))
    287 
    +                           (not (member (peek-char nil stream nil nil)
    288 
    +					'(#\p #\P))))
    281 289 
                       (parse-error frac-start "Expected hex digits after decimal point")))))
    282 290
    283 291 
               ;; Mantissa must have at least one hex digit total
    ... ... @@ -291,8 +299,11 @@
    291 299
    292 300 
           ;; Exponent sign and digits
    293 301 
           (let ((exp-sign 1))
    294 
    -        (when (member (peek-char nil stream nil nil) '(#\+ #\-))
    295 
    -          (when (char= (read-char stream) #\-) (setf exp-sign -1)))
    302 
    +        (when (member (peek-char nil stream nil nil)
    303 
    +		      '(#\+ #\-))
    304 
    +          (when (char= (read-char stream)
    305 
    +		       #\-)
    306 
    +	    (setf exp-sign -1)))
    296 307 
             (let ((exp-start (pos)))
    297 308 
               (multiple-value-bind (value count)
    298 309 
                   (accumulate-digits 10)
    ... ... @@ -303,8 +314,12 @@
    303 314 
           ;; Optional suffix: 'f'/'F' => single, 'w'/'W' => double-double, none => double
    304 315 
           (when (peek-char nil stream nil nil)
    305 316 
             (let ((c (peek-char nil stream nil nil)))
    306 
    -          (cond ((member c '(#\f #\F)) (read-char stream) (setf suffix :single))
    307 
    -                ((member c '(#\w #\W)) (read-char stream) (setf suffix :double-double))
    317 
    +          (cond ((member c '(#\f #\F))
    318 
    +		 (read-char stream)
    319 
    +		 (setf suffix :single))
    320 
    +                ((member c '(#\w #\W))
    321 
    +		 (read-char stream)
    322 
    +		 (setf suffix :double-double))
    308 323 
                     ((not (or (member c '(#\space #\tab #\newline #\return
    309 324 
                                          #\) #\] #\} #\,))
    310 325 
                               (digit-char-p c 10)))
    ... ... @@ -319,8 +334,8 @@
    319 334 
                (scale-float (* sign (float significand 1.0d0)) adjusted-exp))
    320 335
    321 336 
               (:single
    322 
    -           (coerce (scale-float (* sign (float significand 1.0d0)) adjusted-exp)
    323 
    -                   'single-float))
    337 
    +           (scale-float (* sign (float significand 1.0f0))
    338 
    +			adjusted-exp))
    324 339
    325 340 
               (:double-double
    326 341 
                (let* ((sig-bits    (integer-length significand))
    ... ... @@ -335,10 +350,9 @@
    335 350
    336 351 
     (defun read-hex-float-from-string (s &key (start 0) end)
    337 352 
       "Read a C-style hex float from string S.
    338 
    -   START and END bound the region to read (default: entire string).
    339 
    -   Returns two values: the float and the index of the first character
    340 
    -   not consumed.
    341 
    -   Signals HEX-FLOAT-PARSE-ERROR on malformed input."
    353 
    +  START and END bound the region to read (default: entire string).
    354 
    +  Returns two values: the float and the index of the first character
    355 
    +  not consumed.  Signals HEX-FLOAT-PARSE-ERROR on malformed input."
    342 356 
       (with-input-from-string (stream s :start start :end end)
    343 357 
         (values (read-hex-float-from-stream stream)
    344 358 
                 (file-position stream))))
    ... ... @@ -347,11 +361,15 @@
    347 361 
     ;;; READ-HEX-FLOAT -- Public
    348 362 
     ;;;
    349 363 
     ;;; Read a C-style hex float number from either a string or a stream.
    350 
    -(defun read-hex-float (obj)
    351 
    -  "Read a C-style hex float number from OBJ which is either a string or a stream."
    352 
    -  (declare (type (or string stream) obj))
    353 
    -  (etypecase obj
    354 
    -    (string
    355 
    -     (read-hex-float-from-string obj))
    364 
    +(defun ext:read-hex-float (stream-or-string &key (start 0) end)
    365 
    +  "Read a C-style hex float from STREAM-OR-STRING.
    366 
    +  If a string, START and END bound the region to read.  When reading
    367 
    +  from a string, returns two values: the float and the index of the
    368 
    +  first character not consumed.  When reading from a stream, returns
    369 
    +  one value: the float.  Signals HEX-FLOAT-PARSE-ERROR on malformed
    370 
    +  input."
    371 
    +  (etypecase stream-or-string
    356 372 
         (stream
    357 
    -     (read-hex-float-from-stream obj))))
    373 
    +     (read-hex-float-from-stream stream-or-string))
    374 
    +    (string
    375 
    +     (read-hex-float-from-string stream-or-string :start start :end end))))

  • src/general-info/release-22a.md
    ... ... @@ -58,6 +58,9 @@ public domain.
    58 58 
         * #463: `double-double-float` is missing comparison operations
    59 59 
                 between `double-double-float` and `double-float`
    60 60 
         * #474: Add functions to print and parse C-style hex floats.
    61 
    +    * #477: Support reading and writing double-double-float in hex
    62 
    +	    format.  "w" is the suffix used to denote
    63 
    +	    double-double-floats.
    61 64 
       * Other changes:
    62 65 
       * Improvements to the PCL implementation of CLOS:
    63 66 
       * Changes to building procedure:

  • src/i18n/locale/cmucl.pot
    No preview for this file type
  • tests/extensions.lisp
    ... ... @@ -4,12 +4,6 @@
    4 4
    5 5 
     (in-package "EXTENSIONS-TESTS")
    6 6
    7 
    -(define-test float-to-hex-string
    8 
    -  (assert-equal "0x1.8p+1"   (ext:float-to-hex-string 3.0d0))
    9 
    -  (assert-equal "0x1.8p+1f"  (ext:float-to-hex-string 3.0f0))
    10 
    -  (assert-equal "0x1.8p+1w"  (ext:float-to-hex-string 3.0w0))
    11 
    -  (assert-equal "-0x1.8p+1"  (ext:float-to-hex-string -3.0d0)))
    12 
    -
    13 7 
     ;;; ---- write-hex-float / float-to-hex-string tests -------------------------
    14 8
    15 9 
     (define-test write-double-zero
    ... ... @@ -91,150 +85,65 @@
    91 85 
                     (ext:float-to-hex-string (- 1.0w0 (scale-float 1.0w0 -54)))))
    92 86
    93 87
    94 
    -
    95 
    -(defun get-double-bits (val)
    96 
    -  (multiple-value-bind (hi lo) (kernel:double-float-bits val)
    97 
    -    (logior (ash (ldb (byte 32 0) hi) 32) (ldb (byte 32 0) lo))))
    98 
    -
    99 
    -(defun get-single-bits (val)
    100 
    -  (ldb (byte 32 0) (kernel:single-float-bits val)))
    101 
    -
    102 
    -(define-test test-hex-syntax
    103 
    -  (:tag :validation)
    104 
    -  (assert-error 'ext:hex-float-parse-error (ext:read-hex-float "inf"))
    105 
    -  (assert-error 'ext:hex-float-parse-error (ext:read-hex-float "0x.p+0"))
    106 
    -  (assert-error 'ext:hex-float-parse-error (ext:read-hex-float "0x1.0p")))
    107 
    -
    108 
    -(define-test test-cliff-boundaries
    109 
    -  (:tag :precision)
    110 
    -  ;; Double Precision (-1022 Cliff)
    111 
    -
    112 
    -  (assert-equal #x0010000000000000
    113 
    -		(get-double-bits (ext:read-hex-float "0x1.0000000000000p-1022")))
    114 
    -  (assert-equal #x000fffffffffffff
    115 
    -		(get-double-bits (ext:read-hex-float "0x0.fffffffffffffp-1022")))
    116 
    -  (assert-equal #x001f0195cb356b8f
    117 
    -		(get-double-bits (ext:read-hex-float "0x1.f0195cb356b8fp-1022")))
    118 
    -
    119 
    -  ;; Single Precision (-126 Cliff)
    120 
    -
    121 
    -  (assert-equal #x00800000
    122 
    -		(get-single-bits (ext:read-hex-float "0x1.000000p-126f")))
    123 
    -  (assert-equal #x00400000
    124 
    -		(get-single-bits (ext:read-hex-float "0x0.800000p-126f")))
    125 
    -  (assert-equal #x7f7fffff
    126 
    -		(get-single-bits (ext:read-hex-float "0x1.fffffep+127f"))))
    127 
    -
    128 
    -(define-test test-negative-zero
    129 
    -  (:tag :edge-cases)
    130 
    -  (assert-equal #x8000000000000000
    131 
    -		(get-double-bits (ext:read-hex-float "-0x0.0p+0")))
    132 
    -  (assert-equal #x80000000
    133 
    -		(get-single-bits (ext:read-hex-float "-0x0.0p+0f")))
    134 
    -  (assert-true (typep (ext:read-hex-float "-0x0.0p+0f")
    135 
    -		      'single-float)))
    136 
    -
    137 
    -(define-test test-subnormal-boundaries
    138 
    -  (:tag :edge)
    139 
    -  ;; Test smallest single-float subnormal
    140 
    -  (let* ((val (kernel:make-single-float 1))
    141 
    -         (str (ext:float-to-hex-string val))
    142 
    -         (parsed (ext:read-hex-float str)))
    143 
    -    (assert-equal (get-single-bits val) (get-single-bits parsed)
    144 
    -		  val str parsed))
    145 
    -  ;; Test smallest double-float subnormal
    146 
    -  (let* ((val (kernel:make-double-float 0 1))
    147 
    -         (str (ext:float-to-hex-string val))
    148 
    -         (parsed (ext:read-hex-float str)))
    149 
    -    (assert-equal (get-double-bits val) (get-double-bits parsed)
    150 
    -		  val str parsed)))
    151 
    -
    152 
    -(define-test test-double-roundtrip
    153 
    -  (:tag :stress)
    154 
    -  (loop repeat 10000 do
    155 
    -    (let* ((hi-bits (random #x100000000))
    156 
    -           (hi (if (logbitp 31 hi-bits) (- hi-bits #x100000000) hi-bits))
    157 
    -           (lo (random #x100000000))
    158 
    -           (val (kernel:make-double-float hi lo)))
    159 
    -      (unless (or (ext:float-nan-p val) (ext:float-infinity-p val))
    160 
    -        (let* ((str (ext:float-to-hex-string val))
    161 
    -               (parsed (ext:read-hex-float str)))
    162 
    -          (assert-equal (get-double-bits val)
    163 
    -			(get-double-bits parsed)
    164 
    -			val str parsed))))))
    165 
    -
    166 
    -(define-test test-single-roundtrip
    167 
    -  (:tag :stress)
    168 
    -  (loop repeat 10000 do
    169 
    -    (let* ((bits-raw (random #x100000000))
    170 
    -           (bits (if (logbitp 31 bits-raw) (- bits-raw #x100000000) bits-raw))
    171 
    -           (val (kernel:make-single-float bits)))
    172 
    -      (unless (or (ext:float-nan-p val) (ext:float-infinity-p val))
    173 
    -        (let* ((str (concatenate 'string (ext:float-to-hex-string val) "f"))
    174 
    -               (parsed (ext:read-hex-float str)))
    175 
    -          (assert-equal (get-single-bits val)
    176 
    -			(get-single-bits parsed)
    177 
    -			val str parsed))))))
    178 
    -
    179 88 
     ;;; ---- read-hex-float tests ------------------------------------------------
    180 89
    181 90 
     (define-test read-double-zero
    182 
    -  (assert-true (eql 0.0d0  (ext:read-hex-float "0x0p+0")))
    183 
    -  (assert-true (eql -0.0d0 (ext:read-hex-float "-0x0p+0"))))
    91 
    +  (assert-eql 0.0d0  (ext:read-hex-float "0x0p+0"))
    92 
    +  (assert-eql -0.0d0 (ext:read-hex-float "-0x0p+0")))
    184 93
    185 94 
     (define-test read-double-values
    186 
    -  (assert-true (eql 1.0d0  (ext:read-hex-float "0x1p+0")))
    187 
    -  (assert-true (eql -1.0d0 (ext:read-hex-float "-0x1p+0")))
    188 
    -  (assert-true (eql 2.0d0  (ext:read-hex-float "0x1p+1")))
    189 
    -  (assert-true (eql 0.5d0  (ext:read-hex-float "0x1p-1")))
    190 
    -  (assert-true (eql 3.0d0  (ext:read-hex-float "0x1.8p+1")))
    191 
    -  (assert-true (eql -3.0d0 (ext:read-hex-float "-0x1.8p+1")))
    192 
    -  (assert-true (eql pi     (ext:read-hex-float "0x1.921fb54442d18p+1"))))
    95 
    +  (assert-eql 1.0d0  (ext:read-hex-float "0x1p+0"))
    96 
    +  (assert-eql -1.0d0 (ext:read-hex-float "-0x1p+0"))
    97 
    +  (assert-eql 2.0d0  (ext:read-hex-float "0x1p+1"))
    98 
    +  (assert-eql 0.5d0  (ext:read-hex-float "0x1p-1"))
    99 
    +  (assert-eql 3.0d0  (ext:read-hex-float "0x1.8p+1"))
    100 
    +  (assert-eql -3.0d0 (ext:read-hex-float "-0x1.8p+1"))
    101 
    +  (assert-eql pi     (ext:read-hex-float "0x1.921fb54442d18p+1")))
    193 102
    194 103 
     (define-test read-double-denormals
    195 
    -  (assert-true (eql (scale-float 1.0d0 -1023)
    196 
    -                    (ext:read-hex-float "0x0.8p-1022")))
    197 
    -  (assert-true (eql (scale-float 1.0d0 -1074)
    198 
    -                    (ext:read-hex-float "0x0.0000000000001p-1022"))))
    104 
    +  (assert-eql (scale-float 1.0d0 -1023)
    105 
    +              (ext:read-hex-float "0x0.8p-1022"))
    106 
    +  (assert-eql (scale-float 1.0d0 -1074)
    107 
    +              (ext:read-hex-float "0x0.0000000000001p-1022")))
    199 108
    200 109 
     (define-test read-double-case-insensitive
    201 
    -  (assert-true (eql 3.0d0 (ext:read-hex-float "0X1.8P+1")))
    202 
    -  (assert-true (eql 0.5d0 (ext:read-hex-float "0X1P-1"))))
    110 
    +  (assert-eql 3.0d0 (ext:read-hex-float "0X1.8P+1"))
    111 
    +  (assert-eql 0.5d0 (ext:read-hex-float "0X1P-1")))
    203 112
    204 113 
     (define-test read-single-zero
    205 
    -  (assert-true (eql 0.0f0  (ext:read-hex-float "0x0p+0f")))
    206 
    -  (assert-true (eql -0.0f0 (ext:read-hex-float "-0x0p+0f"))))
    114 
    +  (assert-eql 0.0f0  (ext:read-hex-float "0x0p+0f"))
    115 
    +  (assert-eql -0.0f0 (ext:read-hex-float "-0x0p+0f")))
    207 116
    208 117 
     (define-test read-single-values
    209 
    -  (assert-true (eql 1.0f0  (ext:read-hex-float "0x1p+0f")))
    210 
    -  (assert-true (eql -1.0f0 (ext:read-hex-float "-0x1p+0f")))
    211 
    -  (assert-true (eql 2.0f0  (ext:read-hex-float "0x1p+1f")))
    212 
    -  (assert-true (eql 3.0f0  (ext:read-hex-float "0x1.8p+1f")))
    213 
    -  (assert-true (eql (/ 1.0f0 3.0f0)
    214 
    -                    (ext:read-hex-float "0x1.555556p-2f")))
    215 
    -  (assert-true (eql most-positive-single-float
    216 
    -                    (ext:read-hex-float "0x1.fffffep+127f")))
    217 
    -  (assert-true (eql (scale-float 1.0f0 -149)
    218 
    -                    (ext:read-hex-float "0x0.000002p-126f"))))
    118 
    +  (assert-eql 1.0f0  (ext:read-hex-float "0x1p+0f"))
    119 
    +  (assert-eql -1.0f0 (ext:read-hex-float "-0x1p+0f"))
    120 
    +  (assert-eql 2.0f0  (ext:read-hex-float "0x1p+1f"))
    121 
    +  (assert-eql 3.0f0  (ext:read-hex-float "0x1.8p+1f"))
    122 
    +  (assert-eql (/ 1.0f0 3.0f0)
    123 
    +              (ext:read-hex-float "0x1.555556p-2f"))
    124 
    +  (assert-eql most-positive-single-float
    125 
    +              (ext:read-hex-float "0x1.fffffep+127f"))
    126 
    +  (assert-eql (scale-float 1.0f0 -149)
    127 
    +              (ext:read-hex-float "0x0.000002p-126f")))
    219 128
    220 129 
     (define-test read-single-case-insensitive
    221 
    -  (assert-true (eql 3.0f0 (ext:read-hex-float "0x1.8p+1F"))))
    130 
    +  (assert-eql 3.0f0 (ext:read-hex-float "0x1.8p+1F")))
    222 131
    223 132 
     (define-test read-double-double-zero
    224 
    -  (assert-true (eql 0.0w0  (ext:read-hex-float "0x0p+0w")))
    225 
    -  (assert-true (eql -0.0w0 (ext:read-hex-float "-0x0p+0w"))))
    133 
    +  (assert-eql 0.0w0  (ext:read-hex-float "0x0p+0w"))
    134 
    +  (assert-eql -0.0w0 (ext:read-hex-float "-0x0p+0w")))
    226 135
    227 136 
     (define-test read-double-double-values
    228 
    -  (assert-true (eql 1.0w0  (ext:read-hex-float "0x1p+0w")))
    229 
    -  (assert-true (eql -1.0w0 (ext:read-hex-float "-0x1p+0w")))
    230 
    -  (assert-true (eql 3.0w0  (ext:read-hex-float "0x1.8p+1w")))
    231 
    -  (assert-true (eql (scale-float 1.0w0 64)
    232 
    -                    (ext:read-hex-float "0x1p+64w")))
    233 
    -  (assert-true (eql (coerce pi 'ext:double-double-float)
    234 
    -                    (ext:read-hex-float "0x1.921fb54442d18p+1w"))))
    137 
    +  (assert-eql 1.0w0  (ext:read-hex-float "0x1p+0w"))
    138 
    +  (assert-eql -1.0w0 (ext:read-hex-float "-0x1p+0w"))
    139 
    +  (assert-eql 3.0w0  (ext:read-hex-float "0x1.8p+1w"))
    140 
    +  (assert-eql (scale-float 1.0w0 64)
    141 
    +              (ext:read-hex-float "0x1p+64w"))
    142 
    +  (assert-eql (coerce pi 'ext:double-double-float)
    143 
    +              (ext:read-hex-float "0x1.921fb54442d18p+1w")))
    235 144
    236 145 
     (define-test read-double-double-case-insensitive
    237 
    -  (assert-true (eql 3.0w0 (ext:read-hex-float "0x1.8p+1W"))))
    146 
    +  (assert-eql 3.0w0 (ext:read-hex-float "0x1.8p+1W")))
    238 147
    239 148
    240 149 
     ;;; ---- round-trip tests ----------------------------------------------------
    ... ... @@ -246,7 +155,7 @@
    246 155 
                        (scale-float 1.0d0 -1022)
    247 156 
                        (scale-float 1.0d0 -1074)
    248 157 
                        (/ 1.0d0 3.0d0)))
    249 
    -    (assert-true (eql x (ext:read-hex-float (ext:float-to-hex-string x))) x)))
    158 
    +    (assert-eql x (ext:read-hex-float (ext:float-to-hex-string x)))))
    250 159
    251 160 
     (define-test round-trip-single
    252 161 
       (dolist (x (list 0.0f0 -0.0f0 1.0f0 -1.0f0
    ... ... @@ -255,8 +164,7 @@
    255 164 
                        (scale-float 1.0f0 -126)
    256 165 
                        (scale-float 1.0f0 -149)
    257 166 
                        (/ 1.0f0 3.0f0)))
    258 
    -    (assert-true (eql x (ext:read-hex-float (ext:float-to-hex-string x)))
    259 
    -		 x)))
    167 
    +    (assert-eql x (ext:read-hex-float (ext:float-to-hex-string x)))))
    260 168
    261 169 
     (define-test round-trip-double-double
    262 170 
       (dolist (x (list 0.0w0 -0.0w0 1.0w0 -1.0w0
    ... ... @@ -266,27 +174,27 @@
    266 174 
                        (- 1.0w0 (scale-float 1.0w0 -54))
    267 175 
                        ext:most-positive-double-double-float
    268 176 
                        ext:least-positive-double-double-float))
    269 
    -    (assert-true (eql x (ext:read-hex-float (ext:float-to-hex-string x))) x)))
    177 
    +    (assert-eql x (ext:read-hex-float (ext:float-to-hex-string x)))))
    270 178
    271 179
    272 180 
     ;;; ---- read-hex-float-from-string tests ------------------------------------
    273 181
    274 182 
     (define-test read-from-string-positions
    275 183 
       (multiple-value-bind (val pos)
    276 
    -      (ext::read-hex-float-from-string "0x1.8p+1")
    277 
    -    (assert-true (eql 3.0d0 val))
    184 
    +      (ext:read-hex-float "0x1.8p+1")
    185 
    +    (assert-eql 3.0d0 val)
    278 186 
         (assert-equal 8 pos))
    279 187 
       (multiple-value-bind (val pos)
    280 
    -      (ext::read-hex-float-from-string "0x1.8p+1f")
    281 
    -    (assert-true (eql 3.0f0 val))
    188 
    +      (ext:read-hex-float "0x1.8p+1f")
    189 
    +    (assert-eql 3.0f0 val)
    282 190 
         (assert-equal 9 pos))
    283 191 
       (multiple-value-bind (val pos)
    284 
    -      (ext::read-hex-float-from-string "xxx0x1.8p+1" :start 3)
    285 
    -    (assert-true (eql 3.0d0 val))
    192 
    +      (ext:read-hex-float "xxx0x1.8p+1" :start 3)
    193 
    +    (assert-eql 3.0d0 val)
    286 194 
         (assert-equal 11 pos))
    287 195 
       (multiple-value-bind (val pos)
    288 
    -      (ext::read-hex-float-from-string "0x1.8p+1 etc")
    289 
    -    (assert-true (eql 3.0d0 val))
    196 
    +      (ext:read-hex-float "0x1.8p+1 etc")
    197 
    +    (assert-eql 3.0d0 val)
    290 198 
         (assert-equal 8 pos)))
    291 199
    292 200
    ... ... @@ -337,3 +245,58 @@
    337 245 
       (assert-error 'ext:hex-float-parse-error
    338 246 
                     (ext:read-hex-float "-")))
    339 247
    248 
    +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    249 
    +(defun get-double-bits (val)
    250 
    +  (multiple-value-bind (hi lo) (kernel:double-float-bits val)
    251 
    +    (logior (ash (ldb (byte 32 0) hi) 32) (ldb (byte 32 0) lo))))
    252 
    +
    253 
    +(defun get-single-bits (val)
    254 
    +  (ldb (byte 32 0) (kernel:single-float-bits val)))
    255 
    +
    256 
    +(define-test test-cliff-boundaries
    257 
    +  (:tag :precision)
    258 
    +  ;; Double Precision (-1022 Cliff)
    259 
    +
    260 
    +  (assert-equal #x0010000000000000
    261 
    +		(get-double-bits (ext:read-hex-float "0x1.0000000000000p-1022")))
    262 
    +  (assert-equal #x000fffffffffffff
    263 
    +		(get-double-bits (ext:read-hex-float "0x0.fffffffffffffp-1022")))
    264 
    +  (assert-equal #x001f0195cb356b8f
    265 
    +		(get-double-bits (ext:read-hex-float "0x1.f0195cb356b8fp-1022")))
    266 
    +
    267 
    +  ;; Single Precision (-126 Cliff)
    268 
    +
    269 
    +  (assert-equal #x00800000
    270 
    +		(get-single-bits (ext:read-hex-float "0x1.000000p-126f")))
    271 
    +  (assert-equal #x00400000
    272 
    +		(get-single-bits (ext:read-hex-float "0x0.800000p-126f")))
    273 
    +  (assert-equal #x7f7fffff
    274 
    +		(get-single-bits (ext:read-hex-float "0x1.fffffep+127f"))))
    275 
    +
    276 
    +(define-test test-double-roundtrip
    277 
    +  (:tag :stress)
    278 
    +  (loop repeat 10000 do
    279 
    +    (let* ((hi-bits (random #x100000000))
    280 
    +           (hi (if (logbitp 31 hi-bits) (- hi-bits #x100000000) hi-bits))
    281 
    +           (lo (random #x100000000))
    282 
    +           (val (kernel:make-double-float hi lo)))
    283 
    +      (unless (or (ext:float-nan-p val) (ext:float-infinity-p val))
    284 
    +        (let* ((str (ext:float-to-hex-string val))
    285 
    +               (parsed (ext:read-hex-float str)))
    286 
    +          (assert-equal (get-double-bits val)
    287 
    +			(get-double-bits parsed)
    288 
    +			val str parsed))))))
    289 
    +
    290 
    +(define-test test-single-roundtrip
    291 
    +  (:tag :stress)
    292 
    +  (loop repeat 10000 do
    293 
    +    (let* ((bits-raw (random #x100000000))
    294 
    +           (bits (if (logbitp 31 bits-raw) (- bits-raw #x100000000) bits-raw))
    295 
    +           (val (kernel:make-single-float bits)))
    296 
    +      (unless (or (ext:float-nan-p val) (ext:float-infinity-p val))
    297 
    +        (let* ((str (concatenate 'string (ext:float-to-hex-string val) "f"))
    298 
    +               (parsed (ext:read-hex-float str)))
    299 
    +          (assert-equal (get-single-bits val)
    300 
    +			(get-single-bits parsed)
    301 
    +			val str parsed))))))
    302 
    +

    • —
    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/d95ddfb90d55bce73e05175729a92f86847ae48a...528946709fcb5b5c50458fbcde43b70929852906 at 1773092431