syndicate-lang
/
preserves
mirror of https://gitlab.com/preserves/preserves.git
1
0
Fork 1
Code Releases Activity

Prepare to work around NaN issue

This commit is contained in:
Tony Garnock-Jones 2022-11-07 10:22:12 +01:00
parent dfcfa62776
commit 3ccd95d68a
6 changed files with 53 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
implementations/racket/preserves/preserves/float-bytes.rkt Normal file
View File

@ -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))

10
implementations/racket/preserves/preserves/jelly.rkt
View File

@ -8,8 +8,8 @@
;;---------------------------------------------------------------------------
;; Representing values
(require "float.rkt" "float-bytes.rkt")
(struct record (label fields) #:transparent)
(struct float (value) #:transparent) ;; a marker for single-precision I/O
(struct annotated (annotations item) #:transparent)
(struct embedded (value) #:transparent)
@ -23,8 +23,8 @@
(match (next-byte)
[#x80 #f]
[#x81 #t]
[#x82 (float (floating-point-bytes->real (next-bytes 4) #t 0 4))]
[#x83 (floating-point-bytes->real (next-bytes 8) #t 0 8)]
[#x82 (bytes->float (next-bytes 4))]
[#x83 (bytes->double (next-bytes 8))]
[#x84 '#:end]
[#x85 (let ((a (next)))
(match (next)
@ -80,8 +80,8 @@
(match v
[#f (write-byte #x80 out-port)]
[#t (write-byte #x81 out-port)]
[(float v) (write-byte #x82 out-port) (output-bytes (real->floating-point-bytes v 4 #t))]
[(? flonum?) (write-byte #x83 out-port) (output-bytes (real->floating-point-bytes v 8 #t))]
[(float _) (write-byte #x82 out-port) (output-bytes (float->bytes v))]
[(? flonum?) (write-byte #x83 out-port) (output-bytes (double->bytes v))]
[(annotated as v)
(for [(a (in-list as))] (write-byte #x85 out-port) (output a))

5
implementations/racket/preserves/preserves/read-binary.rkt
View File

@ -7,6 +7,7 @@
(require "record.rkt")
(require "embedded.rkt")
(require "float.rkt")
(require "float-bytes.rkt")
(require "annotation.rkt")
(require "varint.rkt")
(require racket/set)
@ -70,8 +71,8 @@
(match lead-byte
[#x80 #f]
[#x81 #t]
[#x82 (float (floating-point-bytes->real (next-bytes 4) #t 0 4))]
[#x83 (floating-point-bytes->real (next-bytes 8) #t 0 8)]
[#x82 (bytes->float (next-bytes 4))]
[#x83 (bytes->double (next-bytes 8))]
[#x84 '#:end]
[#x85 (let ((a (next)))
(if read-annotations?

13
implementations/racket/preserves/preserves/read-text.rkt
View File

@ -10,6 +10,7 @@
(require "read-binary.rkt")
(require "record.rkt")
(require "float.rkt")
(require "float-bytes.rkt")
(require syntax/readerr)
(require (only-in file/sha1 hex-string->bytes))
(require (only-in net/base64 base64-decode))
@ -82,8 +83,8 @@
[#\" (read-literal-binary)]
[#\x (match (next-char)
[#\" (read-hex-binary '())]
[#\f (float (read-hex-float 4))]
[#\d (read-hex-float 8)]
[#\f (read-hex-float 'float)]
[#\d (read-hex-float 'double)]
[c (parse-error "Invalid #x syntax: ~v" c)])]
[#\[ (read-base64-binary '())]
[#\! (embedded (decode-embedded (next)))]
@ -228,13 +229,15 @@
;;---------------------------------------------------------------------------
;; Hex-encoded floating point numbers
(define (read-hex-float byte-count)
(define (read-hex-float precision)
(unless (eqv? (next-char) #\")
(parse-error "Missing open-double-quote in hex-encoded floating-point number"))
(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"))
(floating-point-bytes->real bs #t 0 byte-count))
(match precision
['float (bytes->float bs)]
['double (bytes->double bs)]))
;;---------------------------------------------------------------------------
;; Base64-encoded ByteStrings

7
implementations/racket/preserves/preserves/write-binary.rkt
View File

@ -8,6 +8,7 @@
(require "record.rkt")
(require "embedded.rkt")
(require "float.rkt")
(require "float-bytes.rkt")
(require "annotation.rkt")
(require "varint.rkt")
(require "object-id.rkt")
@ -86,12 +87,12 @@
[#f (output-byte #x80)]
[#t (output-byte #x81)]
[(float v)
[(float _)
(output-byte #x82)
(output-bytes (real->floating-point-bytes v 4 #t))]
(output-bytes (float->bytes v))]
[(? flonum?)
(output-byte #x83)
(output-bytes (real->floating-point-bytes v 8 #t))]
(output-bytes (double->bytes v))]
[(annotated as _ v)
(when write-annotations?

15
implementations/racket/preserves/preserves/write-text.rkt
View File

@ -12,6 +12,7 @@
(require "embedded.rkt")
(require "annotation.rkt")
(require "float.rkt")
(require "float-bytes.rkt")
(require "record.rkt")
(require "object-id.rkt")
(require racket/dict)
@ -134,12 +135,14 @@
(write-binary-stringlike 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))
(! "#x~a\"~a\""
hextype
(bytes->hex-string (real->floating-point-bytes v byte-count #t)))
(! "~v~a" v suffix)))
(match precision ['float "f"] ['double "d"])
(bytes->hex-string (match precision
['float (float->bytes (float v))]
['double (double->bytes v)])))
(! "~v~a" v (match precision ['float "f"] ['double ""]))))
(define (write-value distance v)
(match v
@ -152,8 +155,8 @@
(write-value distance item)]
[#f (! "#f")]
[#t (! "#t")]
[(float v) (write-float v 4 "f" "f")]
[(? flonum?) (write-float v 8 "d" "")]
[(float v) (write-float v 'float)]
[(? flonum?) (write-float v 'double)]
[(? integer? x) (! "~v" v)]
[(? string?)
(! "\"")