cl-postgres/ieee-floats.lisp

   1 ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-IEEE-FLOATS; -*-
   2 (in-package :cl-postgres-ieee-floats)
   3
   4 ;;; Functions for converting floating point numbers represented in
   5 ;;; IEEE 754 style to lisp numbers.
   6 ;;;
   7 ;;; See http://common-lisp.net/project/ieee-floats/
   8
   9 ;; The following macro may look a bit overcomplicated to the casual
  10 ;; reader. The main culprit is the fact that NaN and infinity can be
  11 ;; optionally included, which adds a bunch of conditional parts.
  12 ;;
  13 ;; Assuming you already know more or less how floating point numbers
  14 ;; are typically represented, I'll try to elaborate a bit on the more
  15 ;; confusing parts, as marked by letters:
  16 ;;
  17 ;; (A) Exponents in IEEE floats are offset by half their range, for
  18 ;;     example with 8 exponent bits a number with exponent 2 has 129
  19 ;;     stored in its exponent field.
  20 ;;
  21 ;; (B) The maximum possible exponent is reserved for special cases
  22 ;;     (NaN, infinity).
  23 ;;
  24 ;; (C) If the exponent fits in the exponent-bits, we have to adjust
  25 ;;     the significand for the hidden bit. Because decode-float will
  26 ;;     return a significand between 0 and 1, and we want one between 1
  27 ;;     and 2 to be able to hide the hidden bit, we double it and then
  28 ;;     subtract one (the hidden bit) before converting it to integer
  29 ;;     representation (to adjust for this, 1 is subtracted from the
  30 ;;     exponent earlier). When the exponent is too small, we set it to
  31 ;;     zero (meaning no hidden bit, exponent of 1), and adjust the
  32 ;;     significand downward to compensate for this.
  33 ;;
  34 ;; (D) Here the hidden bit is added. When the exponent is 0, there is
  35 ;;     no hidden bit, and the exponent is interpreted as 1.
  36 ;;
  37 ;; (E) Here the exponent offset is subtracted, but also an extra
  38 ;;     factor to account for the fact that the bits stored in the
  39 ;;     significand are supposed to come after the 'decimal dot'.
  40
  41 (defmacro make-float-converters (encoder-name
  42                                  decoder-name
  43                                  exponent-bits
  44                                  significand-bits
  45                                  support-nan-and-infinity-p)
  46   "Writes an encoder and decoder function for floating point
  47 numbers with the given amount of exponent and significand
  48 bits (plus an extra sign bit). If support-nan-and-infinity-p is
  49 true, the decoders will also understand these special cases. NaN
  50 is represented as :not-a-number, and the infinities as
  51 :positive-infinity and :negative-infinity. Note that this means
  52 that the in- or output of these functions is not just floating
  53 point numbers anymore, but also keywords."
  54   (let* ((total-bits (+ 1 exponent-bits significand-bits))
  55          (exponent-offset (1- (expt 2 (1- exponent-bits)))) ; (A)
  56          (sign-part `(ldb (byte 1 ,(1- total-bits)) bits))
  57          (exponent-part `(ldb (byte ,exponent-bits ,significand-bits) bits))
  58          (significand-part `(ldb (byte ,significand-bits 0) bits))
  59          (nan support-nan-and-infinity-p)
  60          (max-exponent (1- (expt 2 exponent-bits)))) ; (B)
  61     `(progn
  62        (defun ,encoder-name (float)
  63          ,@(unless nan `((declare (type float float))))
  64          (multiple-value-bind (sign significand exponent)
  65              (cond ,@(when nan `(((eq float :not-a-number)
  66                                   (values 0 1 ,max-exponent))
  67                                  ((eq float :positive-infinity)
  68                                   (values 0 0 ,max-exponent))
  69                                  ((eq float :negative-infinity)
  70                                   (values 1 0 ,max-exponent))))
  71                    ((zerop float)
  72                     (values 0 0 0))
  73                    (t
  74                     (multiple-value-bind (significand exponent sign)
  75                         (decode-float float)
  76                       (let ((exponent (+ (1- exponent) ,exponent-offset))
  77                             (sign (if (= sign 1.0) 0 1)))
  78                         (unless (< exponent ,(expt 2 exponent-bits))
  79                           (error "Floating point overflow when encoding ~A."
  80                                  float))
  81                         (if (< exponent 0) ; (C)
  82                             (values sign (ash (round (* ,(expt 2 significand-bits)
  83                                                         significand))
  84                                               exponent)
  85                                     0)
  86                             (values sign (round (* ,(expt 2 significand-bits)
  87                                                    (1- (* significand 2))))
  88                                     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.