cl-postgres/ieee-floats.lisp

   1 ;;; Functions for converting floating point numbers represented in
   2 ;;; IEEE 754 style to lisp numbers.
   3 ;;;
   4 ;;; See http://common-lisp.net/project/ieee-floats/
   5
   6 (defpackage :cl-postgres-ieee-floats
   7   (:use :common-lisp)
   8   (:export :make-float-converters
   9            :encode-float32
  10            :decode-float32
  11            :encode-float64
  12            :decode-float64))
  13
  14 (in-package :cl-postgres-ieee-floats)
  15
  16 ;; The following macro may look a bit overcomplicated to the casual
  17 ;; reader. The main culprit is the fact that NaN and infinity can be
  18 ;; optionally included, which adds a bunch of conditional parts.
  19 ;;
  20 ;; Assuming you already know more or less how floating point numbers
  21 ;; are typically represented, I'll try to elaborate a bit on the more
  22 ;; confusing parts, as marked by letters:
  23 ;;
  24 ;; (A) Exponents in IEEE floats are offset by half their range, for
  25 ;;     example with 8 exponent bits a number with exponent 2 has 129
  26 ;;     stored in its exponent field.
  27 ;;
  28 ;; (B) The maximum possible exponent is reserved for special cases
  29 ;;     (NaN, infinity).
  30 ;;
  31 ;; (C) If the exponent fits in the exponent-bits, we have to adjust
  32 ;;     the significand for the hidden bit. Because decode-float will
  33 ;;     return a significand between 0 and 1, and we want one between 1
  34 ;;     and 2 to be able to hide the hidden bit, we double it and then
  35 ;;     subtract one (the hidden bit) before converting it to integer
  36 ;;     representation (to adjust for this, 1 is subtracted from the
  37 ;;     exponent earlier). When the exponent is too small, we set it to
  38 ;;     zero (meaning no hidden bit, exponent of 1), and adjust the
  39 ;;     significand downward to compensate for this.
  40 ;;
  41 ;; (D) Here the hidden bit is added. When the exponent is 0, there is
  42 ;;     no hidden bit, and the exponent is interpreted as 1.
  43 ;;
  44 ;; (E) Here the exponent offset is subtracted, but also an extra
  45 ;;     factor to account for the fact that the bits stored in the
  46 ;;     significand are supposed to come after the 'decimal dot'.
  47
  48 (defmacro make-float-converters (encoder-name
  49                                  decoder-name
  50                                  exponent-bits
  51                                  significand-bits
  52                                  support-nan-and-infinity-p)
  53   "Writes an encoder and decoder function for floating point
  54 numbers with the given amount of exponent and significand
  55 bits (plus an extra sign bit). If support-nan-and-infinity-p is
  56 true, the decoders will also understand these special cases. NaN
  57 is represented as :not-a-number, and the infinities as
  58 :positive-infinity and :negative-infinity. Note that this means
  59 that the in- or output of these functions is not just floating
  60 point numbers anymore, but also keywords."
  61   (let* ((total-bits (+ 1 exponent-bits significand-bits))
  62          (exponent-offset (1- (expt 2 (1- exponent-bits)))) ; (A)
  63          (sign-part `(ldb (byte 1 ,(1- total-bits)) bits))
  64          (exponent-part `(ldb (byte ,exponent-bits ,significand-bits) bits))
  65          (significand-part `(ldb (byte ,significand-bits 0) bits))
  66          (nan support-nan-and-infinity-p)
  67          (max-exponent (1- (expt 2 exponent-bits)))) ; (B)
  68     `(progn
  69        (defun ,encoder-name (float)
  70          ,@(unless nan `((declare (type float float))))
  71          (multiple-value-bind (sign significand exponent)
  72              (cond ,@(when nan `(((eq float :not-a-number)
  73                                   (values 0 1 ,max-exponent))
  74                                  ((eq float :positive-infinity)
  75                                   (values 0 0 ,max-exponent))
  76                                  ((eq float :negative-infinity)
  77                                   (values 1 0 ,max-exponent))))
  78                    ((zerop float)
  79                     (values 0 0 0))
  80                    (t
  81                     (multiple-value-bind (significand exponent sign) (decode-float float)
  82                       (let ((exponent (+ (1- exponent) ,exponent-offset))
  83                             (sign (if (= sign 1.0) 0 1)))
  84                         (unless (< exponent ,(expt 2 exponent-bits))
  85                           (error "Floating point overflow when encoding ~A." float))
  86                         (if (< exponent 0) ; (C)
  87                             (values sign (ash (round (* ,(expt 2 significand-bits) significand)) exponent) 0)
  88                             (values sign (round (* ,(expt 2 significand-bits) (1- (* significand 2)))) exponent))))))
  89            (let ((bits 0))
  90              (declare (type (unsigned-byte ,total-bits) bits))
  91              (setf ,sign-part sign
  92                    ,exponent-part exponent
  93                    ,significand-part significand)
  94              bits)))
  95
  96        (defun ,decoder-name (bits)
  97          (declare (type (unsigned-byte ,total-bits) bits))
  98          (let* ((sign ,sign-part)
  99                 (exponent ,exponent-part)
 100                 (significand ,significand-part))
 101            ,@(when nan `((when (= exponent ,max-exponent)
 102                            (return-from ,decoder-name
 103                              (cond ((not (zerop significand)) :not-a-number)
 104                                    ((zerop sign) :positive-infinity)
 105                                    (t :negative-infinity))))))
 106            (if (zerop exponent) ; (D)
 107                (setf exponent 1)
 108                (setf (ldb (byte 1 ,significand-bits) significand) 1))
 109            (unless (zerop sign)
 110              (setf significand (- significand)))
 111            (scale-float (float significand ,(if (> total-bits 32) 1.0d0 1.0))
 112                         (- exponent ,(+ exponent-offset significand-bits)))))))) ; (E)
 113
 114 ;; And instances of the above for the common forms of floats.
 115 (make-float-converters encode-float32 decode-float32 8 23 nil)
 116 (make-float-converters encode-float64 decode-float64 11 52 nil)
 117
 118 ;;; Copyright (c) 2006 Marijn Haverbeke
 119 ;;;
 120 ;;; This software is provided 'as-is', without any express or implied
 121 ;;; warranty. In no event will the authors be held liable for any
 122 ;;; damages arising from the use of this software.
 123 ;;;
 124 ;;; Permission is granted to anyone to use this software for any
 125 ;;; purpose, including commercial applications, and to alter it and
 126 ;;; redistribute it freely, subject to the following restrictions:
 127 ;;;
 128 ;;; 1. The origin of this software must not be misrepresented; you must
 129 ;;;    not claim that you wrote the original software. If you use this
 130 ;;;    software in a product, an acknowledgment in the product
 131 ;;;    documentation would be appreciated but is not required.
 132 ;;;
 133 ;;; 2. Altered source versions must be plainly marked as such, and must
 134 ;;;    not be misrepresented as being the original software.
 135 ;;;
 136 ;;; 3. This notice may not be removed or altered from any source
 137 ;;;    distribution.