floats.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2 ;;;
   3 ;;;; Copyright (c) 2003,2004 David Lichteblau <david@lichteblau.com>
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8 ;;;
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11 ;;;
  12 ;;;   * Redistributions in binary form must reproduce the above
  13 ;;;     copyright notice, this list of conditions and the following
  14 ;;;     disclaimer in the documentation and/or other materials
  15 ;;;     provided with the distribution.
  16 ;;;
  17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29 (in-package :cxml-types)
  30
  31 (defun do-not-constant-fold-me (x) x)
  32
  33 #-(or sbcl allegro)
  34 (defun float< (a b)
  35   (cond
  36     ((and (numberp a) (numberp b))
  37      (< a b))
  38     ((member a '(single-float-nan double-float-nan))
  39      nil)
  40     ((member b '(single-float-nan double-float-nan))
  41      nil)
  42     ((member a '(single-float-negative-infinity
  43                  double-float-negative-infinity))
  44      (not (member b '(single-float-negative-infinity
  45                       double-float-negative-infinity))))
  46     ((member b '(single-float-positive-infinity
  47                  double-float-positive-infinity))
  48      (not (member a '(single-float-positive-infinity
  49                       double-float-positive-infinity))))
  50     (t
  51      nil)))
  52
  53 #-(or sbcl allegro)
  54 (defun float= (a b)
  55   (cond
  56     ((and (numberp a) (numberp b))
  57      (= a b))
  58     ((eq a b)
  59      t)
  60     ((member a '(single-float-nan double-float-nan))
  61      (member b '(single-float-nan double-float-nan)))
  62     ((member b '(single-float-nan double-float-nan))
  63      nil)
  64     (t
  65      nil)))
  66
  67 (defparameter single-float-positive-infinity
  68   #+sbcl sb-ext:single-float-positive-infinity
  69   #+allegro excl::*infinity-single*
  70   #-(or sbcl allegro) 'single-float-positive-infinity)
  71
  72 (defparameter single-float-negative-infinity
  73   #+sbcl sb-ext:single-float-negative-infinity
  74   #+allegro excl::*negative-infinity-single*
  75   #-(or sbcl allegro) 'single-float-negative-infinity)
  76
  77 (defparameter double-float-positive-infinity
  78   #+sbcl sb-ext:double-float-positive-infinity
  79   #+allegro excl::*infinity-double*
  80   #-(or sbcl allegro) 'double-float-positive-infinity)
  81
  82 (defparameter double-float-negative-infinity
  83   #+sbcl sb-ext:double-float-negative-infinity
  84   #+allegro excl::*negative-infinity-double*
  85   #-(or sbcl allegro) 'double-float-negative-infinity)
  86
  87 (defparameter double-float-nan
  88   #+sbcl (let ((orig (sb-int:get-floating-point-modes)))
  89            (unwind-protect
  90                 (progn
  91                   (sb-int:set-floating-point-modes :traps nil)
  92                   (/ 0.0d0 (do-not-constant-fold-me 0.0d0)))
  93              (apply #'sb-int:set-floating-point-modes orig)))
  94   #+allegro excl::*nan-double*
  95   #-(or sbcl allegro) 'double-float-nan)
  96
  97 (defparameter single-float-nan
  98   #+sbcl (let ((orig (sb-int:get-floating-point-modes)))
  99            (unwind-protect
 100                 (progn
 101                   (sb-int:set-floating-point-modes :traps nil)
 102                   (/ 0.0f0 (do-not-constant-fold-me 0.0f0)))
 103              (apply #'sb-int:set-floating-point-modes orig)))
 104   #+allegro excl::*nan-single*
 105   #-(or sbcl allegro) 'single-float-nan)