Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

supporting non-native endianness and non-finite floating values

Browse source
This commit is contained in:
Alex Shinn 2018-12-06 23:25:18 +08:00
parent 9af77c9b4f
commit 3aae0e8481
2 changed files with 175 additions and 142 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
lib/chibi/bytevector.sld
View file

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

119
lib/chibi/ieee-754.scm
View file

@ -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
((255)
;;(if (zero? (combine b2 b3 b4)) +/0. 0/0.) ; XXXX for SRFI-70
#f)
(case expn
((255) ; special exponents
(if (zero? (combine b2 b3 b4)) (/ 1. 0.) (/ 0. 0.)))
((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
((255) #f) ; won't handle NaN and +/- Inf
(case expn
((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) => -)
(else #f))
(- (exponent (- b1 128) b2 b3 b4 b5 b6 b7 b8))
(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 (bytes)
(define (bytevector-ieee-single-set! bytevector k num endianness)
(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)))
((> e0 255) ; XXXX here we just write infinity
(list (if (negative? num) 255 127) 128 0 0))
(output (if (negative? num) 128 0) b2 b3 b4)))
((> e0 255) ; infinity
(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))))))))
(let ((result (cond
((zero? num) '(0 0 0 0))
((eq? (native-endianness) 'big) (bytes))
(else (reverse (bytes))))))
(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))))
(output b1 b2 b3 b4))))))))
(cond
((zero? num) (output 0 0 0 0))
((nan? num) (output #xff #xff #xff #xff))
(else (compute))))
(define (bytevector-ieee-double-native-set! bytevector k num)
(define (bytes)
(define (bytevector-ieee-single-native-set! bytevector k num)
(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))))))))
(let ((result (cond
((zero? num) '(0 0 0 0 0 0 0 0))
((eq? (native-endianness) 'big) (bytes))
(else (reverse (bytes))))))
(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))
(bytevector-u8-set! bytevector (+ k 4) (list-ref result 4))
(bytevector-u8-set! bytevector (+ k 5) (list-ref result 5))
(bytevector-u8-set! bytevector (+ k 6) (list-ref result 6))
(bytevector-u8-set! bytevector (+ k 7) (list-ref result 7))))
(output b1 b2 b3 b4 b5 b6 b7 b8))))))))
(cond
((zero? num) (output 0 0 0 0 0 0 0 0))
((nan? num) (output #xff #xff #xff #xff #xff #xff #xff #xff))
(else (compute))))
(define (bytevector-ieee-double-native-set! bytevector k num)
(bytevector-ieee-double-set! bytevector k num (native-endianness)))
;; Local Variables:
;; eval: (put 'call-with-mantissa&exponent 'scheme-indent-function 4)
;; End: