Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

109 lines (92 sloc) 4.076 kb
;;; :FILE-CREATED <Timestamp: #{2011-08-30T21:18:02-04:00Z}#{11352} - by MON>
;;; :FILE tiff4cl-FORK/tiff4cl-floats.lisp
;;; ==============================
;;; ==============================
;;; code.lisp --- IEEE floating point encoding/decoding
;;; Copyright (C) 2009 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <walter@pelissero.de>
;;; Project: ie3fp
#+cmu (ext:file-comment "$Module: code.lisp $")
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA
;;; Code inspired by work done by Marijn Haverbeke.
;;; The original code can be found here:
;;; http://common-lisp.net/project/ieee-floats/
;; (defpackage :ie3fp
;; (:nicknames :ieee-754)
;; (:use :common-lisp)
;; (:export #:make-encoder
;; #:make-decoder
;; #:encode-IEEE-float
;; #:decode-IEEE-float
;; #:encode-IEEE-double
;; #:decode-IEEE-double
;; #:encode-IEEE-quad
;; #:decode-IEEE-quad))
;; (in-package :ie3fp)
(in-package #:tiff4cl)
(defmacro make-encoder (name exponent-length significand-length)
(let ((total-length (+ 1 exponent-length significand-length)))
`(defun ,name (float)
(declare (float float)
(optimize (speed 3) (debug 0) (safety 0)))
(multiple-value-bind (significand exponent sign) (integer-decode-float float)
(declare (type integer significand)
(type fixnum exponent sign))
(let* ((len (integer-length significand))
(delta (- ,significand-length len)))
(setf exponent (+ exponent (1- len) ,(1- (expt 2 (1- exponent-length)))))
(unless (< exponent ,(expt 2 exponent-length))
(error "Floating point number ~A too big; can't be encoded with ~A bit exponent."
float ,exponent-length))
(if (< exponent 0)
(setf significand (ash (logand (ash significand delta)
,(1- (expt 2 significand-length)))
exponent)
exponent 0)
(setf significand (logand (ash significand (1+ delta))
,(1- (expt 2 significand-length)))))
(let ((encoded 0))
(declare (type (unsigned-byte ,total-length) encoded))
(setf (ldb (byte 1 ,(1- total-length)) encoded) (if (= sign 1) 0 1)
(ldb (byte ,exponent-length ,significand-length) encoded) exponent
(ldb (byte ,significand-length 0) encoded) significand)
encoded))))))
(defmacro make-decoder (name exponent-length significand-length)
(let ((total-length (+ 1 exponent-length significand-length)))
`(defun ,name (encoded)
(declare (type (unsigned-byte ,total-length) encoded)
(optimize (speed 3) (debug 0) (safety 0)))
(let ((negative (ldb (byte 1 ,(1- total-length)) encoded))
(exponent (ldb (byte ,exponent-length ,significand-length) encoded))
(significand (ldb (byte ,significand-length 0) encoded)))
(if (zerop exponent)
(setf exponent 1)
;; add the "hidden bit"
(setf (ldb (byte 1 ,significand-length) significand) 1))
(scale-float (float (if (zerop negative)
significand
(- significand))
,(if (> total-length 32)
1.0d0
1.0))
(- exponent ,(+ (1- (expt 2 (1- exponent-length)))
significand-length)))))))
(make-encoder encode-ieee-float 8 23)
(make-decoder decode-ieee-float 8 23)
(make-encoder encode-ieee-double 11 52)
(make-decoder decode-ieee-double 11 52)
(make-encoder encode-IEEE-quad 15 112)
(make-decoder decode-IEEE-quad 15 112)
;;; ==============================
;;; EOF
Jump to Line
Something went wrong with that request. Please try again.