Prepare to work around NaN issue
This commit is contained in:
parent
dfcfa62776
commit
3ccd95d68a
|
@ -0,0 +1,24 @@
|
||||||
|
#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")
|
||||||
|
|
||||||
|
(define (bytes->float bs)
|
||||||
|
(float (floating-point-bytes->real bs #t 0 4)))
|
||||||
|
|
||||||
|
(define (float->bytes v)
|
||||||
|
(real->floating-point-bytes (float-value 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))
|
|
@ -8,8 +8,8 @@
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
;; Representing values
|
;; Representing values
|
||||||
|
|
||||||
|
(require "float.rkt" "float-bytes.rkt")
|
||||||
(struct record (label fields) #:transparent)
|
(struct record (label fields) #:transparent)
|
||||||
(struct float (value) #:transparent) ;; a marker for single-precision I/O
|
|
||||||
(struct annotated (annotations item) #:transparent)
|
(struct annotated (annotations item) #:transparent)
|
||||||
(struct embedded (value) #:transparent)
|
(struct embedded (value) #:transparent)
|
||||||
|
|
||||||
|
@ -23,8 +23,8 @@
|
||||||
(match (next-byte)
|
(match (next-byte)
|
||||||
[#x80 #f]
|
[#x80 #f]
|
||||||
[#x81 #t]
|
[#x81 #t]
|
||||||
[#x82 (float (floating-point-bytes->real (next-bytes 4) #t 0 4))]
|
[#x82 (bytes->float (next-bytes 4))]
|
||||||
[#x83 (floating-point-bytes->real (next-bytes 8) #t 0 8)]
|
[#x83 (bytes->double (next-bytes 8))]
|
||||||
[#x84 '#:end]
|
[#x84 '#:end]
|
||||||
[#x85 (let ((a (next)))
|
[#x85 (let ((a (next)))
|
||||||
(match (next)
|
(match (next)
|
||||||
|
@ -80,8 +80,8 @@
|
||||||
(match v
|
(match v
|
||||||
[#f (write-byte #x80 out-port)]
|
[#f (write-byte #x80 out-port)]
|
||||||
[#t (write-byte #x81 out-port)]
|
[#t (write-byte #x81 out-port)]
|
||||||
[(float v) (write-byte #x82 out-port) (output-bytes (real->floating-point-bytes v 4 #t))]
|
[(float _) (write-byte #x82 out-port) (output-bytes (float->bytes v))]
|
||||||
[(? flonum?) (write-byte #x83 out-port) (output-bytes (real->floating-point-bytes v 8 #t))]
|
[(? flonum?) (write-byte #x83 out-port) (output-bytes (double->bytes v))]
|
||||||
|
|
||||||
[(annotated as v)
|
[(annotated as v)
|
||||||
(for [(a (in-list as))] (write-byte #x85 out-port) (output a))
|
(for [(a (in-list as))] (write-byte #x85 out-port) (output a))
|
||||||
|
|
|
@ -7,6 +7,7 @@
|
||||||
(require "record.rkt")
|
(require "record.rkt")
|
||||||
(require "embedded.rkt")
|
(require "embedded.rkt")
|
||||||
(require "float.rkt")
|
(require "float.rkt")
|
||||||
|
(require "float-bytes.rkt")
|
||||||
(require "annotation.rkt")
|
(require "annotation.rkt")
|
||||||
(require "varint.rkt")
|
(require "varint.rkt")
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
|
@ -70,8 +71,8 @@
|
||||||
(match lead-byte
|
(match lead-byte
|
||||||
[#x80 #f]
|
[#x80 #f]
|
||||||
[#x81 #t]
|
[#x81 #t]
|
||||||
[#x82 (float (floating-point-bytes->real (next-bytes 4) #t 0 4))]
|
[#x82 (bytes->float (next-bytes 4))]
|
||||||
[#x83 (floating-point-bytes->real (next-bytes 8) #t 0 8)]
|
[#x83 (bytes->double (next-bytes 8))]
|
||||||
[#x84 '#:end]
|
[#x84 '#:end]
|
||||||
[#x85 (let ((a (next)))
|
[#x85 (let ((a (next)))
|
||||||
(if read-annotations?
|
(if read-annotations?
|
||||||
|
|
|
@ -10,6 +10,7 @@
|
||||||
(require "read-binary.rkt")
|
(require "read-binary.rkt")
|
||||||
(require "record.rkt")
|
(require "record.rkt")
|
||||||
(require "float.rkt")
|
(require "float.rkt")
|
||||||
|
(require "float-bytes.rkt")
|
||||||
(require syntax/readerr)
|
(require syntax/readerr)
|
||||||
(require (only-in file/sha1 hex-string->bytes))
|
(require (only-in file/sha1 hex-string->bytes))
|
||||||
(require (only-in net/base64 base64-decode))
|
(require (only-in net/base64 base64-decode))
|
||||||
|
@ -82,8 +83,8 @@
|
||||||
[#\" (read-literal-binary)]
|
[#\" (read-literal-binary)]
|
||||||
[#\x (match (next-char)
|
[#\x (match (next-char)
|
||||||
[#\" (read-hex-binary '())]
|
[#\" (read-hex-binary '())]
|
||||||
[#\f (float (read-hex-float 4))]
|
[#\f (read-hex-float 'float)]
|
||||||
[#\d (read-hex-float 8)]
|
[#\d (read-hex-float 'double)]
|
||||||
[c (parse-error "Invalid #x syntax: ~v" c)])]
|
[c (parse-error "Invalid #x syntax: ~v" c)])]
|
||||||
[#\[ (read-base64-binary '())]
|
[#\[ (read-base64-binary '())]
|
||||||
[#\! (embedded (decode-embedded (next)))]
|
[#\! (embedded (decode-embedded (next)))]
|
||||||
|
@ -228,13 +229,15 @@
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
;; Hex-encoded floating point numbers
|
;; Hex-encoded floating point numbers
|
||||||
|
|
||||||
(define (read-hex-float byte-count)
|
(define (read-hex-float precision)
|
||||||
(unless (eqv? (next-char) #\")
|
(unless (eqv? (next-char) #\")
|
||||||
(parse-error "Missing open-double-quote in hex-encoded floating-point number"))
|
(parse-error "Missing open-double-quote in hex-encoded floating-point number"))
|
||||||
(define bs (read-hex-binary '()))
|
(define bs (read-hex-binary '()))
|
||||||
(unless (= (bytes-length bs) byte-count)
|
(unless (= (bytes-length bs) (match precision ['float 4] ['double 8]))
|
||||||
(parse-error "Incorrect number of bytes in hex-encoded floating-point number"))
|
(parse-error "Incorrect number of bytes in hex-encoded floating-point number"))
|
||||||
(floating-point-bytes->real bs #t 0 byte-count))
|
(match precision
|
||||||
|
['float (bytes->float bs)]
|
||||||
|
['double (bytes->double bs)]))
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
;; Base64-encoded ByteStrings
|
;; Base64-encoded ByteStrings
|
||||||
|
|
|
@ -8,6 +8,7 @@
|
||||||
(require "record.rkt")
|
(require "record.rkt")
|
||||||
(require "embedded.rkt")
|
(require "embedded.rkt")
|
||||||
(require "float.rkt")
|
(require "float.rkt")
|
||||||
|
(require "float-bytes.rkt")
|
||||||
(require "annotation.rkt")
|
(require "annotation.rkt")
|
||||||
(require "varint.rkt")
|
(require "varint.rkt")
|
||||||
(require "object-id.rkt")
|
(require "object-id.rkt")
|
||||||
|
@ -86,12 +87,12 @@
|
||||||
[#f (output-byte #x80)]
|
[#f (output-byte #x80)]
|
||||||
[#t (output-byte #x81)]
|
[#t (output-byte #x81)]
|
||||||
|
|
||||||
[(float v)
|
[(float _)
|
||||||
(output-byte #x82)
|
(output-byte #x82)
|
||||||
(output-bytes (real->floating-point-bytes v 4 #t))]
|
(output-bytes (float->bytes v))]
|
||||||
[(? flonum?)
|
[(? flonum?)
|
||||||
(output-byte #x83)
|
(output-byte #x83)
|
||||||
(output-bytes (real->floating-point-bytes v 8 #t))]
|
(output-bytes (double->bytes v))]
|
||||||
|
|
||||||
[(annotated as _ v)
|
[(annotated as _ v)
|
||||||
(when write-annotations?
|
(when write-annotations?
|
||||||
|
|
|
@ -12,6 +12,7 @@
|
||||||
(require "embedded.rkt")
|
(require "embedded.rkt")
|
||||||
(require "annotation.rkt")
|
(require "annotation.rkt")
|
||||||
(require "float.rkt")
|
(require "float.rkt")
|
||||||
|
(require "float-bytes.rkt")
|
||||||
(require "record.rkt")
|
(require "record.rkt")
|
||||||
(require "object-id.rkt")
|
(require "object-id.rkt")
|
||||||
(require racket/dict)
|
(require racket/dict)
|
||||||
|
@ -134,12 +135,14 @@
|
||||||
(write-binary-stringlike v)
|
(write-binary-stringlike v)
|
||||||
(write-binary-base64 outer-distance v)))))
|
(write-binary-base64 outer-distance v)))))
|
||||||
|
|
||||||
(define (write-float v byte-count hextype suffix)
|
(define (write-float v precision)
|
||||||
(if (or (nan? v) (infinite? v))
|
(if (or (nan? v) (infinite? v))
|
||||||
(! "#x~a\"~a\""
|
(! "#x~a\"~a\""
|
||||||
hextype
|
(match precision ['float "f"] ['double "d"])
|
||||||
(bytes->hex-string (real->floating-point-bytes v byte-count #t)))
|
(bytes->hex-string (match precision
|
||||||
(! "~v~a" v suffix)))
|
['float (float->bytes (float v))]
|
||||||
|
['double (double->bytes v)])))
|
||||||
|
(! "~v~a" v (match precision ['float "f"] ['double ""]))))
|
||||||
|
|
||||||
(define (write-value distance v)
|
(define (write-value distance v)
|
||||||
(match v
|
(match v
|
||||||
|
@ -152,8 +155,8 @@
|
||||||
(write-value distance item)]
|
(write-value distance item)]
|
||||||
[#f (! "#f")]
|
[#f (! "#f")]
|
||||||
[#t (! "#t")]
|
[#t (! "#t")]
|
||||||
[(float v) (write-float v 4 "f" "f")]
|
[(float v) (write-float v 'float)]
|
||||||
[(? flonum?) (write-float v 8 "d" "")]
|
[(? flonum?) (write-float v 'double)]
|
||||||
[(? integer? x) (! "~v" v)]
|
[(? integer? x) (! "~v" v)]
|
||||||
[(? string?)
|
[(? string?)
|
||||||
(! "\"")
|
(! "\"")
|
||||||
|
|
Loading…
Reference in New Issue