#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")
  )