;io-utils.lisp
(in-package :common-lisp-user)
(defpackage :io-utils
(:use :common-lisp )
(:export "IEEE-754-TO-FLOAT-64"
"IEEE-754-TO-FLOAT-32"
"FLOAT-32-TO-IEEE-754"
"FLOAT-64-TO-IEEE-754"
"READ-U4-BIGENDIAN"
"READ-U4-LITTLEENDIAN"
"READ-U2-BIGENDIAN"
"READ-FLOAT32-BIGENDIAN"
"READ-FLOAT32-LITTLEENDIAN"
))
; see http://babbage.cs.qc.edu/IEEE-754/
(in-package :io-utils)
(defun read-u2 (in)
(let ((u2 0))
(setf (ldb (byte 8 8) u2) (read-byte in))
(setf (ldb (byte 8 0) u2) (read-byte in))
u2))
(defun read-u4-littleendian (in)
(let ((u4 0))
(setf (ldb (byte 8 24) u4) (read-byte in))
(setf (ldb (byte 8 16) u4) (read-byte in))
(setf (ldb (byte 8 8) u4) (read-byte in))
(setf (ldb (byte 8 0) u4) (read-byte in))
u4))
(defun read-u4-bigendian (in)
(let ((u4 0))
(setf (ldb (byte 8 0) u4) (read-byte in))
(setf (ldb (byte 8 8) u4) (read-byte in))
(setf (ldb (byte 8 16) u4) (read-byte in))
(setf (ldb (byte 8 24) u4) (read-byte in))
u4))
(defmacro gen-ieee-encoding (name type exponent-bits mantissa-bits)
`(progn
(defun ,(intern (format nil "~A-TO-IEEE-754" name)) (float)
(multiple-value-bind (significand expon sgn)
(integer-decode-float float)
(let* ((slen (integer-length significand))
(delta (- slen ,(1+ mantissa-bits)))
(sgn-norm (ash significand delta))
(ex (- (+ ,(+ mantissa-bits (1- (expt 2 (1- exponent-bits))) )
expon)
delta))
(output (if (minusp sgn) (dpb 1 (byte 1 ,(+ mantissa-bits
exponent-bits)) 0)
0))
(final (if (not (plusp ex))
(dpb (ldb (byte ,mantissa-bits 0) (ash sgn-norm (1- ex)))
(byte ,mantissa-bits 0) output)
;; or else .
(dpb (ldb (byte ,mantissa-bits 0) sgn-norm) (byte
,mantissa-bits 0)
(dpb ex (byte ,exponent-bits ,mantissa-bits) output)))))
final)))
(defun ,(intern (format nil "IEEE-754-TO-~A" name)) (ieee)
(let* ((ex (ldb (byte ,exponent-bits ,mantissa-bits) ieee))
(sig (ldb (byte ,mantissa-bits 0) ieee))
(significand (if (zerop ex)
(ash sig 1)
(dpb 1 (byte 1 ,mantissa-bits) sig)))
(ssigned (if (logbitp ,(+ exponent-bits mantissa-bits) ieee)
(- significand)
significand))
(aval
(scale-float (coerce ssigned ,type)
(- ex
,(+ (1- (expt 2 (1- exponent-bits)))
(1- mantissa-bits)
1
) ))))
aval))
))
(gen-ieee-encoding float-32 'single-float 8 23)
(gen-ieee-encoding float-64 'double-float 11 52)
(defun read-float32-bigendian (in)
(ieee-754-to-float-32 (read-u4-bigendian in)))
(defun read-float32-littleendian (in)
(ieee-754-to-float-32 (read-u4-littleendian in)))
; second file -- tests
;tests.lisp
(in-package :common-lisp-user)
(defpackage :io-tests
(:use :common-lisp :io-utils :lisp-unit))
(in-package :io-tests )
(defmacro f32-to-hex (hex flt)
`(assert-equal ,hex (format nil "~X" (float-32-to-ieee-754 ,flt))))
(defmacro hex-to-f32 (hex flt)
`(assert-equal (ieee-754-to-float-32 (parse-integer ,hex :radix 16))
,flt))
(defmacro f64-to-hex (hex flt)
`(assert-equal ,hex (format nil "~X" (float-64-to-ieee-754 ,flt))))
(defmacro hex-to-f64 (hex flt)
`(assert-equal (ieee-754-to-float-64 (parse-integer ,hex :radix 16))
,flt))
(eval-when (:compile-toplevel :load-toplevel)
(defparameter *testf32* '("3F800000" 1.0
"BF800000" -1.0
"A4FB11E" 9.9999995e-33
"3FC00000" 1.5
"2C9" 1.0e-42
"749DC5AD" 9.999999e31
"43AC8000" 345.0
"47A39100" 83746.0
"47" 9.9492191e-44
"6CE3EE" 9.9999994e-39
"AE397" 9.9999881e-40
))
(defparameter *testf64*
'("37D5C72FB1552D83" 1.0d-39
"1A56E1FC2F8F359" 1.0d-300
"7E8" 1.0d-320
"7E37E43C8800759C" 1.0d300
"6979CE4AE6ED0F27" 1.23456789d+200
"4A551E3E787F1976" 1.23456789d+50
)
))
(defmacro to-float-32 ( )
`(define-test hex-to-f32-test
,@(loop for (hex flt) on *testf32* by #'cddr collect `(hex-to-f32
,hex ,flt))))
(defmacro from-float-32 ( )
`(define-test f32-to-hex-test
,@(loop for (hex flt) on *testf32* by #'cddr collect `(f32-to-hex
,hex ,flt))))
(defmacro to-float-64 ( )
`(define-test hex-to-f64-test
,@(loop for (hex flt) on *testf64* by #'cddr collect `(hex-to-f64
,hex ,flt))))
(defmacro from-float-64 ( )
`(define-test f64-to-hex-test
,@(loop for (hex flt) on *testf64* by #'cddr collect `(f64-to-hex
,hex ,flt))))
; see examples here http://babbage.cs.qc.edu/IEEE-754/
(to-float-32)
(from-float-32)
(to-float-64)
(from-float-64)