supporting non-native endianness and non-finite floating values

lib/chibi/bytevector.sld

@@ -9,12 +9,16 @@
    integer->bytevector bytevector->integer
    integer->hex-string hex-string->integer
    bytevector->hex-string hex-string->bytevector
+   bytevector-ieee-single-ref
    bytevector-ieee-single-native-ref
+   bytevector-ieee-single-set!
    bytevector-ieee-single-native-set!
+   bytevector-ieee-double-ref
    bytevector-ieee-double-native-ref
+   bytevector-ieee-double-set!
    bytevector-ieee-double-native-set!
    )
-  (import (scheme base))
+  (import (scheme base) (scheme inexact))
   (cond-expand
    (big-endian
     (begin

lib/chibi/ieee-754.scm

@@ -1,6 +1,6 @@
 ;;; Copyright (c) 2004-2018 by Alex Shinn.
 
-;; Adapted from SRFI-56.
+;; Adapted from SRFI 56.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; syntax
@@ -12,6 +12,22 @@
     ((combine b1 b2 b3 ...)
      (combine (+ (arithmetic-shift b1 8) b2) b3 ...))))
 
+(define-syntax bytes-u8-set-all!
+  (syntax-rules ()
+    ((_) bv off i)
+    ((_ bv off i b1) (bytevector-u8-set! bv (+ off i) b1))
+    ((_ bv off i b1 b2 b3 ...)
+     (begin
+       (bytevector-u8-set! bv (+ off i) b1)
+       (bytes-u8-set-all! bv off (+ i 1) b2 b3 ...)))))
+
+(define-syntax bytevector-u8-set-all!
+  (syntax-rules ()
+    ((_ bvapp iapp b1 ...)
+     (let ((bv bvapp)
+           (i iapp))
+       (bytes-u8-set-all! bv i 0 b1 ...)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; reading floating point numbers
 
@@ -26,12 +42,11 @@
 ;;   http://babbage.cs.qc.edu/courses/cs341/IEEE-754references.html
 ;; as references to IEEE 754.
 
-(define (bytevector-ieee-single-native-ref bytevector k)
+(define (bytevector-ieee-single-ref bytevector k endianness)
   (define (mantissa expn b2 b3 b4)
-      (case expn   ; recognize special literal exponents
+    (case expn
-        ((255)
+      ((255)     ; special exponents
-         ;;(if (zero? (combine b2 b3 b4)) +/0. 0/0.) ; XXXX for SRFI-70
+       (if (zero? (combine b2 b3 b4)) (/ 1. 0.) (/ 0. 0.)))
-         #f)
       ((0)       ; denormalized
        (inexact (* (expt 2.0 (- 1 (+ 127 23))) (combine b2 b3 b4))))
       (else
@@ -44,20 +59,24 @@
         (mantissa (* 2 b1) b2 b3 b4)))
   (define (sign b1 b2 b3 b4)
     (if (> b1 127)  ; 1st bit of b1 is sign
-        (cond ((exponent (- b1 128) b2 b3 b4) => -) (else #f))
+        (- (exponent (- b1 128) b2 b3 b4))
         (exponent b1 b2 b3 b4)))
   (let* ((b1 (bytevector-u8-ref bytevector (+ k 0)))
          (b2 (bytevector-u8-ref bytevector (+ k 1)))
          (b3 (bytevector-u8-ref bytevector (+ k 2)))
          (b4 (bytevector-u8-ref bytevector (+ k 3))))
-      (if (eq? (native-endianness) 'big)
+    (if (eq? endianness 'big)
         (sign b1 b2 b3 b4)
         (sign b4 b3 b2 b1))))
 
-(define (bytevector-ieee-double-native-ref bytevector k)
+(define (bytevector-ieee-single-native-ref bytevector k)
+  (bytevector-ieee-single-ref bytevector k (native-endianness)))
+
+(define (bytevector-ieee-double-ref bytevector k endianness)
   (define (mantissa expn b2 b3 b4 b5 b6 b7 b8)
-      (case expn   ; recognize special literal exponents
+    (case expn
-        ((255) #f) ; won't handle NaN and +/- Inf
+      ((255)     ; special exponents
+       (if (zero? (combine b2 b3 b4 b5 b6 b7 b8)) (/ 1. 0.) (/ 0. 0.)))
       ((0)       ; denormalized
        (inexact (* (expt 2.0 (- 1 (+ 1023 52)))
                    (combine b2 b3 b4 b5 b6 b7 b8))))
@@ -72,8 +91,7 @@
               b3 b4 b5 b6 b7 b8))
   (define (sign b1 b2 b3 b4 b5 b6 b7 b8)
     (if (> b1 127)  ; 1st bit of b1 is sign
-        (cond ((exponent (- b1 128) b2 b3 b4 b5 b6 b7 b8) => -)
+        (- (exponent (- b1 128) b2 b3 b4 b5 b6 b7 b8))
-              (else #f))
         (exponent b1 b2 b3 b4 b5 b6 b7 b8)))
   (let* ((b1 (bytevector-u8-ref bytevector (+ k 0)))
          (b2 (bytevector-u8-ref bytevector (+ k 1)))
@@ -83,10 +101,13 @@
          (b6 (bytevector-u8-ref bytevector (+ k 5)))
          (b7 (bytevector-u8-ref bytevector (+ k 6)))
          (b8 (bytevector-u8-ref bytevector (+ k 7))))
-      (if (eq? (native-endianness) 'big)
+    (if (eq? endianness 'big)
         (sign b1 b2 b3 b4 b5 b6 b7 b8)
         (sign b8 b7 b6 b5 b4 b3 b2 b1))))
 
+(define (bytevector-ieee-double-native-ref bytevector k)
+  (bytevector-ieee-double-ref bytevector k (native-endianness)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; writing floating point numbers
 
@@ -117,8 +138,12 @@
          (else
           (proc (exact (round n)) e))))))))
 
-(define (bytevector-ieee-single-native-set! bytevector k num)
+(define (bytevector-ieee-single-set! bytevector k num endianness)
-    (define (bytes)
+  (define output
+    (if (eq? endianness 'big)
+        (lambda (b1 b2 b3 b4) (bytevector-u8-set-all! bytevector k b1 b2 b3 b4))
+        (lambda (b1 b2 b3 b4) (bytevector-u8-set-all! bytevector k b4 b3 b2 b1))))
+  (define (compute)
     (call-with-mantissa&exponent num 2 23 8
       (lambda (f e)
         (let ((e0 (+ e 127 23)))
@@ -128,9 +153,9 @@
                    (b2 (bit-field f1 16 24))        ; mant:16-23
                    (b3 (bit-field f1 8 16))         ; mant:8-15
                    (b4 (bit-field f1 0 8)))         ; mant:0-7
-                 (list (if (negative? num) 128 0) b2 b3 b4)))
+              (output (if (negative? num) 128 0) b2 b3 b4)))
-              ((> e0 255) ; XXXX here we just write infinity
+           ((> e0 255)  ; infinity
-               (list (if (negative? num) 255 127) 128 0 0))
+            (output (if (negative? num) 255 127) 128 0 0))
            (else
             (let* ((b0 (arithmetic-shift e0 -1))
                    (b1 (if (negative? num) (+ b0 128) b0)) ; sign + exp:1-7
@@ -139,18 +164,23 @@
                         (bit-field f 16 23)))              ;   + mant:16-23
                    (b3 (bit-field f 8 16))                 ; mant:8-15
                    (b4 (bit-field f 0 8)))                 ; mant:0-7
-                 (list b1 b2 b3 b4))))))))
+              (output b1 b2 b3 b4))))))))
-      (let ((result (cond
+  (cond
-                      ((zero? num) '(0 0 0 0))
+   ((zero? num) (output 0 0 0 0))
-                      ((eq? (native-endianness) 'big) (bytes))
+   ((nan? num) (output #xff #xff #xff #xff))
-                      (else (reverse (bytes))))))
+   (else (compute))))
-       (bytevector-u8-set! bytevector (+ k 0) (list-ref result 0))
-       (bytevector-u8-set! bytevector (+ k 1) (list-ref result 1))
-       (bytevector-u8-set! bytevector (+ k 2) (list-ref result 2))
-       (bytevector-u8-set! bytevector (+ k 3) (list-ref result 3))))
 
-(define (bytevector-ieee-double-native-set! bytevector k num)
+(define (bytevector-ieee-single-native-set! bytevector k num)
-    (define (bytes)
+  (bytevector-ieee-single-set! bytevector k num (native-endianness)))
+
+(define (bytevector-ieee-double-set! bytevector k num endianness)
+  (define output
+    (if (eq? endianness 'big)
+        (lambda (b1 b2 b3 b4 b5 b6 b7 b8)
+          (bytevector-u8-set-all! bytevector k b1 b2 b3 b4 b5 b6 b7 b8))
+        (lambda (b1 b2 b3 b4 b5 b6 b7 b8)
+          (bytevector-u8-set-all! bytevector k b8 b7 b6 b5 b4 b3 b2 b1))))
+  (define (compute)
     (call-with-mantissa&exponent num 2 52 11
       (lambda (f e)
         (let ((e0 (+ e 1023 52)))
@@ -164,9 +194,9 @@
                    (b6 (bit-field f1 16 24))
                    (b7 (bit-field f1 8 16))
                    (b8 (bit-field f1 0 8)))
-                 (list (if (negative? num) 128 0) b2 b3 b4 b5 b6 b7 b8)))
+              (output (if (negative? num) 128 0) b2 b3 b4 b5 b6 b7 b8)))
            ((> e0 4095) ; infinity
-               (list (if (negative? num) 255 127) 224 0 0 0 0 0 0))
+            (output (if (negative? num) 255 127) 224 0 0 0 0 0 0))
            (else
             (let* ((b0 (bit-field e0 4 11))
                    (b1 (if (negative? num) (+ b0 128) b0))
@@ -180,16 +210,15 @@
                    (b6 (bit-field f 16 24))
                    (b7 (bit-field f 8 16))
                    (b8 (bit-field f 0 8)))
-                 (list b1 b2 b3 b4 b5 b6 b7 b8))))))))
+              (output b1 b2 b3 b4 b5 b6 b7 b8))))))))
-      (let ((result (cond
+  (cond
-                      ((zero? num) '(0 0 0 0 0 0 0 0))
+   ((zero? num) (output 0 0 0 0 0 0 0 0))
-                      ((eq? (native-endianness) 'big) (bytes))
+   ((nan? num) (output #xff #xff #xff #xff #xff #xff #xff #xff))
-                      (else (reverse (bytes))))))
+   (else (compute))))
-       (bytevector-u8-set! bytevector (+ k 0) (list-ref result 0))
+
-       (bytevector-u8-set! bytevector (+ k 1) (list-ref result 1))
+(define (bytevector-ieee-double-native-set! bytevector k num)
-       (bytevector-u8-set! bytevector (+ k 2) (list-ref result 2))
+  (bytevector-ieee-double-set! bytevector k num (native-endianness)))
-       (bytevector-u8-set! bytevector (+ k 3) (list-ref result 3))
+
-       (bytevector-u8-set! bytevector (+ k 4) (list-ref result 4))
+;; Local Variables:
-       (bytevector-u8-set! bytevector (+ k 5) (list-ref result 5))
+;; eval: (put 'call-with-mantissa&exponent 'scheme-indent-function 4)
-       (bytevector-u8-set! bytevector (+ k 6) (list-ref result 6))
+;; End:
-       (bytevector-u8-set! bytevector (+ k 7) (list-ref result 7))))