Permalink
Browse files

:ADDED :FILE tiff4cl-floats.lisp

  • Loading branch information...
mon-key committed Aug 31, 2011
1 parent 5ee57d6 commit 6649a456f3044e75b71e6a506fcf5654c0b5ee64
Showing with 158 additions and 97 deletions.
  1. +17 −33 package.lisp
  2. +108 −0 tiff4cl-floats.lisp
  3. +20 −35 tiff4cl-util.lisp
  4. +13 −29 tiff4cl.asd
View
@@ -1,36 +1,20 @@
-;;; package.lisp --- package definition
-
-;;; Copyright (C) 2009 by Walter C. Pelissero
-
-;;; Author: Walter C. Pelissero <walter@pelissero.de>
-;;; Project: tiff4cl
-
-#+cmu (ext:file-comment "$Module: package.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
+;;; :FILE-CREATED <Timestamp: #{2011-08-30T21:18:53-04:00Z}#{11352} - by MON>
+;;; :FILE tiff4cl-FORK/package.lisp
+;;; ==============================
(in-package :cl-user)
-(defpackage :tiff4cl
- (:nicknames :tiff)
- (:use :common-lisp)
- (:export #:parse-TIFF
- #:print-TIFF-tags
- #:map-TIFF-tags
- #:TIFF-extract-tags
- ;; accessors
- #:ifd-tags
- #:tag-id
- #:tag-type
- #:tag-value))
+(defpackage #:tiff4cl (:use #:common-lisp)
+ ;; (:nicknames :tiff)
+ (:export #:parse-tiff
+ #:print-tiff-tags
+ #:map-tiff-tags
+ #:tiff-extract-tags
+ ;; accessors
+ #:ifd-tags
+ #:tag-id
+ #:tag-type
+ #:tag-value))
+
+;;; ==============================
+;;; EOF
View
@@ -0,0 +1,108 @@
+;;; :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
View
@@ -1,26 +1,13 @@
- ;;; util.lisp --- various helper functions
+;;; :FILE-CREATED <Timestamp: #{2011-08-30T21:23:57-04:00Z}#{11352} - by MON>
+;;; :FILE tiff4cl-FORK/tiff4cl-util.lisp
+;;; ==============================
- ;;; Copyright (C) 2009 by Walter C. Pelissero
+(in-package #:tiff4cl)
- ;;; Author: Walter C. Pelissero <walter@pelissero.de>
- ;;; Project: tiff4cl
-
-#+cmu (ext:file-comment "$Module: util.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
-
-(in-package :tiff4cl)
+;; :SEE info node (info "(sbcl)Defining Constants")
+(defmacro define-constant (name value &optional doc)
+ `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
+ ,@(when doc (list doc))))
(defmacro make-read-sequence (name buffer)
`(defun ,name (stream length &key (eof-errorp t) eof-value)
@@ -35,12 +22,7 @@
(make-read-sequence read-bytes (make-sequence '(vector (unsigned-byte 8)) length))
;; (make-read-sequence read-string (make-string length))
-;; :SEE info node (info "(sbcl)Defining Constants")
-(defmacro define-constant (name value &optional doc)
- `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value)
- ,@(when doc (list doc))))
-
-(defun decode-integer-BE (sequence &key (start 0) end)
+(defun decode-integer-be (sequence &key (start 0) end)
"Decode a big-endian sequence of bytes as an integer and return it."
(loop
with value = 0
@@ -49,7 +31,7 @@
(elt sequence i)))
finally (return value)))
-(defun decode-integer-LE (sequence &key (start 0) end)
+(defun decode-integer-le (sequence &key (start 0) end)
"Decode a big-endian sequence of bytes as an integer and return it."
(loop
with value = 0
@@ -58,15 +40,18 @@
(elt sequence i)))
finally (return value)))
-(defun read-16bit-BE (stream)
- (decode-integer-BE (read-bytes stream 2)))
+(defun read-16bit-be (stream)
+ (decode-integer-be (read-bytes stream 2)))
(defun read-16bit-LE (stream)
- (decode-integer-LE (read-bytes stream 2)))
+ (decode-integer-le (read-bytes stream 2)))
+
+(defun read-32bit-be (stream)
+ (decode-integer-be (read-bytes stream 4)))
-(defun read-32bit-BE (stream)
- (decode-integer-BE (read-bytes stream 4)))
+(defun read-32bit-le (stream)
+ (decode-integer-le (read-bytes stream 4)))
-(defun read-32bit-LE (stream)
- (decode-integer-LE (read-bytes stream 4)))
+;;; ==============================
+;;; EOF
View
@@ -1,46 +1,30 @@
-;;; tiff4cl.asd --- system definition
-
-;;; Copyright (C) 2009 by Walter C. Pelissero
-
-;;; Author: Walter C. Pelissero <walter@pelissero.de>
-;;; Project: TIFF4CL
-
-#+cmu (ext:file-comment "$Module: tiff4cl.asd, Time-stamp: <2009-05-28 18:13:35 wcp> $")
-
-;;; 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
+;;; :FILE-CREATED <Timestamp: #{2011-08-30T21:22:21-04:00Z}#{11352} - by MON>
+;;; :FILE tiff4cl-FORK/tiff4cl.asd
+;;; ==============================
(in-package :cl-user)
-(defpackage :tiff4cl-system
- (:use :common-lisp :asdf))
+(defpackage #:tiff4cl-system (:use :common-lisp :asdf))
-(in-package :tiff4cl-system)
+(in-package #:tiff4cl-system)
-(defsystem tiff4cl
+(defsystem :tiff4cl
:name "TIFF4CL"
:author "Walter C. Pelissero <walter@pelissero.de>"
:maintainer "Walter C. Pelissero <walter@pelissero.de>"
;; :version "0.0"
:description "TIFF access primitives"
- :long-description
- "A TIFF file parser that reads the tags leaving the actual image data alone."
+ :long-description "A TIFF file parser that reads the tags leaving the actual image data alone."
:licence "LGPL"
- :depends-on (:ie3fp)
+ ;; :depends-on (:ie3fp) ;; `ieee-754:decode-ieee-float'
:serial t
:components
((:file "package")
(:file "tiff4cl-util")
(:file "tiff4cl-specials")
(:file "tiff4cl-conditions")
- (:file "tiff4cl")))
+ (:file "tiff4cl-floats")
+ (:file "tiff4cl-tiff")))
+
+;;; ==============================
+;;; EOF

0 comments on commit 6649a45

Please sign in to comment.