src/real/format-output/TODO-format

   1 - operator<< should respect and reset the istream flags
   2 - operator>> should respect and reset the ostream flags
   3   See ANSI/ISO C++ section 22.2.2.2 num_put
   4   see egcs-1.1b/libio/iostream.cc : write_int,
   5   uses stream.flags(), stream.width(0), stream.fill()
   6
   7 ; (format-float-for-f w d k overflowchar padchar plus-sign-flag arg stream)
   8 ; gibt die Floating-Point-Zahl arg in Festkommadarstellung auf stream aus.
   9 (defun format-float-for-f (w d k overflowchar padchar plus-sign-flag arg stream)
  10   (let ((width (if w (if (or plus-sign-flag (minusp arg)) (1- w) w) nil)))
  11     ; width = zur Verfügung stehende Zeichen ohne Vorzeichen
  12     (multiple-value-bind (digits digitslength leadingpoint trailingpoint)
  13         (format-float-to-string arg width d k nil)
  14       (when (eql d 0) (setq trailingpoint nil)) ; d=0 -> keine Zusatz-Null hinten
  15       (when w
  16         (setq width (- width digitslength))
  17         (when leadingpoint ; evtl. Zusatz-Null vorne einplanen
  18           (if (> width 0) (setq width (1- width)) (setq leadingpoint nil))
  19         )
  20         (when trailingpoint ; evtl. Zusatz-Null hinten einplanen
  21           (if (> width 0) (setq width (1- width)) (setq trailingpoint nil))
  22         )
  23       )
  24       ; Es bleiben noch width Zeichen übrig.
  25       (if (and overflowchar w (minusp width))
  26         (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
  27         (progn
  28           (when (and w (> width 0)) (format-padding width padchar stream))
  29           (if (minusp arg)
  30             (write-char #\- stream)
  31             (if plus-sign-flag (write-char #\+ stream))
  32           )
  33           (when leadingpoint (write-char #\0 stream))
  34           (write-string digits stream)
  35           (when trailingpoint (write-char #\0 stream))
  36       ) )
  37 ) ) )
  38
  39 ; (format-float-for-e w d e k overflowchar padchar exponentchar plus-sign-flag
  40 ;                     arg stream)
  41 ; gibt die Floating-point-Zahl arg in Exponentialdarstellung auf den stream aus.
  42 ; (vgl. CLTL S.392-394)
  43 ; Aufteilung der Mantisse:
  44 ;   Falls k<=0, erst 1 Null (falls von der Breite her passend), dann der Punkt,
  45 ;               dann |k| Nullen, dann d-|k| signifikante Stellen;
  46 ;               zusammen also d Nachkommastellen.
  47 ;   Falls k>0,  erst k signifikante Stellen, dann der Punkt,
  48 ;               dann weitere d-k+1 signifikante Stellen;
  49 ;               zusammen also d+1 signifikante Stellen. Keine Nullen vorne.
  50 ;   (Der Defaultwert in FORMAT-EXPONENTIAL-FLOAT ist k=1.)
  51 ; Vor der Mantisse das Vorzeichen (ein + nur falls arg>=0 und plus-sign-flag).
  52 ; Dann der Exponent, eingeleitet durch exponentchar, dann Vorzeichen des
  53 ; Exponenten (stets + oder -), dann e Stellen für den Exponenten.
  54 ; Dann wird das Ganze mit padchars auf w Zeichen Breite aufgefüllt.
  55 ; Sollte das (auch nach evtl. Unterdrückung einer führenden Null) mehr als
  56 ; w Zeichen ergeben, so werden statt dessen w overflowchars ausgegeben, oder
  57 ; (falls overflowchar = nil) die Zahl mit so vielen Stellen wie nötig
  58 ; ausgegeben.
  59 (defun format-float-for-e (w d e k
  60        overflowchar padchar exponentchar plus-sign-flag arg stream)
  61   (multiple-value-bind (mantissa oldexponent) (format-scale-exponent (abs arg))
  62     (let* ((exponent (if (zerop arg) 0 (- oldexponent k))) ; auszugebender Exponent
  63            (expdigits (write-to-string (abs exponent) :base 10. :radix nil :readably nil))
  64            (expdigitsneed (if e (max (length expdigits) e) (length expdigits)))
  65            ; expdigitsneed = Anzahl der Stellen, die für die Ziffern des
  66            ; Exponenten nötig sind.
  67            (mantd (if d (if (> k 0) (1+ (- d k)) d) nil))
  68            ; mantd = Anzahl der Mantissenstellen hinter dem Punkt
  69            (dmin (if (minusp k) (- 1 k) nil)) ; nachher: fordere, daß
  70            ; nicht in die ersten (+ 1 (abs k)) Stellen hineingerundet wird.
  71            (mantwidth (if w (- w 2 expdigitsneed) nil))
  72            ; mantwidth = Anzahl der für die Mantisse (inkl. Vorzeichen, Punkt)
  73            ; zur Verfügung stehenden Zeichen (oder nil)
  74           )
  75       (declare (simple-string expdigits) (fixnum exponent expdigitsneed))
  76       (if (and overflowchar w e (> expdigitsneed e))
  77         ; Falls Overflowchar und w und e angegeben, Exponent mehr braucht:
  78         (format-padding w overflowchar stream)
  79         (progn
  80           (if w
  81             (if (or plus-sign-flag (minusp arg)) (setq mantwidth (1- mantwidth)))
  82           )
  83           ; mantwidth = Anzahl der für die Mantisse (ohne Vorzeichen,
  84           ; inklusive Punkt) zur Verfügung stehenden Zeichen (oder nil)
  85           (multiple-value-bind (mantdigits mantdigitslength
  86                                 leadingpoint trailingpoint)
  87               (format-float-to-string mantissa mantwidth mantd k dmin)
  88             (when w
  89               (setq mantwidth (- mantwidth mantdigitslength))
  90               (if trailingpoint
  91                 (if (or (null mantd) (> mantd 0))
  92                   (setq mantwidth (- mantwidth 1))
  93                   (setq trailingpoint nil)
  94               ) )
  95               (if leadingpoint
  96                 (if (> mantwidth 0)
  97                   (setq mantwidth (- mantwidth 1))
  98                   (setq leadingpoint nil)
  99               ) )
 100             )
 101             ; Es bleiben noch mantwidth Zeichen übrig.
 102             (if (and overflowchar w (minusp mantwidth))
 103               (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
 104               (progn
 105                 (when (and w (> mantwidth 0))
 106                   (format-padding mantwidth padchar stream)
 107                 )
 108                 (if (minusp arg)
 109                   (write-char #\- stream)
 110                   (if plus-sign-flag (write-char #\+ stream))
 111                 )
 112                 (if leadingpoint (write-char #\0 stream))
 113                 (write-string mantdigits stream)
 114                 (if trailingpoint (write-char #\0 stream))
 115                 (write-char
 116                   (cond (exponentchar)
 117                         ((and (not *PRINT-READABLY*)
 118                               (typep arg *READ-DEFAULT-FLOAT-FORMAT*)
 119                          )
 120                          #\E
 121                         )
 122                         ((short-float-p arg) #\s)
 123                         ((single-float-p arg) #\f)
 124                         ((double-float-p arg) #\d)
 125                         ((long-float-p arg) #\L)
 126                   )
 127                   stream
 128                 )
 129                 (write-char (if (minusp exponent) #\- #\+) stream)
 130                 (when (and e (> e (length expdigits)))
 131                   (format-padding (- e (length expdigits)) #\0 stream)
 132                 )
 133                 (write-string expdigits stream)
 134           ) ) )
 135     ) ) )
 136 ) )
 137
 138 ; ~F, CLTL S.390-392, CLtL2 S. 588-590
 139 (defformat-simple format-fixed-float (stream colon-modifier atsign-modifier
 140                   (w nil) (d nil) (k 0) (overflowchar nil) (padchar #\Space))
 141                   (arg)
 142   (declare (ignore colon-modifier))
 143   (when (rationalp arg) (setq arg (float arg)))
 144   (if (floatp arg)
 145     (format-float-for-f w d k overflowchar padchar atsign-modifier arg stream)
 146     (print_rational arg stream 10)
 147 ) )
 148
 149 ; ~E, CLTL S.392-395, CLtL2 S. 590-593
 150 (defformat-simple format-exponential-float (stream colon-modifier atsign-modifier
 151                   (w nil) (d nil) (e nil) (k 1)
 152                   (overflowchar nil) (padchar #\Space) (exponentchar nil))
 153                   (arg)
 154   (declare (ignore colon-modifier))
 155   (when (rationalp arg) (setq arg (float arg)))
 156   (if (floatp arg)
 157     (format-float-for-e w d e k overflowchar padchar exponentchar
 158                         atsign-modifier arg stream
 159     )
 160     (print_rational arg stream 10)
 161 ) )
 162
 163 ; ~G, CLTL S.395-396, CLtL2 S. 594-595
 164 (defformat-simple format-general-float (stream colon-modifier atsign-modifier
 165                   (w nil) (d nil) (e nil) (k 1)
 166                   (overflowchar nil) (padchar #\Space) (exponentchar nil))
 167                   (arg)
 168   (declare (ignore colon-modifier))
 169   (if (rationalp arg) (setq arg (float arg)))
 170   (if (floatp arg)
 171     (multiple-value-bind (mantissa n) (format-scale-exponent (abs arg))
 172       (declare (ignore mantissa))
 173       (if (null d)
 174         (setq d
 175           (multiple-value-bind (digits digitslength)
 176             (format-float-to-string (abs arg) nil nil nil nil)
 177             (declare (ignore digits))
 178             (max (max (1- digitslength) 1) (min n 7))
 179       ) ) )
 180       (let* ((ee (if e (+ 2 e) 4))
 181              (dd (- d n)))
 182         (if (<= 0 dd d)
 183           (progn
 184             (format-float-for-f
 185               (if w (- w ee) nil)
 186               dd 0
 187               overflowchar padchar atsign-modifier arg stream
 188             )
 189             (format-padding ee #\Space stream)
 190           )
 191           (format-float-for-e w d e k overflowchar padchar exponentchar
 192                               atsign-modifier arg stream
 193     ) ) ) )
 194     (print_rational arg stream 10)
 195 ) )
 196
 197 ; ~$, CLTL S.396-397, CLtL2 S. 595-596
 198 (defformat-simple format-dollars-float (stream colon-modifier atsign-modifier
 199                   (d 2) (n 1) (w 0) (padchar #\Space))
 200                   (arg)
 201   (when (rationalp arg) (setq arg (float arg)))
 202   (if (floatp arg)
 203     (multiple-value-bind (digits digitslength
 204                           leadingpoint trailingpoint leadings)
 205       (format-float-to-string arg nil d 0 nil)
 206       (declare (ignore digitslength leadingpoint trailingpoint))
 207       (let* ((lefts (max leadings n))
 208              (totalwidth (+ (if (or atsign-modifier (minusp arg)) 1 0)
 209                             lefts 1 d
 210              )           )
 211              (padcount (max (- w totalwidth) 0)))
 212         (if (not colon-modifier) (format-padding padcount padchar stream))
 213         (if (minusp arg)
 214           (write-char #\- stream)
 215           (if atsign-modifier (write-char #\+ stream))
 216         )
 217         (if colon-modifier (format-padding padcount padchar stream))
 218         (format-padding (- lefts leadings) #\0 stream)
 219         (write-string digits stream)
 220     ) )
 221     (print_rational arg stream 10)
 222 ) )