1 ;;;; -*- Mode: lisp -*-
3 ;;;; Copyright (c) 2007 Raymond Toy
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
14 ;;;; The above copyright notice and this permission notice shall be
15 ;;;; included in all copies or substantial portions of the Software.
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.
28 (defun qd-scale-exponent (original-x)
29 (let* ((x original-x
))
30 (multiple-value-bind (sig exponent
)
32 (declare (ignore sig
))
35 (let* ((ex (round (* exponent
(log #q2
10))))
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
))
44 (do ((m #q10.0q0
(* m
#q10.0q0
))
48 (values z ex
))))))))))
50 (defun decimal-string (n)
51 (cl:write-to-string n
:base
10 :radix nil
:escape nil
))
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
)))
60 (if (and w ovf e
(> elen e
)) ;exponent overflow
62 (write-char ovf stream
))
63 (let* ((fdig (if d
(if (plusp k
) (1+ (- d k
)) d
) nil
))
69 (if (or atsign
(minusp (float-sign number
)))
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
))
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
)) #\.
))
87 (if (or (> spaceleft
0) tpoint
)
90 (when (and tpoint
(<= spaceleft
0))
92 (cond ((and w
(< spaceleft
0) ovf
)
93 ;;significand overflow
94 (dotimes (i w
) (write-char ovf stream
)))
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
112 (char= (aref fstr
(1- flen
)) #\.
)))
113 ;; It's later and we're adding the zero
115 (write-char #\
0 stream
))
116 (write-char (if marker
120 (write-char (if (minusp expt
) #\-
#\
+) stream
)
122 ;;zero-fill before exponent if necessary
123 (dotimes (i (- e
(length estr
)))
124 (write-char #\
0 stream
)))
125 (write-string estr stream
)))))))))
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
))