Preserve sign and payload of 32-bit NaNs
This commit is contained in:
parent
3ccd95d68a
commit
9eee54be80
|
@ -10,15 +10,92 @@
|
|||
double->bytes)
|
||||
|
||||
(require "float.rkt")
|
||||
(require (only-in racket/math nan? infinite?))
|
||||
|
||||
(module binary racket/base
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (binary32-nan-or-inf? bs)
|
||||
(and (= (bitwise-bit-field (bytes-ref bs 0) 0 7) #x7f)
|
||||
(bitwise-bit-set? (bytes-ref bs 1) 7)))
|
||||
|
||||
(define (binary64-nan-or-inf? bs)
|
||||
(and (= (bitwise-bit-field (bytes-ref bs 0) 0 7) #x7f)
|
||||
(= (bitwise-bit-field (bytes-ref bs 1) 4 8) #x0f)))
|
||||
|
||||
(define (sign-bit-set? bs)
|
||||
(bitwise-bit-set? (bytes-ref bs 0) 0)))
|
||||
|
||||
(require (submod "." binary))
|
||||
|
||||
(define (bytes->float bs)
|
||||
(float (floating-point-bytes->real bs #t 0 4)))
|
||||
(if (binary32-nan-or-inf? bs)
|
||||
(let* ((vf (integer-bytes->integer bs #f #t))
|
||||
(signexp (bitwise-bit-field vf 23 32))
|
||||
(payload (bitwise-bit-field vf 0 23))
|
||||
(vd (bitwise-ior (arithmetic-shift signexp 55)
|
||||
#x0070000000000000
|
||||
(arithmetic-shift payload 29)))
|
||||
(dbs (integer->integer-bytes vd 8 #f #t)))
|
||||
(float (floating-point-bytes->real dbs #t 0 8)))
|
||||
(float (floating-point-bytes->real bs #t 0 4))))
|
||||
|
||||
(define (float->bytes v)
|
||||
(real->floating-point-bytes (float-value v) 4 #t))
|
||||
(let ((v (float-value v)))
|
||||
(if (or (nan? v) (infinite? v))
|
||||
(let* ((dbs (real->floating-point-bytes v 8 #t))
|
||||
(vd (integer-bytes->integer dbs #f #t))
|
||||
(signexp (bitwise-bit-field vd 55 64))
|
||||
(payload (bitwise-bit-field vd 29 52))
|
||||
(vf (bitwise-ior (arithmetic-shift signexp 23)
|
||||
payload))
|
||||
(bs (integer->integer-bytes vf 4 #f #t)))
|
||||
bs)
|
||||
(real->floating-point-bytes v 4 #t))))
|
||||
|
||||
(define (bytes->double bs)
|
||||
(floating-point-bytes->real bs #t 0 8))
|
||||
|
||||
(define (double->bytes v)
|
||||
(real->floating-point-bytes v 8 #t))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(require file/sha1)
|
||||
|
||||
(define (check-roundtrip-double hex)
|
||||
(check-equal? (bytes->hex-string (double->bytes (bytes->double (hex-string->bytes hex))))
|
||||
hex))
|
||||
|
||||
(define (check-roundtrip-float hex)
|
||||
(check-equal? (bytes->hex-string (float->bytes (bytes->float (hex-string->bytes hex))))
|
||||
hex))
|
||||
|
||||
(check-roundtrip-double "0123456789abcdef")
|
||||
(check-roundtrip-double "7ff0000000000321")
|
||||
(check-roundtrip-double "7ff0000000000001")
|
||||
(check-roundtrip-double "7ff0000000000000")
|
||||
(check-roundtrip-double "fff0000000000321")
|
||||
(check-roundtrip-double "fff0000000000001")
|
||||
(check-roundtrip-double "fff0000000000000")
|
||||
(check-roundtrip-double "7ff8000000000321")
|
||||
(check-roundtrip-double "7ff8000000000001")
|
||||
(check-roundtrip-double "7ff8000000000000")
|
||||
(check-roundtrip-double "fff8000000000321")
|
||||
(check-roundtrip-double "fff8000000000001")
|
||||
(check-roundtrip-double "fff8000000000000")
|
||||
|
||||
(check-roundtrip-float "01234567")
|
||||
(check-roundtrip-float "7f800321")
|
||||
(check-roundtrip-float "7f800001")
|
||||
(check-roundtrip-float "7f800000")
|
||||
(check-roundtrip-float "ff800321")
|
||||
(check-roundtrip-float "ff800001")
|
||||
(check-roundtrip-float "ff800000")
|
||||
(check-roundtrip-float "7fc00321")
|
||||
(check-roundtrip-float "7fc00001")
|
||||
(check-roundtrip-float "7fc00000")
|
||||
(check-roundtrip-float "ffc00321")
|
||||
(check-roundtrip-float "ffc00001")
|
||||
(check-roundtrip-float "ffc00000")
|
||||
)
|
||||
|
|
Loading…
Reference in New Issue