mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
supporting non-native endianness and non-finite floating values
This commit is contained in:
Alex Shinn
parent
9af77c9b4f
commit
3aae0e8481
2 changed files with 175 additions and 142 deletions
|
|
@ -9,12 +9,16 @@
|
||||||
integer->bytevector bytevector->integer
|
integer->bytevector bytevector->integer
|
||||||
integer->hex-string hex-string->integer
|
integer->hex-string hex-string->integer
|
||||||
bytevector->hex-string hex-string->bytevector
|
bytevector->hex-string hex-string->bytevector
|
||||||
|
bytevector-ieee-single-ref
|
||||||
bytevector-ieee-single-native-ref
|
bytevector-ieee-single-native-ref
|
||||||
|
bytevector-ieee-single-set!
|
||||||
bytevector-ieee-single-native-set!
|
bytevector-ieee-single-native-set!
|
||||||
|
bytevector-ieee-double-ref
|
||||||
bytevector-ieee-double-native-ref
|
bytevector-ieee-double-native-ref
|
||||||
|
bytevector-ieee-double-set!
|
||||||
bytevector-ieee-double-native-set!
|
bytevector-ieee-double-native-set!
|
||||||
)
|
)
|
||||||
(import (scheme base))
|
(import (scheme base) (scheme inexact))
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(big-endian
|
(big-endian
|
||||||
(begin
|
(begin
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
;;; Copyright (c) 2004-2018 by Alex Shinn.
|
;;; Copyright (c) 2004-2018 by Alex Shinn.
|
||||||
|
|
||||||
;; Adapted from SRFI-56.
|
;; Adapted from SRFI 56.
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; syntax
|
;; syntax
|
||||||
|
|
@ -12,6 +12,22 @@
|
||||||
((combine b1 b2 b3 ...)
|
((combine b1 b2 b3 ...)
|
||||||
(combine (+ (arithmetic-shift b1 8) 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
|
;; reading floating point numbers
|
||||||
|
|
||||||
|
|
@ -26,66 +42,71 @@
|
||||||
;; http://babbage.cs.qc.edu/courses/cs341/IEEE-754references.html
|
;; http://babbage.cs.qc.edu/courses/cs341/IEEE-754references.html
|
||||||
;; as references to IEEE 754.
|
;; 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)
|
(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
|
||||||
((0) ; denormalized
|
(inexact (* (expt 2.0 (- 1 (+ 127 23))) (combine b2 b3 b4))))
|
||||||
(inexact (* (expt 2.0 (- 1 (+ 127 23))) (combine b2 b3 b4))))
|
(else
|
||||||
(else
|
(inexact
|
||||||
(inexact
|
(* (expt 2.0 (- expn (+ 127 23)))
|
||||||
(* (expt 2.0 (- expn (+ 127 23)))
|
(combine (+ b2 128) b3 b4)))))) ; hidden bit
|
||||||
(combine (+ b2 128) b3 b4)))))) ; hidden bit
|
(define (exponent b1 b2 b3 b4)
|
||||||
(define (exponent b1 b2 b3 b4)
|
(if (> b2 127) ; 1st bit of b2 is low bit of expn
|
||||||
(if (> b2 127) ; 1st bit of b2 is low bit of expn
|
|
||||||
(mantissa (+ (* 2 b1) 1) (- b2 128) b3 b4)
|
(mantissa (+ (* 2 b1) 1) (- b2 128) b3 b4)
|
||||||
(mantissa (* 2 b1) b2 b3 b4)))
|
(mantissa (* 2 b1) b2 b3 b4)))
|
||||||
(define (sign b1 b2 b3 b4)
|
(define (sign b1 b2 b3 b4)
|
||||||
(if (> b1 127) ; 1st bit of b1 is sign
|
(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)))
|
(exponent b1 b2 b3 b4)))
|
||||||
(let* ((b1 (bytevector-u8-ref bytevector (+ k 0)))
|
(let* ((b1 (bytevector-u8-ref bytevector (+ k 0)))
|
||||||
(b2 (bytevector-u8-ref bytevector (+ k 1)))
|
(b2 (bytevector-u8-ref bytevector (+ k 1)))
|
||||||
(b3 (bytevector-u8-ref bytevector (+ k 2)))
|
(b3 (bytevector-u8-ref bytevector (+ k 2)))
|
||||||
(b4 (bytevector-u8-ref bytevector (+ k 3))))
|
(b4 (bytevector-u8-ref bytevector (+ k 3))))
|
||||||
(if (eq? (native-endianness) 'big)
|
(if (eq? endianness 'big)
|
||||||
(sign b1 b2 b3 b4)
|
(sign b1 b2 b3 b4)
|
||||||
(sign b4 b3 b2 b1))))
|
(sign b4 b3 b2 b1))))
|
||||||
|
|
||||||
|
(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
|
||||||
|
((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))))
|
||||||
|
(else
|
||||||
|
(inexact
|
||||||
|
(* (expt 2.0 (- expn (+ 1023 52)))
|
||||||
|
(combine (+ b2 16) b3 b4 b5 b6 b7 b8)))))) ; hidden bit
|
||||||
|
(define (exponent b1 b2 b3 b4 b5 b6 b7 b8)
|
||||||
|
(mantissa (bitwise-ior (arithmetic-shift b1 4) ; 7 bits
|
||||||
|
(arithmetic-shift b2 -4)) ; + 4 bits
|
||||||
|
(bitwise-and b2 #b1111)
|
||||||
|
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
|
||||||
|
(- (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)))
|
||||||
|
(b3 (bytevector-u8-ref bytevector (+ k 2)))
|
||||||
|
(b4 (bytevector-u8-ref bytevector (+ k 3)))
|
||||||
|
(b5 (bytevector-u8-ref bytevector (+ k 4)))
|
||||||
|
(b6 (bytevector-u8-ref bytevector (+ k 5)))
|
||||||
|
(b7 (bytevector-u8-ref bytevector (+ k 6)))
|
||||||
|
(b8 (bytevector-u8-ref bytevector (+ k 7))))
|
||||||
|
(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)
|
(define (bytevector-ieee-double-native-ref bytevector k)
|
||||||
(define (mantissa expn b2 b3 b4 b5 b6 b7 b8)
|
(bytevector-ieee-double-ref bytevector k (native-endianness)))
|
||||||
(case expn ; recognize special literal exponents
|
|
||||||
((255) #f) ; won't handle NaN and +/- Inf
|
|
||||||
((0) ; denormalized
|
|
||||||
(inexact (* (expt 2.0 (- 1 (+ 1023 52)))
|
|
||||||
(combine b2 b3 b4 b5 b6 b7 b8))))
|
|
||||||
(else
|
|
||||||
(inexact
|
|
||||||
(* (expt 2.0 (- expn (+ 1023 52)))
|
|
||||||
(combine (+ b2 16) b3 b4 b5 b6 b7 b8)))))) ; hidden bit
|
|
||||||
(define (exponent b1 b2 b3 b4 b5 b6 b7 b8)
|
|
||||||
(mantissa (bitwise-ior (arithmetic-shift b1 4) ; 7 bits
|
|
||||||
(arithmetic-shift b2 -4)) ; + 4 bits
|
|
||||||
(bitwise-and b2 #b1111)
|
|
||||||
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 b2 b3 b4 b5 b6 b7 b8)))
|
|
||||||
(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)))
|
|
||||||
(b5 (bytevector-u8-ref bytevector (+ k 4)))
|
|
||||||
(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)
|
|
||||||
(sign b1 b2 b3 b4 b5 b6 b7 b8)
|
|
||||||
(sign b8 b7 b6 b5 b4 b3 b2 b1))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; writing floating point numbers
|
;; writing floating point numbers
|
||||||
|
|
@ -104,92 +125,100 @@
|
||||||
(cond
|
(cond
|
||||||
((negative? num)
|
((negative? num)
|
||||||
(call-with-mantissa&exponent (- num) base mant-size exp-size proc))
|
(call-with-mantissa&exponent (- num) base mant-size exp-size proc))
|
||||||
((zero? num) (proc 0 0))
|
((zero? num) (proc 0 0))
|
||||||
(else
|
(else
|
||||||
(let* ((bot (expt base mant-size))
|
(let* ((bot (expt base mant-size))
|
||||||
(top (* base bot)))
|
(top (* base bot)))
|
||||||
(let loop ((n (inexact num)) (e 0))
|
(let loop ((n (inexact num)) (e 0))
|
||||||
(cond
|
(cond
|
||||||
((>= n top)
|
((>= n top)
|
||||||
(loop (/ n base) (+ e 1)))
|
(loop (/ n base) (+ e 1)))
|
||||||
((< n bot)
|
((< n bot)
|
||||||
(loop (* n base) (- e 1)))
|
(loop (* n base) (- e 1)))
|
||||||
(else
|
(else
|
||||||
(proc (exact (round n)) e))))))))
|
(proc (exact (round n)) e))))))))
|
||||||
|
|
||||||
|
(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)))
|
||||||
|
(cond
|
||||||
|
((negative? e0)
|
||||||
|
(let* ((f1 (exact (round (* f (expt 2 (- e0 1))))))
|
||||||
|
(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
|
||||||
|
(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
|
||||||
|
(b2 (bitwise-ior
|
||||||
|
(if (odd? e0) 128 0) ; exp:0
|
||||||
|
(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
|
||||||
|
(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-single-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)))
|
||||||
(call-with-mantissa&exponent num 2 23 8
|
|
||||||
(lambda (f e)
|
(define (bytevector-ieee-double-set! bytevector k num endianness)
|
||||||
(let ((e0 (+ e 127 23)))
|
(define output
|
||||||
(cond
|
(if (eq? endianness 'big)
|
||||||
((negative? e0)
|
(lambda (b1 b2 b3 b4 b5 b6 b7 b8)
|
||||||
(let* ((f1 (exact (round (* f (expt 2 (- e0 1))))))
|
(bytevector-u8-set-all! bytevector k b1 b2 b3 b4 b5 b6 b7 b8))
|
||||||
(b2 (bit-field f1 16 24)) ; mant:16-23
|
(lambda (b1 b2 b3 b4 b5 b6 b7 b8)
|
||||||
(b3 (bit-field f1 8 16)) ; mant:8-15
|
(bytevector-u8-set-all! bytevector k b8 b7 b6 b5 b4 b3 b2 b1))))
|
||||||
(b4 (bit-field f1 0 8))) ; mant:0-7
|
(define (compute)
|
||||||
(list (if (negative? num) 128 0) b2 b3 b4)))
|
(call-with-mantissa&exponent num 2 52 11
|
||||||
((> e0 255) ; XXXX here we just write infinity
|
(lambda (f e)
|
||||||
(list (if (negative? num) 255 127) 128 0 0))
|
(let ((e0 (+ e 1023 52)))
|
||||||
(else
|
(cond
|
||||||
(let* ((b0 (arithmetic-shift e0 -1))
|
((negative? e0)
|
||||||
(b1 (if (negative? num) (+ b0 128) b0)) ; sign + exp:1-7
|
(let* ((f1 (exact (round (* f (expt 2 (- e0 1))))))
|
||||||
(b2 (bitwise-ior
|
(b2 (bit-field f1 48 52))
|
||||||
(if (odd? e0) 128 0) ; exp:0
|
(b3 (bit-field f1 40 48))
|
||||||
(bit-field f 16 23))) ; + mant:16-23
|
(b4 (bit-field f1 32 40))
|
||||||
(b3 (bit-field f 8 16)) ; mant:8-15
|
(b5 (bit-field f1 24 32))
|
||||||
(b4 (bit-field f 0 8))) ; mant:0-7
|
(b6 (bit-field f1 16 24))
|
||||||
(list b1 b2 b3 b4))))))))
|
(b7 (bit-field f1 8 16))
|
||||||
(let ((result (cond
|
(b8 (bit-field f1 0 8)))
|
||||||
((zero? num) '(0 0 0 0))
|
(output (if (negative? num) 128 0) b2 b3 b4 b5 b6 b7 b8)))
|
||||||
((eq? (native-endianness) 'big) (bytes))
|
((> e0 4095) ; infinity
|
||||||
(else (reverse (bytes))))))
|
(output (if (negative? num) 255 127) 224 0 0 0 0 0 0))
|
||||||
(bytevector-u8-set! bytevector (+ k 0) (list-ref result 0))
|
(else
|
||||||
(bytevector-u8-set! bytevector (+ k 1) (list-ref result 1))
|
(let* ((b0 (bit-field e0 4 11))
|
||||||
(bytevector-u8-set! bytevector (+ k 2) (list-ref result 2))
|
(b1 (if (negative? num) (+ b0 128) b0))
|
||||||
(bytevector-u8-set! bytevector (+ k 3) (list-ref result 3))))
|
(b2 (bitwise-ior (arithmetic-shift
|
||||||
|
(bit-field e0 0 4)
|
||||||
|
4)
|
||||||
|
(bit-field f 48 52)))
|
||||||
|
(b3 (bit-field f 40 48))
|
||||||
|
(b4 (bit-field f 32 40))
|
||||||
|
(b5 (bit-field f 24 32))
|
||||||
|
(b6 (bit-field f 16 24))
|
||||||
|
(b7 (bit-field f 8 16))
|
||||||
|
(b8 (bit-field f 0 8)))
|
||||||
|
(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)
|
(define (bytevector-ieee-double-native-set! bytevector k num)
|
||||||
(define (bytes)
|
(bytevector-ieee-double-set! bytevector k num (native-endianness)))
|
||||||
(call-with-mantissa&exponent num 2 52 11
|
|
||||||
(lambda (f e)
|
;; Local Variables:
|
||||||
(let ((e0 (+ e 1023 52)))
|
;; eval: (put 'call-with-mantissa&exponent 'scheme-indent-function 4)
|
||||||
(cond
|
;; End:
|
||||||
((negative? e0)
|
|
||||||
(let* ((f1 (exact (round (* f (expt 2 (- e0 1))))))
|
|
||||||
(b2 (bit-field f1 48 52))
|
|
||||||
(b3 (bit-field f1 40 48))
|
|
||||||
(b4 (bit-field f1 32 40))
|
|
||||||
(b5 (bit-field f1 24 32))
|
|
||||||
(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)))
|
|
||||||
((> e0 4095) ; infinity
|
|
||||||
(list (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))
|
|
||||||
(b2 (bitwise-ior (arithmetic-shift
|
|
||||||
(bit-field e0 0 4)
|
|
||||||
4)
|
|
||||||
(bit-field f 48 52)))
|
|
||||||
(b3 (bit-field f 40 48))
|
|
||||||
(b4 (bit-field f 32 40))
|
|
||||||
(b5 (bit-field f 24 32))
|
|
||||||
(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))))
|
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue