; FORMAT - und was dazugehört.
; Bruno Haible 22.06.1988
; CLISP-Version 16.08.1988, 03.09.1988, 04.08.1989
; Groß umgearbeitet von Bruno Haible am 14.02.1990-15.02.1990

(in-package "SYSTEM")

;-------------------------------------------------------------------------------

; Datenstruktur der Kontrollstring-Direktive:
(defstruct (control-string-directive
             (:copier nil)
             (:conc-name "CSD-")
             (:predicate nil)
             (:constructor make-csd ())
           )
  (type         0 :type fixnum)
  (cs-index     0 :type fixnum)
  (parm-list    nil :type list)
  (v-or-#-p     nil :type symbol)
  (colon-p      nil :type symbol)
  (atsign-p     nil :type symbol)
  (data         nil)
  (clause-chain nil)
)
#+CLISP (remprop 'control-string-directive 'sys::defstruct-description)
; Erläuterung:
; type=0 : Direktive ~<Newline>, nichts auszugeben.
;          Weitere Komponenten bedeutungslos
; type=1 : String auszugeben,
;          von *FORMAT-CS* die Portion :START cs-index :END data.
;          Weitere Komponenten bedeutungslos
; type=2 : Formatier-Direktive auszuführen.
;          data = Name der Direktive (Symbol),
;          colon-p gibt an, ob ein ':' da war,
;          atsign-p gibt an, ob ein '@' da war,
;          parm-list = Parameterliste an die Direktive,
;          v-or-#-p gibt an, ob parm-list vor dem Aufruf noch zu behandeln ist.
;          clause-chain ist eine Verzeigerung: z.B. bei ~[...~;...~;...~]
;          von der ~[-Direktive auf die Liste ab der ersten ~;-Direktive,
;          von da auf die Liste ab der nächsten ~;-Direktive usw.
;          bis schließlich auf die Liste ab der ~]-Direktive.

; Zeigt an, ob ein Character ein Whitespace-Character ist.
(defun whitespacep (char)
  (member char '(#\Space #\Newline #\Linefeed #\Tab #\Return #\Page))
)

; (FORMAT-PARSE-CS control-string startindex csdl stop-at)
; parst einen Kontrollstring (genauer: (subseq control-string startindex))
; und legt die sich ergebende Control-String-Directive-Liste in (cdr csdl) ab.
; Das Parsen muß mit der Direktive stop-at enden (ein Character, oder NIL
; für Stringende).
; Falls stop-at /= NIL, ist in (csd-clause-chain (car csdl)) ein Pointer auf
; die Teilliste ab dem nächsten Separator einzutragen. Diese Pointer bilden
; eine einfach verkettete Liste innerhalb csdl: von einem Separator zum
; nächsten, zum Schluß zum Ende der Clause.
(defun format-parse-cs (control-string startindex csdl stop-at)
  (declare (fixnum startindex))
  (macrolet ((errorstring ()
               (DEUTSCH "Kontrollstring endet mitten in einer Direktive."
                ENGLISH "The control string terminates within a directive."
                FRANCAIS "La chaîne de contrôle se termine en plein milieu d'une directive.")
            ))
    (prog* ((index startindex) ; cs-index des nächsten Zeichens
            ch ; current character
            intparam ; Integer-Parameter
            newcsd ; aktuelle CSD
            (last-separator-csd (car csdl))
           )
      (declare (type simple-string control-string) (type fixnum index))
      (loop ; neue Direktive insgesamt
        (tagbody
          (when (>= index (length control-string))
            (go string-ended)
          )
          (setq ch (schar control-string index))
          (unless (eql ch #\~)
            ; eventuell noch Stringstück zu einer eingenen Direktive machen
            (setq csdl (setf (cdr csdl) (list (setq newcsd (MAKE-CSD)))))
            (setf (csd-type     newcsd) 1)
            (setf (csd-cs-index newcsd) index)
            (setq index (position #\~ control-string :start index))
            (unless index
              (setf (csd-data newcsd) (setq index (length control-string)))
              (go string-ended)
            )
            (setf (csd-data newcsd) index)
          )
          (setq csdl (setf (cdr csdl) (list (setq newcsd (MAKE-CSD)))))
          (setf (csd-type         newcsd) 2)
          (setf (csd-cs-index     newcsd) index)
          (setf (csd-parm-list    newcsd) nil)
          (setf (csd-v-or-#-p     newcsd) nil)
          (setf (csd-colon-p      newcsd) nil)
          (setf (csd-atsign-p     newcsd) nil)
          (setf (csd-data         newcsd) nil)
          (setf (csd-clause-chain newcsd) nil)

          param ; Parameter einer Direktive kann beginnen
          (incf index)
          (when (>= index (length control-string))
            (format-error control-string index (errorstring))
            (go string-ended)
          )
          (setq ch (schar control-string index))
          (when (digit-char-p ch) (go num-param))
          (case ch
            ((#\+ #\-) (go num-param))
            (#\' (go quote-param))
            ((#\V #\v #\#)
             (push (if (eql ch #\#) ':ARG-COUNT ':NEXT-ARG)
                   (csd-parm-list newcsd)
             )
             (setf (csd-v-or-#-p newcsd) T)
             (go param-ok-1)
            )
            (#\, (push nil (csd-parm-list newcsd)) (go param))
            (#\: (go colon-modifier))
            (#\@ (go atsign-modifier))
            (T (go directive))
          )

          num-param ; numerischer Parameter
          (multiple-value-setq (intparam index)
            (parse-integer control-string :start index :junk-allowed t)
          )
          (unless intparam
            (format-error control-string index
                          (DEUTSCH "~A muß eine Zahl einleiten."
                           ENGLISH "~A must introduce a number."
                           FRANCAIS "~A doit introduire un nombre.")
                          ch
          ) )
          (push intparam (csd-parm-list newcsd))
          (go param-ok-2)

          quote-param ; Quote-Parameter-Behandlung
          (incf index)
          (when (>= index (length control-string))
            (format-error control-string index
              (DEUTSCH "Kontrollstring endet mitten in einem '-Parameter."
               ENGLISH "The control string terminates in the middle of a parameter."
               FRANCAIS "La chaîne de contrôle se termine au milieu d'un paramètre.")
            )
            (go string-ended)
          )
          (setq ch (schar control-string index))
          (push ch (csd-parm-list newcsd))

          param-ok-1 ; Parameter OK
          (incf index)
          param-ok-2 ; Parameter OK
          (when (>= index (length control-string))
            (format-error control-string index (errorstring))
            (go string-ended)
          )
          (setq ch (schar control-string index))
          (case ch
            (#\, (go param))
            (#\: (go colon-modifier))
            (#\@ (go atsign-modifier))
            (T (go directive))
          )

          colon-modifier ; nach :
          (setf (csd-colon-p newcsd) T)
          (go passed-modifier)

          atsign-modifier ; nach @
          (setf (csd-atsign-p newcsd) T)
          (go passed-modifier)

          passed-modifier ; nach : oder @
          (incf index)
          (when (>= index (length control-string))
            (format-error control-string index (errorstring))
            (go string-ended)
          )
          (setq ch (schar control-string index))
          (case ch
            (#\: (go colon-modifier))
            (#\@ (go atsign-modifier))
            (T (go directive))
          )

          directive ; Direktive (ihr Name) erreicht
          (setf (csd-parm-list newcsd) (nreverse (csd-parm-list newcsd)))
          (let ((directive-name
                  (cdr (assoc (char-upcase ch)
                         '((#\A . FORMAT-ASCII)
                           (#\S . FORMAT-S-EXPRESSION)
                           (#\W . FORMAT-WRITE)
                           (#\D . FORMAT-DECIMAL)
                           (#\B . FORMAT-BINARY)
                           (#\O . FORMAT-OCTAL)
                           (#\X . FORMAT-HEXADECIMAL)
                           (#\R . FORMAT-RADIX)
                           (#\P . FORMAT-PLURAL)
                           (#\C . FORMAT-CHARACTER)
                           (#\F . FORMAT-FIXED-FLOAT)
                           (#\E . FORMAT-EXPONENTIAL-FLOAT)
                           (#\G . FORMAT-GENERAL-FLOAT)
                           (#\$ . FORMAT-DOLLARS-FLOAT)
                           (#\% . FORMAT-TERPRI)
                           (#\& . FORMAT-FRESH-LINE)      (#\Newline . #\Newline)
                           (#\| . FORMAT-PAGE)
                           (#\~ . FORMAT-TILDE)
                           (#\T . FORMAT-TABULATE)
                           (#\* . FORMAT-GOTO)
                           (#\? . FORMAT-INDIRECTION)
                           (#\( . FORMAT-CASE-CONVERSION) (#\) . FORMAT-CASE-CONVERSION-END)
                           (#\[ . FORMAT-CONDITIONAL)     (#\] . FORMAT-CONDITIONAL-END)
                           (#\{ . FORMAT-ITERATION)       (#\} . FORMAT-ITERATION-END)
                           (#\< . FORMAT-JUSTIFICATION)   (#\> . FORMAT-JUSTIFICATION-END)
                           (#\^ . FORMAT-UP-AND-OUT)      (#\; . FORMAT-SEPARATOR)
                           ; mit Funktionsdefinition      ; ohne Funktionsdefinition
               )) )    )  )
            (if directive-name
              (setf (csd-data newcsd) directive-name)
              (format-error control-string index
                (DEUTSCH "Diese Direktive gibt es nicht."
                 ENGLISH "Non-existent directive"
                 FRANCAIS "Directive non reconnue.")
          ) ) )
          (incf index)
          (case ch
            (( #\( #\[ #\{ #\< )
             (multiple-value-setq (index csdl)
               (format-parse-cs control-string index csdl
                 (case ch (#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) )
             ) )
            )
            (( #\) #\] #\} #\> )
             (unless stop-at
               (format-error control-string index
                 (DEUTSCH "Schließende Klammer '~A' ohne vorherige öffnende Klammer"
                  ENGLISH "The closing directive '~A' does not have a corresponding opening one."
                  FRANCAIS "Parenthèse fermante '~A' sans parenthèse ouvrante correspondante.")
                 ch
             ) )
             (unless (eql ch stop-at)
               (format-error control-string index
                 (DEUTSCH "Schließende Klammer '~A' paßt nicht; sollte '~A' lauten."
                  ENGLISH "The closing directive '~A' does not match the corresponding opening one. It should read '~A'."
                  FRANCAIS "La parenthèse fermante '~A' ne correspond pas à celle ouvrante. Il devrait y avoir '~A'.")
                 ch stop-at
             ) )
             (setf (csd-clause-chain last-separator-csd) csdl)
             (go end)
            )
            (#\;
             (unless (or (eql stop-at #\]) (eql stop-at #\>))
               (format-error control-string index
                 (DEUTSCH "Hier ist keine ~~;-Direktive möglich."
                  ENGLISH "The ~~; directive is not allowed at this point."
                  FRANCAIS "La directive ~~; n'est pas permise ici.")
             ) )
             (setf (csd-clause-chain last-separator-csd) csdl)
             (setq last-separator-csd newcsd)
            )
            (#\Newline
             (setf (csd-type newcsd) 0)
             (if (csd-colon-p newcsd)
               (if (csd-atsign-p newcsd)
                 (format-error control-string index
                   (DEUTSCH "Die ~~Newline-Direktive ist mit : und @ sinnlos."
                    ENGLISH "The ~~newline directive cannot take both modifiers."
                    FRANCAIS "La directive ~~Newline est insensée avec les deux qualificateurs : et @.")
                 )
                 nil ; ~:<newline> -> Newline ignorieren, Whitespace dalassen
               )
               (progn
                 (when (csd-atsign-p newcsd)
                   ; ~@<newline> -> Stringstück mit Newline zum Ausgeben
                   (setf (csd-type newcsd) 1)
                   (setf (csd-cs-index newcsd) (1- index))
                   (setf (csd-data newcsd) index)
                 )
                 (setq index
                   (or (position-if-not #'whitespacep control-string :start index)
                       (length control-string)
          ) )) ) ) )
        ) ; tagbody zu Ende
      ) ; loop zu Ende

      string-ended
      (when stop-at
        (format-error control-string index
          (DEUTSCH "Schließende Klammer '~A' fehlt."
           ENGLISH "An opening directive is never closed; expecting '~A'."
           FRANCAIS "Il manque la borne fermante '~A'.")
          stop-at
      ) )

      end
      (return (values index csdl))
) ) )

;-------------------------------------------------------------------------------

(defvar *FORMAT-CS*) ; control-string
(defvar *FORMAT-CSDL*) ; control-string directive list
(defvar *FORMAT-ARG-LIST*) ; argument-list
(defvar *FORMAT-NEXT-ARG*) ; pointer to next argument in argument-list
(defvar *FORMAT-UP-AND-OUT* nil) ; reason for up-and-out

; (format-error controlstring errorpos errorcode . arguments)
; signalisiert einen Error, der bei FORMAT aufgetreten ist. Die Stelle im
; Control-string wird mit einem Pfeil markiert.
(defun format-error (controlstring errorpos errorstring &rest arguments)
  (unless errorpos (setq errorpos (csd-cs-index (car *FORMAT-CSDL*))))
  (setq errorstring
    (string-concat errorstring
      (DEUTSCH "~%Stelle im Kontrollstring:"
       ENGLISH "~%Current point in control string:"
       FRANCAIS "~%Position dans la chaîne de contrôle :")
  ) )
  (let ((pos1 0) (pos2 0))
    (declare (simple-string errorstring) (fixnum pos1 pos2))
    (loop
      (setq pos2 (or (position #\Newline controlstring :start pos1)
                     (length controlstring)
      )          )
      (setq errorstring (string-concat errorstring "~%  ~A"))
      (setq arguments
        (nconc arguments (list (substring controlstring pos1 pos2))) )
      (when (<= pos1 errorpos pos2)
        (setq errorstring
          (string-concat errorstring "~%~VT"
                         #+ATARI "" #+(or DOS OS/2) "" #-(or ATARI DOS OS/2) "|"
        ) )
        (setq arguments (nconc arguments (list (+ (- errorpos pos1) 2))))
      )
      (when (= pos2 (length controlstring)) (return))
      (setq pos1 (+ pos2 1))
  ) )
  (apply #'error-of-type 'error errorstring arguments)
)

;-------------------------------------------------------------------------------

(defun format (destination control-string &rest arguments)
  (unless (stringp control-string)
    (error-of-type 'type-error
      :datum control-string :expected-type 'string
      (DEUTSCH "Kontrollstring muß ein String sein, nicht ~S"
       ENGLISH "The control-string must be a string, not ~S"
       FRANCAIS "La chaîne de contrôle doit être une chaîne et non ~S")
      control-string
  ) )
  ; evtl. noch control-string zu einem Simple-String machen ??
  (let ((node (list control-string)))
    (format-parse-cs control-string 0 node nil)
    (let* ((*FORMAT-CS*         (car node))
           (*FORMAT-CSDL*       (cdr node))
           (*FORMAT-ARG-LIST*   arguments)
           (*FORMAT-NEXT-ARG*   *FORMAT-ARG-LIST*)
           (*FORMAT-UP-AND-OUT* nil))
      (cond ((null destination)
             (let ((stream (make-string-output-stream)))
               (format-interpret stream)
               (get-output-stream-string stream)
            ))
            ((eq destination 'T)
             (format-interpret *STANDARD-OUTPUT*)
             nil
            )
            ((streamp destination)
             (format-interpret destination)
             nil
            )
            ((stringp destination)
             (if (array-has-fill-pointer-p destination)
               (let ((stream (sys::make-string-push-stream destination)))
                 (format-interpret stream)
               )
               (error-of-type 'error
                 (DEUTSCH "String zum Vollschreiben ~S hat keinen Fill-Pointer."
                  ENGLISH "The destination string ~S should have a fill pointer."
                  FRANCAIS "La chaîne destination n'a pas de pointeur de remplissage.")
                 destination
             ) )
             nil
            )
            (t (error-of-type 'type-error
                 :datum destination :expected-type '(or (member nil t) stream string)
                 (DEUTSCH "Das ist weder NIL noch T noch ein Stream noch ein String: ~S"
                  ENGLISH "The destination argument ~S is invalid (not NIL or T or a stream or a string)."
                  FRANCAIS "L'argument de destination n'est ni NIL, ni T, ni un «stream» ni une chaîne : ~S")
                 destination
            )  )
) ) ) )

;-------------------------------------------------------------------------------

; (next-arg) liefert (und verbraucht) das nächste Argument aus der Argument-
; liste *FORMAT-NEXT-ARG*.
(defun next-arg ()
  (if (atom *FORMAT-NEXT-ARG*)
    (format-error *FORMAT-CS* nil
      (DEUTSCH "Nicht genügend Argumente für diese Direktive übrig."
       ENGLISH "There are not enough arguments left for this directive."
       FRANCAIS "Il ne reste pas assez d'arguments pour cette directive.")
    )
    (pop *FORMAT-NEXT-ARG*)
) )

; (format-interpret stream [endmarker]) interpretiert *FORMAT-CSDL* ab.
; Fluid vars:
;   *FORMAT-ARG-LIST*
;   *FORMAT-NEXT-ARG*
;   *FORMAT-CS*
;   *FORMAT-CSDL*
;   *FORMAT-UP-AND-OUT*
; Abbruch des Interpretierens bei Antreffen der Direktive endmarker
; oder der Direktive ~; .
(defun format-interpret (stream &optional (endmarker nil))
  (loop
    (when *FORMAT-UP-AND-OUT* (return))
    (when (endp *FORMAT-CSDL*) (return))
    (let ((csd (car *FORMAT-CSDL*)))
      (case (csd-type csd)
        (0 )
        (1 (write-string *FORMAT-CS* stream
             :start (csd-cs-index csd) :end (csd-data csd)
        )  )
        (2 (let ((directive-name (csd-data csd)))
             (if (eq directive-name endmarker) (return))
             (if (eq directive-name 'FORMAT-SEPARATOR) (return))
             (apply directive-name
               stream
               (csd-colon-p csd)
               (csd-atsign-p csd)
               (format-resolve-parms csd)
        )  ) )
    ) )
    (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
) )

; liefert die korrekte Argumentliste einer CSD, evtl. mit eingesetzten
; Parametern: V (als :NEXT-ARG) und # (als :ARG-COUNT) werden aufgelöst.
(defun format-resolve-parms (csd)
  (let ((arglist (csd-parm-list csd)))
    (if (csd-v-or-#-p csd)
      (mapcar #'(lambda (arg)
                  (case arg
                    (:NEXT-ARG (next-arg))
                    (:ARG-COUNT (list-length *FORMAT-NEXT-ARG*))
                    (T arg)
                ) )
              arglist
      )
      arglist
) ) )

; Bewegt den Stand des "Pointers in die Argumentliste" in eine Richtung.
(defun format-goto-new-arg (backwardp index)
  (if backwardp
    ; rückwärts
    (setq *FORMAT-NEXT-ARG*
      (nthcdr
        (max (- (list-length *FORMAT-ARG-LIST*) (list-length *FORMAT-NEXT-ARG*) index) 0)
        *FORMAT-ARG-LIST*
    ) )
    ; vorwärts ist einfacher:
    (setq *FORMAT-NEXT-ARG* (nthcdr index *FORMAT-NEXT-ARG*))
) )

; gibt arg als römische 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 römische 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-Blöcke
           (when (null illions-list)
             (format-error *FORMAT-CS* nil
               (DEUTSCH "Zu großes Argument für ~~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 Abzählnummer 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 aufgefüllt mit Padding characters padchar.
; Und zwar so, daß die Breite mindestens mincol ist. Um das zu erreichen,
; werden mindestens minpad Zeichen eingefügt, eventuelle weitere dann in
; Blöcken à colinc Zeichen. Falls padleftflag, werden sie links eingefügt,
; 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 zusätzlich
    (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 aufgefüllt mit padchar's, so daß die Gesamtbreite mindestens
; mincol ist.
(defun format-integer (base
                       mincol
                       padchar
                       commachar
                       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) 3) 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) 3))
                  ) ; noch ein Komma einzufügen?
              (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 für ~D, ~B, ~O, ~X:
(defun format-base (base stream colon-modifier atsign-modifier
                    mincol padchar commachar)
  (if (null mincol) (setq mincol 0))
  (if (null padchar) (setq padchar #\Space))
  (if (null commachar) (setq commachar #\,))
  (let ((arg (next-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
                      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 höchstens die Länge width (width=nil -> keine Einschränkung).
; 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 dürfen.
;        (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 Erhöhung von numerator um aufrund-einh.
             ; Stellen: 0 = 1. Stelle vor dem Punkt, -1 = 1. Stelle nach dem Punkt.
             (stelle 0) ; Stelle der als nächstes auszugebenden Ziffer
             (digit-count 0) ; Zahl der bisher in digit-string ausgegebenen
                             ; Ziffern (exklusive den Punkt)
             (point-pos 0) ; Punkt-Position = Zahl führender 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 wegfällt
             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 Grössen verdoppeln:
          (setq aufrund-einh (ash aufrund-einh 1))
          (setq numerator (ash numerator 1))
          (setq denominator (ash denominator 1))
        )
        ; Defaultmäßig: Auf-/Abrunde-Einheit = eine Einheit in der letzten
        ; BINÄRstelle.
        ; 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 Verhältnis 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 führende 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 führenden 0
        ;        = 1 + Stelle der 1. signifikanten Ziffer
        ;        oder =0, falls k>=0
        ; Ausführung 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 führende Nullen nach dem Punkt -> d:=(1- width)
                (setq letzte-stelle (- 1 width))
                ; Es kommen keine führenden 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 berücksichtigen:
              (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 erhöht bzw. erniedigt werden
              ; müßte, damit sich die Dezimaldarstellung um genau 1 an der
              ; Position letzte-stelle verändert.
              (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
        ; Führenden 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 Verfügung 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 für den Exponenten.
; Dann wird das Ganze mit padchars auf w Zeichen Breite aufgefüllt.
; Sollte das (auch nach evtl. Unterdrückung einer führenden Null) mehr als
; w Zeichen ergeben, so werden statt dessen w overflowchars ausgegeben, oder
; (falls overflowchar = nil) die Zahl mit so vielen Stellen wie nötig
; 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 für die Ziffern des
           ; Exponenten nötig 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 für die Mantisse (inkl. Vorzeichen, Punkt)
           ; zur Verfügung 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 für die Mantisse (ohne Vorzeichen,
          ; inklusive Punkt) zur Verfügung 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)
          ) ) )
    ) ) )
) )

; Rückt *FORMAT-CSDL* vor bis zum Ende des momentanen ~[ bzw. ~{ bzw. ~< .
(defun format-skip-to-end ()
  (do ()
      ((null (csd-clause-chain (car *FORMAT-CSDL*))))
    (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
) )

; (format-justified-segments mincol colinc minpad justify-left justify-right
;   piecelist) berechnet, an welchen Stellen zwischen den einzelnen Strings in
; piecelist wieviele Leerstellen zu setzen sind.
; Zwischen die einzelnen Strings aus piecelist (auch vorher, falls justify-left;
; auch nachher, falls justify-right) werden mindestens minpad padding-characters
; eingefügt. Dann werden nochmals weitere padding-characters dazugenommen,
; damit die Gesamtbreite >= mincol wird. Ist die Breite > mincol, werden weitere
; padding-characters dazugenommen, so daß die Breite von der Form
; mincol + k * colinc wird. Diese padding-characters werden auf die einzelnen
; Stellen gleichmäßig verteilt.
; 1. Wert: Ein Vektor, der zu jeder Stelle angibt, wieviele padding-characters
; einzufügen sind (NIL = keine).
; Erstes Element: ganz links, zweites: nach 1. String, ..., letztes: rechts.
; 2. Wert: Die sich ergebende Gesamtbreite.
(defun format-justified-segments
       (mincol colinc minpad justify-left justify-right piecelist)
  (declare (fixnum mincol colinc minpad))
  (let ((piecesnumber 0)
        (pieceswidth 0))
    (dolist (piece piecelist)
      (declare (simple-string piece))
      (incf piecesnumber)
      (incf pieceswidth (length piece))
    )
    (let* ((new-justify-left
             (or justify-left (and (= piecesnumber 1) (not justify-right))))
           (padblocks (+ piecesnumber -1       ; Anzahl der Einfüge-Stellen
                         (if new-justify-left 1 0) (if justify-right 1 0)
           )          )
           (width-need (+ pieceswidth (* padblocks minpad)))
           (width (+ mincol
                     (if (<= width-need mincol)
                         0
                         (* (ceiling (- width-need mincol) colinc) colinc)
          ))      )  )
      (declare (fixnum piecesnumber pieceswidth padblocks width-need width))
      (multiple-value-bind (padwidth rest) (floor (- width pieceswidth) padblocks)
        (let ((padblock-lengths
                (make-array (1+ piecesnumber) :initial-element padwidth)
             ))
          (unless new-justify-left (setf (svref padblock-lengths 0) nil))
          (unless justify-right (setf (svref padblock-lengths piecesnumber) nil))
          (do ((i 0 (1+ i)))
              ((zerop rest))
            (when (svref padblock-lengths i)
              (incf (svref padblock-lengths i))
              (decf rest)
          ) )
          (values padblock-lengths width)
) ) ) ) )

;-------------------------------------------------------------------------------

; ~A CLTL S.387-388
(defun format-ascii (stream colon-modifier atsign-modifier
             &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  (if (null mincol) (setq mincol 0))
  (if (null colinc) (setq colinc 1))
  (if (null minpad) (setq minpad 0))
  (if (null padchar) (setq padchar #\Space))
  (let ((arg (next-arg)))
    (when (and colon-modifier (null arg)) (setq arg "()"))
    (if (and (zerop mincol) (zerop minpad))
      (princ arg stream)
      (format-padded-string mincol colinc minpad padchar
        atsign-modifier ; =: padleftflag
        (princ-to-string arg)
        stream
) ) ) )

; ~S CLTL S.388
(defun format-s-expression (stream colon-modifier atsign-modifier
             &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  (if (null mincol) (setq mincol 0))
  (if (null colinc) (setq colinc 1))
  (if (null minpad) (setq minpad 0))
  (if (null padchar) (setq padchar #\Space))
  (let ((arg (next-arg)))
    (if (and (zerop mincol) (zerop minpad))
      (if (and colon-modifier (null arg))
        (write-string "()" stream)
        (prin1 arg stream)
      )
      (format-padded-string mincol colinc minpad padchar
        atsign-modifier ; =: padleftflag
        (if (and colon-modifier (null arg)) "()" (prin1-to-string arg))
        stream
) ) ) )

; ~W
(defun format-write (stream colon-modifier atsign-modifier
             &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  (declare (ignore colon-modifier))
  (if (null mincol) (setq mincol 0))
  (if (null colinc) (setq colinc 1))
  (if (null minpad) (setq minpad 0))
  (if (null padchar) (setq padchar #\Space))
  (let ((arg (next-arg)))
    (if (and (zerop mincol) (zerop minpad))
      (write arg :stream stream)
      (format-padded-string mincol colinc minpad padchar
        atsign-modifier ; =: padleftflag
        (write-to-string arg)
        stream
) ) ) )

; ~D, CLTL S.388
(defun format-decimal (stream colon-modifier atsign-modifier
                       &optional (mincol 0) (padchar #\Space) (commachar #\,))
  (format-base 10 stream colon-modifier atsign-modifier mincol padchar commachar)
)

; ~B, CLTL S.388
(defun format-binary (stream colon-modifier atsign-modifier
                      &optional (mincol 0) (padchar #\Space) (commachar #\,))
  (format-base 2 stream colon-modifier atsign-modifier mincol padchar commachar)
)

; ~O, CLTL S.388
(defun format-octal (stream colon-modifier atsign-modifier
                     &optional (mincol 0) (padchar #\Space) (commachar #\,))
  (format-base 8 stream colon-modifier atsign-modifier mincol padchar commachar)
)

; ~X, CLTL S.388-389
(defun format-hexadecimal (stream colon-modifier atsign-modifier
                        &optional (mincol 0) (padchar #\Space) (commachar #\,))
  (format-base 16 stream colon-modifier atsign-modifier mincol padchar commachar)
)

; ~R, CLTL S.389
(defun format-radix (stream colon-modifier atsign-modifier
            &optional (radix nil) (mincol 0) (padchar #\Space) (commachar #\,))
  (if (null mincol) (setq mincol 0))
  (if (null padchar) (setq padchar #\Space))
  (if (null commachar) (setq commachar #\,))
  (let ((arg (next-arg)))
    (if radix
      (format-integer radix mincol padchar commachar
                      colon-modifier atsign-modifier
                      arg stream
      )
      (if atsign-modifier
        (if (integerp arg)
          (if colon-modifier
            (format-old-roman arg stream)
            (format-new-roman arg stream)
          )
          (format-error *FORMAT-CS* nil
            (DEUTSCH "Die ~~R- und ~~:R-Direktiven erwarten ein Integer als Argument, nicht ~S"
             ENGLISH "The ~~R and ~~:R directives require an integer argument, not ~S"
             FRANCAIS "Les directives ~~R et ~~:R nécessitent un argument de type entier et non ~S")
            arg
        ) )
        (if colon-modifier
          (format-ordinal arg stream)
          (format-cardinal arg stream)
) ) ) ) )

; ~P, CLTL S. 389
(defun format-plural (stream colon-modifier atsign-modifier)
  (when colon-modifier (format-goto-new-arg t 1))
  (let ((singular (eql (next-arg) 1)))
    (if atsign-modifier
      (write-string (if singular "y" "ies") stream)
      (unless singular (write-char #\s stream))
) ) )

; ~C, CLTL S.389-390
(defun format-character (stream colon-modifier atsign-modifier)
  (let ((arg (next-arg)))
    (unless (characterp arg)
      (format-error *FORMAT-CS* nil
        (DEUTSCH "Die ~~C-Direktive erwartet ein Character, nicht ~S"
         ENGLISH "The ~~C directive requires a character argument, not ~S"
         FRANCAIS "La directive ~~C requiert un caractère et non ~S")
        arg
    ) )
    (flet ((write-charname (arg)
             (let ((name (char-name arg)))
               (if name
                 (write-string (string-capitalize name) stream)
                 (write-char arg stream)
          )) ) )
      (if (not atsign-modifier)
        ; ~C oder ~:C
        (progn
          (dolist (name '(:CONTROL :META :SUPER :HYPER))
            (when (char-bit arg name)
              (write-string (string-capitalize (symbol-name name)) stream
                            :end (if colon-modifier nil 1)
              )
              (write-char #\- stream)
          ) )
          (write-charname (make-char arg))
        )
        (if (not colon-modifier)
          ; ~@C
          (prin1 arg stream)
          ; ~:@C -- hier NUR die Anweisung, wie's zu tippen ist.
          (progn
            (let ((keynames '("Shift-" "Control-" "Alternate-")))
              (dolist (name '(:SUPER :CONTROL :META))
                (when (char-bit arg name)
                  (write-string (car keynames) stream)
                  (setq arg (set-char-bit arg name nil))
                )
                (setq keynames (cdr keynames))
            ) )
            (let* ((hyperkey-alist
                     #+(or ATARI DOS OS/2 UNIX AMIGA)
                     '(
     #-(or UNIX AMIGA) (#\Enter  . "Enter" )
               #-AMIGA (#\Insert . "Insert")
               #-AMIGA (#\End    . "End"   )
                       (#\Down   . #-ATARI "Down"  #+ATARI "")
               #-AMIGA (#\PgDn   . "PgDn"  )
                       (#\Left   . #-ATARI "Left"  #+ATARI "")
                #+UNIX (#\Center . "Center")
                       (#\Right  . #-ATARI "Right" #+ATARI "")
               #-AMIGA (#\Home   . #-ATARI "Home"  #+ATARI "Clr/Home")
                       (#\Up     . #-ATARI "Up"    #+ATARI "")
               #-AMIGA (#\PgUp   . "PgUp"  )
    #+(or ATARI AMIGA) (#\Help   . "Help"  )
               #+ATARI (#\Undo   . "Undo"  )
       #+(or DOS OS/2) (#\Prtscr . "PrtScr")
     #-(or UNIX AMIGA) (#\Delete . "Delete")
                       (#\F1     . "F1"    )
                       (#\F2     . "F2"    )
                       (#\F3     . "F3"    )
                       (#\F4     . "F4"    )
                       (#\F5     . "F5"    )
                       (#\F6     . "F6"    )
                       (#\F7     . "F7"    )
                       (#\F8     . "F8"    )
                       (#\F9     . "F9"    )
                       (#\F10    . "F10"   )
               #-AMIGA (#\F11    . "F11"   )
               #-AMIGA (#\F12    . "F12"   )
                      )
                     #-(or ATARI DOS OS/2 UNIX AMIGA)
                     '()
                   )
                   (acons (assoc arg hyperkey-alist)))
              (if acons
                (write-string (cdr acons) stream)
                (progn
                  (when (char-bit arg ':HYPER)
                    (write-string (DEUTSCH "Ziffernblock-"
                                   ENGLISH "Keypad-"
                                   FRANCAIS "bloc numérique ")
                                  stream
                    )
                    (setq arg (set-char-bit arg :HYPER nil))
                  )
                  (write-charname arg)
          ) ) ) )
) ) ) ) )

; ~F, CLTL S.390-392
(defun format-fixed-float (stream colon-modifier atsign-modifier
       &optional (w nil) (d nil) (k 0) (overflowchar nil) (padchar #\Space))
  (declare (ignore colon-modifier))
  (if (null k) (setq k 0))
  (if (null padchar) (setq padchar #\Space))
  (let ((arg (next-arg)))
    (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
(defun format-exponential-float (stream colon-modifier atsign-modifier
          &optional (w nil) (d nil) (e nil) (k 1)
                    (overflowchar nil) (padchar #\Space) (exponentchar nil))
  (declare (ignore colon-modifier))
  (if (null k) (setq k 1))
  (if (null padchar) (setq padchar #\Space))
  (let ((arg (next-arg)))
    (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
(defun format-general-float (stream colon-modifier atsign-modifier
          &optional (w nil) (d nil) (e nil) (k 1)
                    (overflowchar nil) (padchar #\Space) (exponentchar nil))
  (declare (ignore colon-modifier))
  (if (null k) (setq k 1))
  (if (null padchar) (setq padchar #\Space))
  (let ((arg (next-arg)))
    (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
(defun format-dollars-float (stream colon-modifier atsign-modifier
          &optional (d 2) (n 1) (w 0) (padchar #\Space) )
  (if (null d) (setq d 2))
  (if (null n) (setq n 1))
  (if (null w) (setq w 0))
  (if (null padchar) (setq padchar #\Space))
  (let ((arg (next-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)
) ) )

; ~%, CLTL S.397
(defun format-terpri (stream colon-modifier atsign-modifier &optional (count 1))
  (declare (ignore colon-modifier atsign-modifier))
  (if (null count) (setq count 1))
  (dotimes (i count) (terpri stream))
)

; ~&, CLTL S.397
(defun format-fresh-line (stream colon-modifier atsign-modifier
                          &optional (count 1))
  (declare (ignore colon-modifier atsign-modifier))
  (if (null count) (setq count 1))
  (when (plusp count)
    (fresh-line stream)
    (dotimes (i (1- count)) (terpri stream))
) )

; ~|, CLTL S.397
(defun format-page (stream colon-modifier atsign-modifier &optional (count 1))
  (declare (ignore colon-modifier atsign-modifier))
  (if (null count) (setq count 1))
  (dotimes (i count) (write-char #\Page stream))
)

; ~~, CLTL S.397
(defun format-tilde (stream colon-modifier atsign-modifier &optional (count 1))
  (declare (ignore colon-modifier atsign-modifier))
  (if (null count) (setq count 1))
  (dotimes (i count) (write-char #\~ stream))
)

; ~T, CLTL S.398-399
(defun format-tabulate (stream colon-modifier atsign-modifier
                        &optional (colnum 1) (colinc 1))
  (declare (ignore colon-modifier))
  (if (null colnum) (setq colnum 1))
  (if (null colinc) (setq colinc 1))
  (let* ((new-colnum (max colnum 0))
         (new-colinc (max colinc 1)) ; >0
         (pos (sys::line-position stream))) ; aktuelle Position, Fixnum >=0
    (if atsign-modifier
      (format-padding
        (+ new-colnum (mod (- (+ pos new-colnum)) new-colinc))
        #\Space stream
      )
      (if (< pos new-colnum)
        (format-padding (- new-colnum pos) #\Space stream)
        (unless (zerop colinc)
          (format-padding (+ colinc (mod (- new-colnum pos) (- colinc)))
                          #\Space stream
) ) ) ) ) )

; ~*, CLTL S.399
(defun format-goto (stream colon-modifier atsign-modifier &optional (index nil))
  (declare (ignore stream))
  (if atsign-modifier
    (setq *FORMAT-NEXT-ARG* (nthcdr (or index 0) *FORMAT-ARG-LIST*))
    (format-goto-new-arg colon-modifier (or index 1))
) )

; ~?, CLTL S.399-401
(defun format-indirection (stream colon-modifier atsign-modifier)
  (declare (ignore colon-modifier))
  (let ((csarg (next-arg)))
    (unless (stringp csarg)
      (format-error *FORMAT-CS* nil
        (DEUTSCH "Als Kontrollstring für ~~? ist das untauglich: ~S"
         ENGLISH "The control string argument for the ~~? directive is invalid: ~S"
         FRANCAIS "~S ne convient pas comme chaîne de contrôle pour ~~?.")
        csarg
    ) )
    ; evtl. noch csarg zu einem Simple-String machen ??
    (let ((node (list csarg)))
      (format-parse-cs csarg 0 node nil)
      (if atsign-modifier
        (let ((*FORMAT-CS* (car node))
              (*FORMAT-CSDL* (cdr node))
              (*FORMAT-UP-AND-OUT* nil))
          (format-interpret stream)
        )
        (let ((arglistarg (next-arg)))
          (unless (listp arglistarg)
            (format-error *FORMAT-CS* nil
              (DEUTSCH "Das ist keine passende Argumentliste für die ~~?-Direktive: ~S"
               ENGLISH "The argument list argument for the ~~? directive is invalid: ~S"
               FRANCAIS "Ceci n'est pas une liste d'arguments convenable pour la directive ~~? : ~S")
              arglistarg
          ) )
          (let* ((*FORMAT-CS* (car node))
                 (*FORMAT-CSDL* (cdr node))
                 (*FORMAT-ARG-LIST* arglistarg)
                 (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*))
            (format-interpret stream)
) ) ) ) ) )

; ~(, CLTL S.401
(defun format-case-conversion (stream colon-modifier atsign-modifier)
  (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  (let ((tempstr
          (let ((tempstream (make-string-output-stream (sys::line-position stream))))
            (format-interpret tempstream 'FORMAT-CASE-CONVERSION-END)
            (get-output-stream-string tempstream)
       )) )
    (if colon-modifier
      (if atsign-modifier
        (write-string (nstring-upcase tempstr) stream)
        (write-string (nstring-capitalize tempstr) stream)
      )
      (if atsign-modifier
        (progn
          (setq tempstr (nstring-downcase tempstr))
          (dotimes (i (length tempstr)) ; erstes Zeichen zum Upcase machen
            (when (both-case-p (schar tempstr i))
              (setf (schar tempstr i) (char-upcase (schar tempstr i)))
              (return)
          ) )
          (write-string tempstr stream)
        )
        (write-string (nstring-downcase tempstr) stream)
) ) ) )

; ~[, CLTL S.402-403
(defun format-conditional (stream colon-modifier atsign-modifier
                           &optional (prefix nil))
  (if colon-modifier
    (if atsign-modifier
      (format-error *FORMAT-CS* nil
        (DEUTSCH "~~[ geht nicht mit : und @ gleichzeitig."
         ENGLISH "The ~~[ directive cannot take both modifiers."
         FRANCAIS "La directive ~~[ ne peut pas accepter les deux qualificateurs : et @ en même temps.")
      )
      (progn
        (when (next-arg)
          (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
        )
        (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
        (format-interpret stream 'FORMAT-CONDITIONAL-END)
      )
    )
    (if atsign-modifier
      (when (next-arg)
        (format-goto-new-arg t 1)
        (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
        (format-interpret stream 'FORMAT-CONDITIONAL-END)
      )
      (let ((index (or prefix (next-arg))))
        (unless (integerp index)
          (format-error *FORMAT-CS* nil
            (DEUTSCH "Argument für ~~[ muß ein Integer sein, nicht ~S"
             ENGLISH "The ~~[ parameter must be an integer, not ~S"
             FRANCAIS "L'argument pour ~~[ doit être un entier et non ~S")
            index
        ) )
        (dotimes (i (if (minusp index) most-positive-fixnum index))
          (when (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
            (return)
          )
          (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
          (when (csd-colon-p (car *FORMAT-CSDL*)) (return))
        )
        (unless (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
          (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
        )
        (format-interpret stream 'FORMAT-CONDITIONAL-END)
  ) ) )
  (format-skip-to-end) ; Weiterrücken bis ans Ende der ~[...~]-Direktive
)

; ~{, CLTL S.403-404
(defun format-iteration (stream colon-modifier atsign-modifier
                         &optional (prefix nil))
  (let* ((total-csdl *FORMAT-CSDL*)
         (max-iteration-count prefix))
    (format-skip-to-end) ; Weiterrücken bis ans Ende der ~{...~}-Direktive
    (let* ((min-1-iteration (csd-colon-p (car *FORMAT-CSDL*)))
           (inner-cs (if (eq (cdr total-csdl) *FORMAT-CSDL*)
                       (next-arg)
                       *FORMAT-CS*
           )         )
           (inner-csdl (if (eq (cdr total-csdl) *FORMAT-CSDL*)
                         (let ((node (list inner-cs)))
                           (format-parse-cs inner-cs 0 node nil)
                           (cdr node)
                         )
                         (cdr total-csdl)
           )           )
           (arg-list-rest (if (not atsign-modifier)
                            (let ((arg (next-arg)))
                              (unless (listp arg)
                                (format-error *FORMAT-CS* nil
                                  (DEUTSCH "Das Argument zu ~~{ muß eine Liste sein, nicht ~S"
                                   ENGLISH "The ~~{ directive requires a list argument, not ~S"
                                   FRANCAIS "L'argument de ~~{ doit être une liste et non ~S")
                                  arg
                              ) )
                              arg
          ))              ) )
      (do* ((iteration-count 0 (1+ iteration-count)))
           ((or (and max-iteration-count
                     (>= iteration-count max-iteration-count)
                )
                (let ((remaining (if atsign-modifier
                                   *FORMAT-NEXT-ARG*
                                   arg-list-rest
                     ))          )
                  (if min-1-iteration
                    (and (plusp iteration-count) (null remaining))
                    (null remaining)
           ))   ) )
        (if colon-modifier
          (let* ((*FORMAT-ARG-LIST*
                   (if atsign-modifier (next-arg) (pop arg-list-rest))
                 )
                 (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
                 (*FORMAT-CS* inner-cs)
                 (*FORMAT-CSDL* inner-csdl)
                 (*FORMAT-UP-AND-OUT* nil))
            (format-interpret stream 'FORMAT-ITERATION-END)
            (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
          )
          (if atsign-modifier
            (let* ((*FORMAT-CS* inner-cs)
                   (*FORMAT-CSDL* inner-csdl)
                   (*FORMAT-UP-AND-OUT* nil))
              (format-interpret stream 'FORMAT-ITERATION-END)
              (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
            )
            (let* ((*FORMAT-ARG-LIST* arg-list-rest)
                   (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
                   (*FORMAT-CS* inner-cs)
                   (*FORMAT-CSDL* inner-csdl)
                   (*FORMAT-UP-AND-OUT* nil))
              (format-interpret stream 'FORMAT-ITERATION-END)
              (setq arg-list-rest *FORMAT-NEXT-ARG*)
              (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
) ) ) ) ) ) )

; ~<, CLTL S.404-406
(defun format-justification (stream colon-modifier atsign-modifier
       &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  (if (null mincol) (setq mincol 0))
  (if (null colinc) (setq colinc 1))
  (if (null minpad) (setq minpad 0))
  (if (null padchar) (setq padchar #\Space))
  (let* ((saved-csdl *FORMAT-CSDL*)
         (pos (sys::line-position stream))
         (tempstream (make-string-output-stream pos))
         (check-on-line-overflow nil)
         supplementary-need
         line-length
         (old-piecelist
           (let ((pieces nil))
             (do ((first-piece-flag t nil))
                 ((eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-JUSTIFICATION-END))
               (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
               (let ((*FORMAT-UP-AND-OUT* nil))
                 (format-interpret tempstream 'FORMAT-JUSTIFICATION-END)
                 (when (and first-piece-flag (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-SEPARATOR))
                   (when (setq check-on-line-overflow (csd-colon-p (car *FORMAT-CSDL*)))
                     (multiple-value-setq (supplementary-need line-length)
                       (values-list (format-resolve-parms (car *FORMAT-CSDL*)))
                 ) ) )
                 (when *FORMAT-UP-AND-OUT*
                   (setq *FORMAT-CSDL* saved-csdl)
                   (format-skip-to-end)
                   (return)
                 )
                 (push (get-output-stream-string tempstream) pieces)
             ) )
             (nreverse pieces)
         ) )
         (piecelist
           (if check-on-line-overflow (cdr old-piecelist) old-piecelist)
        ))
    (if piecelist
      (multiple-value-bind (padblocklengths width)
        (format-justified-segments mincol colinc minpad
          colon-modifier atsign-modifier piecelist)
        (when (and check-on-line-overflow
                   (> (+ pos width (or supplementary-need 0))
                      (or line-length #|(sys::line-length stream)|# 72)
              )    )
          (write-string (first old-piecelist) stream)
        )
        (do ((i 0 (1+ i)))
            (nil)
          (when (svref padblocklengths i)
            (format-padding (svref padblocklengths i) padchar stream)
          )
          (when (null piecelist) (return))
          (write-string (pop piecelist) stream)
      ) )
      (format-padding mincol padchar stream)
    )
) )

; ~^, CLTL S.406-407
(defun format-up-and-out (stream colon-modifier atsign-modifier
                          &optional (a nil) (b nil) (c nil))
  (declare (ignore stream atsign-modifier))
  (if (cond ((and (null a) (null b) (null c)) ; keine Parameter
             (null *FORMAT-NEXT-ARG*)
            )
            ((and (null b) (null c)) (eql a 0)) ; ein Parameter
            ((null c) (eql a b)) ; zwei Parameter
            ((and (integerp a) (integerp b) (integerp c)) (<= a b c))
            ((and (characterp a) (characterp b) (characterp c)) (char<= a b c))
      )
    (setq *FORMAT-UP-AND-OUT* (if colon-modifier ':TERMINATE-ALL ':TERMINATE))
) )

;-------------------------------------------------------------------------------

