external/oct/qd-format.lisp

   1 ;;;; -*- Mode: lisp -*-
   2 ;;;;
   3 ;;;; Copyright (c) 2007 Raymond Toy
   4 ;;;;
   5 ;;;; Permission is hereby granted, free of charge, to any person
   6 ;;;; obtaining a copy of this software and associated documentation
   7 ;;;; files (the "Software"), to deal in the Software without
   8 ;;;; restriction, including without limitation the rights to use,
   9 ;;;; copy, modify, merge, publish, distribute, sublicense, and/or sell
  10 ;;;; copies of the Software, and to permit persons to whom the
  11 ;;;; Software is furnished to do so, subject to the following
  12 ;;;; conditions:
  13 ;;;;
  14 ;;;; The above copyright notice and this permission notice shall be
  15 ;;;; included in all copies or substantial portions of the Software.
  16 ;;;;
  17 ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  18 ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  19 ;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  20 ;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  21 ;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  22 ;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  23 ;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  24 ;;;; OTHER DEALINGS IN THE SOFTWARE.
  25
  26 (in-package #:qd)
  27
  28 (defun qd-scale-exponent (original-x)
  29   (let* ((x original-x))
  30     (multiple-value-bind (sig exponent)
  31         (decode-float x)
  32       (declare (ignore sig))
  33       (if (= x #q0)
  34           (values #q0 1)
  35           (let* ((ex (round (* exponent (log #q2 10))))
  36                  (x (if (minusp ex)
  37
  38                         (* x #q10.0q0 (expt #q10.0q0 (- (- ex) 1)))
  39                         (/ x #q10.0q0 (expt #q10.0q0 (1- ex))))))
  40             (do ((d #q10.0q0 (* d #q10.0q0))
  41                  (y x (/ x d))
  42                  (ex ex (1+ ex)))
  43                 ((< y #q1.0q0)
  44                  (do ((m #q10.0q0 (* m #q10.0q0))
  45                       (z y (* y m))
  46                       (ex ex (1- ex)))
  47                      ((>= z #q0.1q0)
  48                       (values z ex))))))))))
  49
  50 (defun decimal-string (n)
  51   (cl:write-to-string n :base 10 :radix nil :escape nil))
  52
  53 (defun qd-format-exp-aux (stream number w d e k ovf pad marker atsign)
  54   (multiple-value-bind (num expt)
  55       (qd-scale-exponent (abs number))
  56     (let* ((expt (- expt k))
  57            (estr (decimal-string (abs expt)))
  58            (elen (if e (max (length estr) e) (length estr)))
  59            (add-zero-p nil))
  60       (if (and w ovf e (> elen e))      ;exponent overflow
  61           (dotimes (i w)
  62             (write-char ovf stream))
  63           (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
  64                  (fmin (if (minusp k)
  65                            1
  66                            fdig))
  67                  (spaceleft (if w
  68                                 (- w 2 elen
  69                                    (if (or atsign (minusp (float-sign number)))
  70                                        1 0))
  71                                 nil)))
  72             (multiple-value-bind (fstr flen lpoint tpoint)
  73                 (qdi::qd-to-string (qd-value num) spaceleft fdig k fmin)
  74               (when (and d (zerop d)) (setq tpoint nil))
  75               (when w
  76                 (decf spaceleft flen)
  77                 ;; See CLHS 22.3.3.2.  "If the parameter d is
  78                 ;; omitted, ... [and] if the fraction to be
  79                 ;; printed is zero then a single zero digit should
  80                 ;; appear after the decimal point."  So we need to
  81                 ;; subtract one from here because we're going to
  82                 ;; add an extra 0 digit later.
  83                 (when (and (null d) (char= (aref fstr (1- flen)) #\.))
  84                   (setf add-zero-p t)
  85                   (decf spaceleft))
  86                 (when lpoint
  87                   (if (or (> spaceleft 0) tpoint)
  88                       (decf spaceleft)
  89                       (setq lpoint nil)))
  90                 (when (and tpoint (<= spaceleft 0))
  91                   (setq tpoint nil)))
  92               (cond ((and w (< spaceleft 0) ovf)
  93                      ;;significand overflow
  94                      (dotimes (i w) (write-char ovf stream)))
  95                     (t (when w
  96                          (dotimes (i spaceleft)
  97                            (write-char pad stream)))
  98                        (if (minusp (float-sign number))
  99                            (write-char #\- stream)
 100                            (if atsign (write-char #\+ stream)))
 101                        (when lpoint (write-char #\0 stream))
 102                        (write-string fstr stream)
 103                        ;; Add a zero if we need it.  Which means
 104                        ;; we figured out we need one above, or
 105                        ;; another condition.  Basically, append a
 106                        ;; zero if there are no width constraints
 107                        ;; and if the last char to print was a
 108                        ;; decimal (so the trailing fraction is
 109                        ;; zero.)
 110                        (when (or add-zero-p
 111                                  (and (null w)
 112                                       (char= (aref fstr (1- flen)) #\.)))
 113                          ;; It's later and we're adding the zero
 114                          ;; digit.
 115                          (write-char #\0 stream))
 116                        (write-char (if marker
 117                                        marker
 118                                        #\q)
 119                                    stream)
 120                        (write-char (if (minusp expt) #\- #\+) stream)
 121                        (when e
 122                          ;;zero-fill before exponent if necessary
 123                          (dotimes (i (- e (length estr)))
 124                            (write-char #\0 stream)))
 125                        (write-string estr stream)))))))))
 126
 127 (defun qd-format-exp (stream arg colon-p at-sign-p
 128                       &optional w d e (k 1) ovf (pad #\space) exp-marker)
 129   (declare (ignore colon-p))
 130   (qd-format-exp-aux stream arg w d e k ovf pad exp-marker at-sign-p))