
; gibt arg als rmische Zahl auf stream aus, z.B. 4 als IIII.
(defun format-old-roman (arg stream)
  (unless (and (integerp arg) (<= 1 arg 4999))
    (format-error *FORMAT-CS* nil
      (DEUTSCH "Die ~~:@R-Direktive erwartet ein Integer zwischen 1 und 4999, nicht ~S"
       ENGLISH "The ~~:@R directive requires an integer in the range 1 - 4999, not ~S"
       FRANCAIS "La directive ~~:@R requiert un entier compris entre 1 et 4999 et non ~S")
      arg
  ) )
  (do ((charlistr  '(#\M  #\D #\C #\L #\X #\V #\I) (cdr charlistr))
       (valuelistr '(1000 500 100 50  10   5   1) (cdr valuelistr))
       (value arg (multiple-value-bind (multiplicity restvalue)
                      (floor value (first valuelistr))
                    (dotimes (i multiplicity)
                      (write-char (first charlistr) stream)
                    )
                    restvalue
      ))          )
      ((zerop value))
) )

; gibt arg als rmische Zahl auf stream aus, z.B. 4 als IV.
(defun format-new-roman (arg stream)
  (unless (and (integerp arg) (<= 1 arg 3999))
    (format-error *FORMAT-CS* nil
      (DEUTSCH "Die ~~@R-Direktive erwartet ein Integer zwischen 1 und 3999, nicht ~S"
       ENGLISH "The ~~@R directive requires an integer in the range 1 - 3999, not ~S"
       FRANCAIS "La directive ~~@R requiert un entier compris entre 1 et 3999 et non ~S")
      arg
  ) )
  (do ((charlistr       '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr))
       (valuelistr     '(1000 500 100 50  10   5   1 ) (cdr valuelistr))
       (lowercharlistr  '(#\C #\C #\X #\X #\I #\I    ) (cdr lowercharlistr))
       (lowervaluelistr '(100 100 10  10   1   1   0 ) (cdr lowervaluelistr))
       (value arg
         (multiple-value-bind (multiplicity restvalue)
             (floor value (first valuelistr))
           (dotimes (i multiplicity) (write-char (first charlistr) stream))
           (let ((loweredvalue (- (first valuelistr) (first lowervaluelistr))))
             (if (>= restvalue loweredvalue)
               (progn
                 (write-char (first lowercharlistr) stream)
                 (write-char (first charlistr) stream)
                 (- restvalue loweredvalue)
               )
               restvalue
      )) ) ) )
      ((zerop value))
) )

(defconstant FORMAT-CARDINAL-ONES
  '#(NIL "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
     "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen"
     "seventeen" "eighteen" "nineteen"
)   )

(defconstant FORMAT-CARDINAL-TENS
  '#(NIL NIL "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")
)

; (format-small-cardinal arg stream) gibt eine ganze Zahl >0, <1000 im
; Klartext auf englisch auf den stream aus. (arg=0 -> gibt nichts aus.)
(defun format-small-cardinal (arg stream)
  (multiple-value-bind (hundreds tens-and-ones) (truncate arg 100)
    (when (> hundreds 0)
      (write-string (svref FORMAT-CARDINAL-ONES hundreds) stream)
      (write-string " hundred" stream)
    )
    (when (> tens-and-ones 0)
      (when (> hundreds 0) (write-string " and " stream))
      (multiple-value-bind (tens ones) (truncate tens-and-ones 10)
        (if (< tens 2)
          (write-string (svref FORMAT-CARDINAL-ONES tens-and-ones) stream)
          (progn
            (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
            (when (> ones 0)
              (write-char #\- stream)
              (write-string (svref FORMAT-CARDINAL-ONES ones) stream)
) ) ) ) ) ) )

; (format-cardinal arg stream) gibt die ganze Zahl arg im Klartext auf englisch
; auf den Stream aus.
(defun format-cardinal (arg stream) ; arg Integer
  (if (zerop arg)
    (write-string "zero" stream)
    (progn
      (when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
      (labels
        ((blocks1000 (illions-list arg) ; Zerlegung in 1000er-Blcke
           (when (null illions-list)
             (format-error *FORMAT-CS* nil
               (DEUTSCH "Zu groes Argument fr ~~R-Direktive."
                ENGLISH "The argument for the ~~R directive is too large."
                FRANCAIS "L'argument pour la directive ~~R est trop grand.")
           ) )
           (multiple-value-bind (thousands small) (truncate arg 1000)
             (when (> thousands 0) (blocks1000 (cdr illions-list) thousands))
             (when (> small 0)
               (when (> thousands 0) (write-string ", " stream))
               (format-small-cardinal small stream)
               (write-string (car illions-list) stream)
        )) ) )
        (blocks1000
          ; amerikanisch (billion=10^9)
          '("" " thousand" " million" " billion" " trillion" " quadrillion"
            " quintillion" " sextillion" " septillion" " octillion" " nonillion"
            " decillion" " undecillion" " duodecillion" " tredecillion"
            " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
            " octodecillion" " novemdecillion" " vigintillion")
          arg
) ) ) ) )

(defconstant FORMAT-ORDINAL-ONES
  '#(NIL "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth"
     "ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
     "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"
)   )

; (format-ordinal arg stream) gibt eine ganze Zahl arg als Abzhlnummer im
; Klartext auf englisch auf den stream aus.
(defun format-ordinal (arg stream) ; arg Integer
  (if (zerop arg)
    (write-string "zeroth" stream)
    (progn
      (when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
      (multiple-value-bind (hundreds tens-and-ones) (floor arg 100)
        (when (> hundreds 0) (format-cardinal (* hundreds 100) stream))
        (if (zerop tens-and-ones)
          (write-string "th" stream)
          (multiple-value-bind (tens ones) (floor tens-and-ones 10)
            (when (> hundreds 0) (write-char #\Space stream))
            (cond ((< tens 2)
                   (write-string (svref FORMAT-ORDINAL-ONES tens-and-ones) stream)
                  )
                  ((zerop ones)
                   (write-string
                     (svref '#(NIL "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth"
                               "sixtieth" "seventieth" "eightieth" "ninetieth")
                            tens
                     )
                     stream
                  ))
                  (t (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
                     (write-char #\- stream)
                     (write-string (svref FORMAT-ORDINAL-ONES ones) stream)
) ) ) ) ) ) )     )

; (format-padding count char stream) gibt count (ein Fixnum >=0) Zeichen char
; auf stream aus.
(defun format-padding (count char stream)
  (dotimes (i count) (write-char char stream))
)

; gibt auf den Stream stream aus:
; den String str, eventuell aufgefllt mit Padding characters padchar.
; Und zwar so, da die Breite mindestens mincol ist. Um das zu erreichen,
; werden mindestens minpad Zeichen eingefgt, eventuelle weitere dann in
; Blcken  colinc Zeichen. Falls padleftflag, werden sie links eingefgt,
; sonst rechts vom String.
(defun format-padded-string
       (mincol colinc minpad padchar padleftflag str stream)
  (let* ((need (+ (length str) minpad)) ; so viele Zeichen mindestens
         (auxpad (if (< need mincol)
                   (* (ceiling (- mincol need) colinc) colinc)
                   0
        ))       ) ; so viele Zeichen zustzlich
    (unless padleftflag (write-string str stream))
    (format-padding (+ minpad auxpad) padchar stream)
    (when padleftflag (write-string str stream))
) )

; gibt den Integer arg auf den Stream aus:
; in Zahlenbasis base, mit Vorzeichen (+ nur falls >0 und positive-sign-flag),
; bei commaflag alle drei Stellen unterbrochen durch ein Zeichen commachar.
; Das Ganze links aufgefllt mit padchar's, so da die Gesamtbreite mindestens
; mincol ist.
(defun format-integer (base
                       mincol
                       padchar
                       commachar
                       commainterval
                       commaflag
                       positive-sign-flag
                       arg
                       stream
                      )
  (let* ((*print-base* base)
         (*print-radix* nil)
         (*print-readably* nil))
    (if (and (zerop mincol) (not commaflag) (not positive-sign-flag))
      (princ arg stream) ; normale Ausgabe tut's
      (let* ((oldstring (princ-to-string arg))
             (oldstring-length (length oldstring))
             (number-of-digits
               (if (minusp arg) (1- oldstring-length) oldstring-length) )
             (number-of-commas
               (if commaflag (floor (1- number-of-digits) commainterval) 0) )
             (positive-sign (and positive-sign-flag (> arg 0)))
             (newstring-length
               (+ (if positive-sign 1 0) ; Vorzeichen
                  oldstring-length number-of-commas ; Ziffern, Kommas
             ) )
             (newstring (make-string newstring-length)) )
        ; Erst Vorzeichen +:
        (when positive-sign (setf (schar newstring 0) #\+))
        ; Dann oldstring in newstring bertragen, dabei Kommata berspringen:
        (let ((oldpos oldstring-length) (newpos newstring-length))
          (loop
            (decf oldpos)
            (when (minusp oldpos) (return))
            (decf newpos)
            (setf (schar newstring newpos) (schar oldstring oldpos))
            (when (and (plusp number-of-commas)
                       (zerop (mod (- oldstring-length oldpos) commainterval))
                  ) ; noch ein Komma einzufgen?
              (decf newpos)
              (setf (schar newstring newpos) commachar)
              (decf number-of-commas)
        ) ) )
        (if (zerop mincol)
          (write-string newstring stream) ; schneller
          (format-padded-string mincol 1 0 padchar t newstring stream)
) ) ) ) )

; was ~D bei non-Integer-Argument tut: Argument mit ~A, aber dezimal ausgeben
(defun format-ascii-decimal (arg stream)
  (let ((*print-base* 10.)
        (*print-radix* nil)
        (*print-readably* nil))
    (princ arg stream)
) )

; Unterprogramm fr ~D, ~B, ~O, ~X:
(defun format-base (base stream colon-modifier atsign-modifier
                    mincol padchar commachar commainterval
                    arg)
  (if (or (and (zerop mincol) (not colon-modifier) (not atsign-modifier))
          (not (integerp arg))
      )
    (let ((*print-base* base)
          (*print-radix* nil)
          (*print-readably* nil))
      (princ arg stream)
    )
    (format-integer base mincol padchar commachar commainterval
                    colon-modifier atsign-modifier arg stream
) ) )

; (format-scale-exponent-aux arg null eins zehn zehntel lg2)
; liefert zur Floating-Point-Zahl arg >= 0 und
; null = 0.0, eins = 1.0, zehn = 10.0, zehntel = 0.1, lg2 = log(2)/log(10)
; (erste vier in derselben Floating-Point-Precision wie arg)
; zwei Werte: mantissa und n, mit
; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
; (Bei arg=null: null und n=0.)
(defun format-scale-exponent-aux (arg null eins zehn zehntel lg2)
  (multiple-value-bind (significand expon) (decode-float arg)
    (declare (ignore significand))
    (if (zerop arg)
      (values null 0)
      (let* ((expon10a (truncate (* expon lg2))) ; nicht round, um berlauf zu vermeiden
             (signif10a (/ arg (expt zehn expon10a))))
        (do ((zehnpot zehn (* zehnpot zehn))
             (signif10b signif10a (/ signif10a zehnpot))
             (expon10b expon10a (1+ expon10b)))
            ((< signif10b eins)
             (do ((zehnpot zehn (* zehnpot zehn))
                  (signif10c signif10b (* signif10c zehnpot))
                  (expon10c expon10b (1- expon10c)))
                 ((>= signif10c zehntel)
                  (values signif10c expon10c)
             )   )
        )   )
) ) ) )

; (format-scale-exponent arg) liefert zur Floating-Point-Zahl arg >= 0
; zwei Werte: mantissa und n, mit
; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
; (Bei arg=null: 0.0 und n=0.)
(defun format-scale-exponent (arg)
  (cond ((short-float-p arg)
         (format-scale-exponent-aux arg 0.0s0 1.0s0 10.0s0 0.1s0 0.30103s0)
        )
        ((single-float-p arg)
         (format-scale-exponent-aux arg 0.0f0 1.0f0 10.0f0 0.1f0 0.30103s0)
        )
        ((double-float-p arg)
         (format-scale-exponent-aux arg 0.0d0 1.0d0 10.0d0 0.1d0 0.30103s0)
        )
        ((long-float-p arg)
         (format-scale-exponent-aux arg
           (float 0 arg) (float 1 arg) (float 10 arg) (float 1/10 arg)
           0.30102999566d0 ; lg2 wird mit 32 Bit Genauigkeit gebraucht
) )     ))

; (format-float-to-string arg width d k dmin)
; ergibt einen String zum Floating-point arg:
; er hat den Wert von (* (abs arg) (expt 10 k)), dabei mind. d Nachkommastellen
; und hchstens die Lnge width (width=nil -> keine Einschrnkung).
; Trotzdem wird nicht auf weniger als dmin Stellen gerundet.
(let ((digit-string
        (make-array 20 :element-type 'string-char :adjustable t :fill-pointer t)
     ))
(defun format-float-to-string (arg width d k dmin)
  (if (zerop arg)
    (let ((places (max (or d 0) (or dmin 0))))
      (when width ; width angegeben -> places := (min places (1- width))
        (when (>= places width) (setq places (1- width)))
      )
      (values
        (let ((str (make-string (1+ places) :initial-element #\0)))
          (setf (schar str 0) #\.)
          str          ; ein Punkt und places Nullen
        )
        (1+ places)    ; Stellenzahl
        t              ; Punkt ganz vorne
        (zerop places) ; Punkt ganz hinten ?
        0              ; Position des Punktes
    ) )
    (multiple-value-bind (significand expon) (integer-decode-float arg)
; significand : Integer >0
; expon : Integer
; mantprec : Anzahl der echten Mantissenbits von significand
; (also 2^mantprec <= significand < 2^(mantprec+1))
; width : Anzahl Stellen, die die Zahl (inklusive Punkt) nicht berschreiten
;         soll, oder NIL
; d : Mindestanzahl Nachkommastellen oder NIL
; k : Skalierungsfaktor (siehe CLTL S.394)
; dmin : Mindestanzahl von Dezimaltellen, die (trotz Angabe von width oder d)
;        nicht gerundet werden drfen.
;        (Nur interessant, falls d <= dmin <= (precision der Zahl).)
; wandelt die Zahl significand*2^expon um in einen Dezimalstring um.
; Es ist kein Exponent dabei.
      (let* ((mantprec (1- (float-digits arg)))
             (numerator significand)
             (denominator 1)
             (abrund-einh 1) ; Abrundungseinheit:
               ; Abrunden um 1 in der letzten abrundbaren Stelle entspricht
               ; einer Erniedrigung von numerator um abrund-einh.
             (aufrund-einh 1) ; Aufrundungseinheit:
               ; Aufrunden um 1 in der letzten aufrundbaren Stelle entspricht
               ; einer Erhhung von numerator um aufrund-einh.
             ; Stellen: 0 = 1. Stelle vor dem Punkt, -1 = 1. Stelle nach dem Punkt.
             (stelle 0) ; Stelle der als nchstes auszugebenden Ziffer
             (digit-count 0) ; Zahl der bisher in digit-string ausgegebenen
                             ; Ziffern (exklusive den Punkt)
             (point-pos 0) ; Punkt-Position = Zahl fhrender Stellen
                           ; = Zahl der Ziffern vor dem Punkt
             (letzte-stelle nil) ; NIL oder (falls d oder width angegeben waren)
                           ; Stelle der letzten signifikanten Ziffer
             (halbzahlig nil) ; zeigt an, ob hinten genau ein 0.500000 wegfllt
             digit ; die laufende Ziffer, >=0, <10
             (abrunden nil) ; T falls letzte Ziffer abzurunden ist
             (aufrunden nil) ; T falls letzte Ziffer aufzurunden ist
            )
        (setf (fill-pointer digit-string) 0) ; digit-string leeren
        (cond
          ((> expon 0)
           (setq numerator (ash significand expon))
           (setq aufrund-einh (setq abrund-einh (ash 1 expon)))
          )
          ((< expon 0)
           (setq denominator (ash 1 (- expon))) ; aufrund-einh = abrund-einh = 1
        ) )
        ; Zahl = numerator/denominator
        (when (= significand (ash 1 mantprec))
          ; Ist der Significand=2^mantprec, so ist abrund-einh zu halbieren.
          ; Man kann stattdessen auch alle 3 anderen Grssen verdoppeln:
          (setq aufrund-einh (ash aufrund-einh 1))
          (setq numerator (ash numerator 1))
          (setq denominator (ash denominator 1))
        )
        ; Defaultmig: Auf-/Abrunde-Einheit = eine Einheit in der letzten
        ; BINRstelle.
        ; Zahl = numerator/denominator
        ; Skalierungsfaktor k in die Zahl mit einbeziehen (vgl. CLTL S.394)
        ; k<0 -> Mantisse durch 10^(abs k) dividieren
        ; k>0 -> Mantisse mit 10^k multiplizieren
        ; Dabei aufrund-einh, abrund-einh im Verhltnis zu numerator beibehalten.
        (when k
          (if (< k 0)
            (let ((skal-faktor (expt 10 (- k))))
              (setq denominator (* denominator skal-faktor))
            )
            (let ((skal-faktor (expt 10 k)))
              (setq numerator (* numerator skal-faktor))
              (setq aufrund-einh (* aufrund-einh skal-faktor))
              (setq abrund-einh (* abrund-einh skal-faktor))
            )
        ) )
        ; auf >= 1/10 adjustieren:
        ; (jeweils numerator mit 10 multiplizieren, eine fhrende 0 mehr vorsehen)
        (do ()
            ((>= (* numerator 10) denominator))
          (setq stelle (1- stelle))
          (setq numerator (* numerator 10))
          (setq abrund-einh (* abrund-einh 10))
          (setq aufrund-einh (* aufrund-einh 10))
        )
        ; stelle = Stelle der letzten fhrenden 0
        ;        = 1 + Stelle der 1. signifikanten Ziffer
        ;        oder =0, falls k>=0
        ; Ausfhrung der Rundung:
        (loop
          ; Solange das Ergebnis auch nach Aufrundung >= 1 bliebe,
          ; eine Vorkommastelle mehr einplanen:
          (do ()
              ((< (+ (ash numerator 1) aufrund-einh) (ash denominator 1)))
            (setq denominator (* denominator 10))
            (setq stelle (1+ stelle))
          )
          ; Falls d oder width angegeben:
          ; letzte-stelle ausrechnen
          (if d
            ; Falls dmin angegeben: (min (- d) (- dmin)) = (- (max d dmin)).
            ; Sonst (- d).
            (progn
              (setq letzte-stelle (- d))
              (when (and dmin (> letzte-stelle (- dmin)))
                (setq letzte-stelle (- dmin))
            ) )
            ; Falls nicht d, nur width angegeben:
            (when width
              (if (< stelle 0)
                ; Es kommen fhrende Nullen nach dem Punkt -> d:=(1- width)
                (setq letzte-stelle (- 1 width))
                ; Es kommen keine fhrenden Nullen nach dem Punkt ->
                ; Es wird stelle Vorkommaziffern geben, d:=(- (1- width) stelle)
                (setq letzte-stelle (1+ (- stelle width)))
              )
              ; also letzte-stelle = (- (- (1- width) (max stelle 0)))
              ; wieder dmin bercksichtigen:
              (when (and dmin (> letzte-stelle (- dmin)))
                (setq letzte-stelle (- dmin))
          ) ) )
          (when (or d width)
            (let* ((ziffernzahl (- letzte-stelle stelle))
                   ; ziffernzahl = Zahl signifikanter Stellen oder <0.
                   (dezimal-einh denominator))
              ; dezimal-einh := (ceiling (* dezimal-einh (expt 10 ziffernzahl)))
              (if (>= ziffernzahl 0)
                (dotimes (i ziffernzahl)
                  (setq dezimal-einh (* dezimal-einh 10))
                )
                (dotimes (i (- ziffernzahl))
                  (setq dezimal-einh (ceiling dezimal-einh 10))
                )
              )
              ; dezimal-einh = Um wieviel numerator erhht bzw. erniedigt werden
              ; mte, damit sich die Dezimaldarstellung um genau 1 an der
              ; Position letzte-stelle verndert.
              (setq abrund-einh (max dezimal-einh abrund-einh))
              (setq aufrund-einh (max dezimal-einh aufrund-einh))
              ; Jetzt darf auch um eine (halbe) DEZIMAL-Einheit gerundet werden.
              (when (= aufrund-einh dezimal-einh) (setq halbzahlig T))
          ) )
          (when (< (+ (ash numerator 1) aufrund-einh) (ash denominator 1))
            (return)
        ) )
        ; stelle = Position der ersten signifikanten Stelle + 1
        ; Fhrenden Punkt und nachfolgende Nullen ausgeben:
        (when (< stelle 0)
          (setq point-pos digit-count)
          (vector-push-extend #\. digit-string)
          (dotimes (i (- stelle))
            (incf digit-count)
            (vector-push-extend #\0 digit-string)
        ) )
        ; Ziffern der Mantisse ausgeben:
        (loop
          (when (zerop stelle)
            (vector-push-extend #\. digit-string)
            (setq point-pos digit-count)
          )
          (decf stelle)
          (multiple-value-setq (digit numerator)
            (truncate (* numerator 10) denominator)
          )
          (setq abrund-einh (* abrund-einh 10))
          (setq aufrund-einh (* aufrund-einh 10))
          (setq abrunden (< (ash numerator 1) abrund-einh))
          (if halbzahlig
            (setq aufrunden
              (>= (ash numerator 1) (- (ash denominator 1) aufrund-einh))
            )
            (setq aufrunden
              (> (ash numerator 1) (- (ash denominator 1) aufrund-einh))
            )
          )
          (when (or abrunden aufrunden
                    (and letzte-stelle (<= stelle letzte-stelle))
                )
            (return)
          )
          (vector-push-extend (schar "0123456789" digit) digit-string)
          (incf digit-count)
        )
        ; letzte signifikante Ziffer ausgeben:
        (when (or (null letzte-stelle) (>= stelle letzte-stelle))
          (vector-push-extend
            (schar "0123456789"
              (cond
                ((and abrunden (not aufrunden)) digit)
                ((and aufrunden (not abrunden)) (1+ digit))
                ((<= (ash numerator 1) denominator) digit)
                (t (1+ digit))
            ) )
            digit-string
          )
          (incf digit-count)
        )
        ; Nachfolgende Nullen und Punkt ausgeben
        (when (>= stelle 0)
          (dotimes (i stelle)
            (incf digit-count)
            (vector-push-extend #\0 digit-string)
          )
          (vector-push-extend #\. digit-string)
          (setq point-pos digit-count)
        )
        (when d
          (dotimes (i (- d (- digit-count point-pos)))
            (incf digit-count)
            (vector-push-extend #\0 digit-string)
        ) )
        (values
                  digit-string               ; Ziffern
                  (1+ digit-count)           ; Anzahl der Ziffern
                  (= point-pos 0)            ; Punkt ganz vorne?
                  (= point-pos digit-count)  ; Punkt ganz hinten?
                  point-pos                  ; Position des Punktes
        ) ; 5 Werte
) ) ) )
)

; (format-float-for-f w d k overflowchar padchar plus-sign-flag arg stream)
; gibt die Floating-Point-Zahl arg in Festkommadarstellung auf stream aus.
(defun format-float-for-f (w d k overflowchar padchar plus-sign-flag arg stream)
  (let ((width (if w (if (or plus-sign-flag (minusp arg)) (1- w) w) nil)))
    ; width = zur Verfgung stehende Zeichen ohne Vorzeichen
    (multiple-value-bind (digits digitslength leadingpoint trailingpoint)
        (format-float-to-string arg width d k nil)
      (when (eql d 0) (setq trailingpoint nil)) ; d=0 -> keine Zusatz-Null hinten
      (when w
        (setq width (- width digitslength))
        (when leadingpoint ; evtl. Zusatz-Null vorne einplanen
          (if (> width 0) (setq width (1- width)) (setq leadingpoint nil))
        )
        (when trailingpoint ; evtl. Zusatz-Null hinten einplanen
          (if (> width 0) (setq width (1- width)) (setq trailingpoint nil))
        )
      )
      ; Es bleiben noch width Zeichen brig.
      (if (and overflowchar w (minusp width))
        (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
        (progn
          (when (and w (> width 0)) (format-padding width padchar stream))
          (if (minusp arg)
            (write-char #\- stream)
            (if plus-sign-flag (write-char #\+ stream))
          )
          (when leadingpoint (write-char #\0 stream))
          (write-string digits stream)
          (when trailingpoint (write-char #\0 stream))
      ) )
) ) )

; (format-float-for-e w d e k overflowchar padchar exponentchar plus-sign-flag
;                     arg stream)
; gibt die Floating-point-Zahl arg in Exponentialdarstellung auf den stream aus.
; (vgl. CLTL S.392-394)
; Aufteilung der Mantisse:
;   Falls k<=0, erst 1 Null (falls von der Breite her passend), dann der Punkt,
;               dann |k| Nullen, dann d-|k| signifikante Stellen;
;               zusammen also d Nachkommastellen.
;   Falls k>0,  erst k signifikante Stellen, dann der Punkt,
;               dann weitere d-k+1 signifikante Stellen;
;               zusammen also d+1 signifikante Stellen. Keine Nullen vorne.
;   (Der Defaultwert in FORMAT-EXPONENTIAL-FLOAT ist k=1.)
; Vor der Mantisse das Vorzeichen (ein + nur falls arg>=0 und plus-sign-flag).
; Dann der Exponent, eingeleitet durch exponentchar, dann Vorzeichen des
; Exponenten (stets + oder -), dann e Stellen fr den Exponenten.
; Dann wird das Ganze mit padchars auf w Zeichen Breite aufgefllt.
; Sollte das (auch nach evtl. Unterdrckung einer fhrenden Null) mehr als
; w Zeichen ergeben, so werden statt dessen w overflowchars ausgegeben, oder
; (falls overflowchar = nil) die Zahl mit so vielen Stellen wie ntig
; ausgegeben.
(defun format-float-for-e (w d e k
       overflowchar padchar exponentchar plus-sign-flag arg stream)
  (multiple-value-bind (mantissa oldexponent) (format-scale-exponent (abs arg))
    (let* ((exponent (if (zerop arg) 0 (- oldexponent k))) ; auszugebender Exponent
           (expdigits (write-to-string (abs exponent) :base 10. :radix nil :readably nil))
           (expdigitsneed (if e (max (length expdigits) e) (length expdigits)))
           ; expdigitsneed = Anzahl der Stellen, die fr die Ziffern des
           ; Exponenten ntig sind.
           (mantd (if d (if (> k 0) (1+ (- d k)) d) nil))
           ; mantd = Anzahl der Mantissenstellen hinter dem Punkt
           (dmin (if (minusp k) (- 1 k) nil)) ; nachher: fordere, da
           ; nicht in die ersten (+ 1 (abs k)) Stellen hineingerundet wird.
           (mantwidth (if w (- w 2 expdigitsneed) nil))
           ; mantwidth = Anzahl der fr die Mantisse (inkl. Vorzeichen, Punkt)
           ; zur Verfgung stehenden Zeichen (oder nil)
          )
      (declare (simple-string expdigits) (fixnum exponent expdigitsneed))
      (if (and overflowchar w e (> expdigitsneed e))
        ; Falls Overflowchar und w und e angegeben, Exponent mehr braucht:
        (format-padding w overflowchar stream)
        (progn
          (if w
            (if (or plus-sign-flag (minusp arg)) (setq mantwidth (1- mantwidth)))
          )
          ; mantwidth = Anzahl der fr die Mantisse (ohne Vorzeichen,
          ; inklusive Punkt) zur Verfgung stehenden Zeichen (oder nil)
          (multiple-value-bind (mantdigits mantdigitslength
                                leadingpoint trailingpoint)
              (format-float-to-string mantissa mantwidth mantd k dmin)
            (when w
              (setq mantwidth (- mantwidth mantdigitslength))
              (if trailingpoint
                (if (or (null mantd) (> mantd 0))
                  (setq mantwidth (- mantwidth 1))
                  (setq trailingpoint nil)
              ) )
              (if leadingpoint
                (if (> mantwidth 0)
                  (setq mantwidth (- mantwidth 1))
                  (setq leadingpoint nil)
              ) )
            )
            ; Es bleiben noch mantwidth Zeichen brig.
            (if (and overflowchar w (minusp mantwidth))
              (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
              (progn
                (when (and w (> mantwidth 0))
                  (format-padding mantwidth padchar stream)
                )
                (if (minusp arg)
                  (write-char #\- stream)
                  (if plus-sign-flag (write-char #\+ stream))
                )
                (if leadingpoint (write-char #\0 stream))
                (write-string mantdigits stream)
                (if trailingpoint (write-char #\0 stream))
                (write-char
                  (cond (exponentchar)
                        ((and (not *PRINT-READABLY*)
                              (typep arg *READ-DEFAULT-FLOAT-FORMAT*)
                         )
                         #\E
                        )
                        ((short-float-p arg) #\s)
                        ((single-float-p arg) #\f)
                        ((double-float-p arg) #\d)
                        ((long-float-p arg) #\L)
                  )
                  stream
                )
                (write-char (if (minusp exponent) #\- #\+) stream)
                (when (and e (> e (length expdigits)))
                  (format-padding (- e (length expdigits)) #\0 stream)
                )
                (write-string expdigits stream)
          ) ) )
    ) ) )
) )

; ~F, CLTL S.390-392, CLtL2 S. 588-590
(defformat-simple format-fixed-float (stream colon-modifier atsign-modifier
                  (w nil) (d nil) (k 0) (overflowchar nil) (padchar #\Space))
                  (arg)
  (declare (ignore colon-modifier))
  (when (rationalp arg) (setq arg (float arg)))
  (if (floatp arg)
    (format-float-for-f w d k overflowchar padchar atsign-modifier arg stream)
    (format-ascii-decimal arg stream)
) )

; ~E, CLTL S.392-395, CLtL2 S. 590-593
(defformat-simple format-exponential-float (stream colon-modifier atsign-modifier
                  (w nil) (d nil) (e nil) (k 1)
                  (overflowchar nil) (padchar #\Space) (exponentchar nil))
                  (arg)
  (declare (ignore colon-modifier))
  (when (rationalp arg) (setq arg (float arg)))
  (if (floatp arg)
    (format-float-for-e w d e k overflowchar padchar exponentchar
                        atsign-modifier arg stream
    )
    (format-ascii-decimal arg stream)
) )

; ~G, CLTL S.395-396, CLtL2 S. 594-595
(defformat-simple format-general-float (stream colon-modifier atsign-modifier
                  (w nil) (d nil) (e nil) (k 1)
                  (overflowchar nil) (padchar #\Space) (exponentchar nil))
                  (arg)
  (declare (ignore colon-modifier))
  (if (rationalp arg) (setq arg (float arg)))
  (if (floatp arg)
    (multiple-value-bind (mantissa n) (format-scale-exponent (abs arg))
      (declare (ignore mantissa))
      (if (null d)
        (setq d
          (multiple-value-bind (digits digitslength)
            (format-float-to-string (abs arg) nil nil nil nil)
            (declare (ignore digits))
            (max (max (1- digitslength) 1) (min n 7))
      ) ) )
      (let* ((ee (if e (+ 2 e) 4))
             (dd (- d n)))
        (if (<= 0 dd d)
          (progn
            (format-float-for-f
              (if w (- w ee) nil)
              dd 0
              overflowchar padchar atsign-modifier arg stream
            )
            (format-padding ee #\Space stream)
          )
          (format-float-for-e w d e k overflowchar padchar exponentchar
                              atsign-modifier arg stream
    ) ) ) )
    (format-ascii-decimal arg stream)
) )

; ~$, CLTL S.396-397, CLtL2 S. 595-596
(defformat-simple format-dollars-float (stream colon-modifier atsign-modifier
                  (d 2) (n 1) (w 0) (padchar #\Space))
                  (arg)
  (when (rationalp arg) (setq arg (float arg)))
  (if (floatp arg)
    (multiple-value-bind (digits digitslength
                          leadingpoint trailingpoint leadings)
      (format-float-to-string arg nil d 0 nil)
      (declare (ignore digitslength leadingpoint trailingpoint))
      (let* ((lefts (max leadings n))
             (totalwidth (+ (if (or atsign-modifier (minusp arg)) 1 0)
                            lefts 1 d
             )           )
             (padcount (max (- w totalwidth) 0)))
        (if (not colon-modifier) (format-padding padcount padchar stream))
        (if (minusp arg)
          (write-char #\- stream)
          (if atsign-modifier (write-char #\+ stream))
        )
        (if colon-modifier (format-padding padcount padchar stream))
        (format-padding (- lefts leadings) #\0 stream)
        (write-string digits stream)
    ) )
    (format-ascii-decimal arg stream)
) )
