102 lines
3.6 KiB
Racket
102 lines
3.6 KiB
Racket
#lang racket/base
|
|
;; Conversion between binary32 and binary64 big-endian external format (byte-vectors) and
|
|
;; internal double-precision floating-point numbers, with special attention paid to
|
|
;; preservation of the quiet/signaling bit of NaNs, which otherwise is frequently disturbed by
|
|
;; hardware-level conversion between single and double precision.
|
|
|
|
(provide bytes->float
|
|
float->bytes
|
|
bytes->double
|
|
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)
|
|
(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)
|
|
(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")
|
|
)
|