home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / format.lsp < prev    next >
Encoding:
Text File  |  1994-12-19  |  74.5 KB  |  1,815 lines
  1. ; FORMAT - und was dazugeh÷rt.
  2. ; Bruno Haible 22.06.1988
  3. ; CLISP-Version 16.08.1988, 03.09.1988, 04.08.1989
  4. ; Gro▀ umgearbeitet von Bruno Haible am 14.02.1990-15.02.1990
  5.  
  6. (in-package "SYSTEM")
  7.  
  8. ;-------------------------------------------------------------------------------
  9.  
  10. ; Datenstruktur der Kontrollstring-Direktive:
  11. (defstruct (control-string-directive
  12.              (:copier nil)
  13.              (:conc-name "CSD-")
  14.              (:predicate nil)
  15.              (:constructor make-csd ())
  16.            )
  17.   (type         0 :type fixnum)
  18.   (cs-index     0 :type fixnum)
  19.   (parm-list    nil :type list)
  20.   (v-or-#-p     nil :type symbol)
  21.   (colon-p      nil :type symbol)
  22.   (atsign-p     nil :type symbol)
  23.   (data         nil)
  24.   (clause-chain nil)
  25. )
  26. #+CLISP (remprop 'control-string-directive 'sys::defstruct-description)
  27. ; ErlΣuterung:
  28. ; type=0 : Direktive ~<Newline>, nichts auszugeben.
  29. ;          Weitere Komponenten bedeutungslos
  30. ; type=1 : String auszugeben,
  31. ;          von *FORMAT-CS* die Portion :START cs-index :END data.
  32. ;          Weitere Komponenten bedeutungslos
  33. ; type=2 : Formatier-Direktive auszufⁿhren.
  34. ;          data = Name der Direktive (Symbol),
  35. ;          colon-p gibt an, ob ein ':' da war,
  36. ;          atsign-p gibt an, ob ein '@' da war,
  37. ;          parm-list = Parameterliste an die Direktive,
  38. ;          v-or-#-p gibt an, ob parm-list vor dem Aufruf noch zu behandeln ist.
  39. ;          clause-chain ist eine Verzeigerung: z.B. bei ~[...~;...~;...~]
  40. ;          von der ~[-Direktive auf die Liste ab der ersten ~;-Direktive,
  41. ;          von da auf die Liste ab der nΣchsten ~;-Direktive usw.
  42. ;          bis schlie▀lich auf die Liste ab der ~]-Direktive.
  43.  
  44. ; Zeigt an, ob ein Character ein Whitespace-Character ist.
  45. (defun whitespacep (char)
  46.   (member char '(#\Space #\Newline #\Linefeed #\Tab #\Return #\Page))
  47. )
  48.  
  49. ; (FORMAT-PARSE-CS control-string startindex csdl stop-at)
  50. ; parst einen Kontrollstring (genauer: (subseq control-string startindex))
  51. ; und legt die sich ergebende Control-String-Directive-Liste in (cdr csdl) ab.
  52. ; Das Parsen mu▀ mit der Direktive stop-at enden (ein Character, oder NIL
  53. ; fⁿr Stringende).
  54. ; Falls stop-at /= NIL, ist in (csd-clause-chain (car csdl)) ein Pointer auf
  55. ; die Teilliste ab dem nΣchsten Separator einzutragen. Diese Pointer bilden
  56. ; eine einfach verkettete Liste innerhalb csdl: von einem Separator zum
  57. ; nΣchsten, zum Schlu▀ zum Ende der Clause.
  58. (defun format-parse-cs (control-string startindex csdl stop-at)
  59.   (declare (fixnum startindex))
  60.   (macrolet ((errorstring ()
  61.                (DEUTSCH "Kontrollstring endet mitten in einer Direktive."
  62.                 ENGLISH "The control string terminates within a directive."
  63.                 FRANCAIS "La chaεne de contr⌠le se termine en plein milieu d'une directive.")
  64.             ))
  65.     (prog* ((index startindex) ; cs-index des nΣchsten Zeichens
  66.             ch ; current character
  67.             intparam ; Integer-Parameter
  68.             newcsd ; aktuelle CSD
  69.             (last-separator-csd (car csdl))
  70.            )
  71.       (declare (type simple-string control-string) (type fixnum index))
  72.       (loop ; neue Direktive insgesamt
  73.         (tagbody
  74.           (when (>= index (length control-string))
  75.             (go string-ended)
  76.           )
  77.           (setq ch (schar control-string index))
  78.           (unless (eql ch #\~)
  79.             ; eventuell noch Stringstⁿck zu einer eingenen Direktive machen
  80.             (setq csdl (setf (cdr csdl) (list (setq newcsd (MAKE-CSD)))))
  81.             (setf (csd-type     newcsd) 1)
  82.             (setf (csd-cs-index newcsd) index)
  83.             (setq index (position #\~ control-string :start index))
  84.             (unless index
  85.               (setf (csd-data newcsd) (setq index (length control-string)))
  86.               (go string-ended)
  87.             )
  88.             (setf (csd-data newcsd) index)
  89.           )
  90.           (setq csdl (setf (cdr csdl) (list (setq newcsd (MAKE-CSD)))))
  91.           (setf (csd-type         newcsd) 2)
  92.           (setf (csd-cs-index     newcsd) index)
  93.           (setf (csd-parm-list    newcsd) nil)
  94.           (setf (csd-v-or-#-p     newcsd) nil)
  95.           (setf (csd-colon-p      newcsd) nil)
  96.           (setf (csd-atsign-p     newcsd) nil)
  97.           (setf (csd-data         newcsd) nil)
  98.           (setf (csd-clause-chain newcsd) nil)
  99.  
  100.           param ; Parameter einer Direktive kann beginnen
  101.           (incf index)
  102.           (when (>= index (length control-string))
  103.             (format-error control-string index (errorstring))
  104.             (go string-ended)
  105.           )
  106.           (setq ch (schar control-string index))
  107.           (when (digit-char-p ch) (go num-param))
  108.           (case ch
  109.             ((#\+ #\-) (go num-param))
  110.             (#\' (go quote-param))
  111.             ((#\V #\v #\#)
  112.              (push (if (eql ch #\#) ':ARG-COUNT ':NEXT-ARG)
  113.                    (csd-parm-list newcsd)
  114.              )
  115.              (setf (csd-v-or-#-p newcsd) T)
  116.              (go param-ok-1)
  117.             )
  118.             (#\, (push nil (csd-parm-list newcsd)) (go param))
  119.             (#\: (go colon-modifier))
  120.             (#\@ (go atsign-modifier))
  121.             (T (go directive))
  122.           )
  123.  
  124.           num-param ; numerischer Parameter
  125.           (multiple-value-setq (intparam index)
  126.             (parse-integer control-string :start index :junk-allowed t)
  127.           )
  128.           (unless intparam
  129.             (format-error control-string index
  130.                           (DEUTSCH "~A mu▀ eine Zahl einleiten."
  131.                            ENGLISH "~A must introduce a number."
  132.                            FRANCAIS "~A doit introduire un nombre.")
  133.                           ch
  134.           ) )
  135.           (push intparam (csd-parm-list newcsd))
  136.           (go param-ok-2)
  137.  
  138.           quote-param ; Quote-Parameter-Behandlung
  139.           (incf index)
  140.           (when (>= index (length control-string))
  141.             (format-error control-string index
  142.               (DEUTSCH "Kontrollstring endet mitten in einem '-Parameter."
  143.                ENGLISH "The control string terminates in the middle of a parameter."
  144.                FRANCAIS "La chaεne de contr⌠le se termine au milieu d'un paramΦtre.")
  145.             )
  146.             (go string-ended)
  147.           )
  148.           (setq ch (schar control-string index))
  149.           (push ch (csd-parm-list newcsd))
  150.  
  151.           param-ok-1 ; Parameter OK
  152.           (incf index)
  153.           param-ok-2 ; Parameter OK
  154.           (when (>= index (length control-string))
  155.             (format-error control-string index (errorstring))
  156.             (go string-ended)
  157.           )
  158.           (setq ch (schar control-string index))
  159.           (case ch
  160.             (#\, (go param))
  161.             (#\: (go colon-modifier))
  162.             (#\@ (go atsign-modifier))
  163.             (T (go directive))
  164.           )
  165.  
  166.           colon-modifier ; nach :
  167.           (setf (csd-colon-p newcsd) T)
  168.           (go passed-modifier)
  169.  
  170.           atsign-modifier ; nach @
  171.           (setf (csd-atsign-p newcsd) T)
  172.           (go passed-modifier)
  173.  
  174.           passed-modifier ; nach : oder @
  175.           (incf index)
  176.           (when (>= index (length control-string))
  177.             (format-error control-string index (errorstring))
  178.             (go string-ended)
  179.           )
  180.           (setq ch (schar control-string index))
  181.           (case ch
  182.             (#\: (go colon-modifier))
  183.             (#\@ (go atsign-modifier))
  184.             (T (go directive))
  185.           )
  186.  
  187.           directive ; Direktive (ihr Name) erreicht
  188.           (setf (csd-parm-list newcsd) (nreverse (csd-parm-list newcsd)))
  189.           (let ((directive-name
  190.                   (cdr (assoc (char-upcase ch)
  191.                          '((#\A . FORMAT-ASCII)
  192.                            (#\S . FORMAT-S-EXPRESSION)
  193.                            (#\W . FORMAT-WRITE)
  194.                            (#\D . FORMAT-DECIMAL)
  195.                            (#\B . FORMAT-BINARY)
  196.                            (#\O . FORMAT-OCTAL)
  197.                            (#\X . FORMAT-HEXADECIMAL)
  198.                            (#\R . FORMAT-RADIX)
  199.                            (#\P . FORMAT-PLURAL)
  200.                            (#\C . FORMAT-CHARACTER)
  201.                            (#\F . FORMAT-FIXED-FLOAT)
  202.                            (#\E . FORMAT-EXPONENTIAL-FLOAT)
  203.                            (#\G . FORMAT-GENERAL-FLOAT)
  204.                            (#\$ . FORMAT-DOLLARS-FLOAT)
  205.                            (#\% . FORMAT-TERPRI)
  206.                            (#\& . FORMAT-FRESH-LINE)      (#\Newline . #\Newline)
  207.                            (#\| . FORMAT-PAGE)
  208.                            (#\~ . FORMAT-TILDE)
  209.                            (#\T . FORMAT-TABULATE)
  210.                            (#\* . FORMAT-GOTO)
  211.                            (#\? . FORMAT-INDIRECTION)
  212.                            (#\( . FORMAT-CASE-CONVERSION) (#\) . FORMAT-CASE-CONVERSION-END)
  213.                            (#\[ . FORMAT-CONDITIONAL)     (#\] . FORMAT-CONDITIONAL-END)
  214.                            (#\{ . FORMAT-ITERATION)       (#\} . FORMAT-ITERATION-END)
  215.                            (#\< . FORMAT-JUSTIFICATION)   (#\> . FORMAT-JUSTIFICATION-END)
  216.                            (#\^ . FORMAT-UP-AND-OUT)      (#\; . FORMAT-SEPARATOR)
  217.                            ; mit Funktionsdefinition      ; ohne Funktionsdefinition
  218.                )) )    )  )
  219.             (if directive-name
  220.               (setf (csd-data newcsd) directive-name)
  221.               (format-error control-string index
  222.                 (DEUTSCH "Diese Direktive gibt es nicht."
  223.                  ENGLISH "Non-existent directive"
  224.                  FRANCAIS "Directive non reconnue.")
  225.           ) ) )
  226.           (incf index)
  227.           (case ch
  228.             (( #\( #\[ #\{ #\< )
  229.              (multiple-value-setq (index csdl)
  230.                (format-parse-cs control-string index csdl
  231.                  (case ch (#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) )
  232.              ) )
  233.             )
  234.             (( #\) #\] #\} #\> )
  235.              (unless stop-at
  236.                (format-error control-string index
  237.                  (DEUTSCH "Schlie▀ende Klammer '~A' ohne vorherige ÷ffnende Klammer"
  238.                   ENGLISH "The closing directive '~A' does not have a corresponding opening one."
  239.                   FRANCAIS "ParenthΦse fermante '~A' sans parenthΦse ouvrante correspondante.")
  240.                  ch
  241.              ) )
  242.              (unless (eql ch stop-at)
  243.                (format-error control-string index
  244.                  (DEUTSCH "Schlie▀ende Klammer '~A' pa▀t nicht; sollte '~A' lauten."
  245.                   ENGLISH "The closing directive '~A' does not match the corresponding opening one. It should read '~A'."
  246.                   FRANCAIS "La parenthΦse fermante '~A' ne correspond pas α celle ouvrante. Il devrait y avoir '~A'.")
  247.                  ch stop-at
  248.              ) )
  249.              (setf (csd-clause-chain last-separator-csd) csdl)
  250.              (go end)
  251.             )
  252.             (#\;
  253.              (unless (or (eql stop-at #\]) (eql stop-at #\>))
  254.                (format-error control-string index
  255.                  (DEUTSCH "Hier ist keine ~~;-Direktive m÷glich."
  256.                   ENGLISH "The ~~; directive is not allowed at this point."
  257.                   FRANCAIS "La directive ~~; n'est pas permise ici.")
  258.              ) )
  259.              (setf (csd-clause-chain last-separator-csd) csdl)
  260.              (setq last-separator-csd newcsd)
  261.             )
  262.             (#\Newline
  263.              (setf (csd-type newcsd) 0)
  264.              (if (csd-colon-p newcsd)
  265.                (if (csd-atsign-p newcsd)
  266.                  (format-error control-string index
  267.                    (DEUTSCH "Die ~~Newline-Direktive ist mit : und @ sinnlos."
  268.                     ENGLISH "The ~~newline directive cannot take both modifiers."
  269.                     FRANCAIS "La directive ~~Newline est insensΘe avec les deux qualificateurs : et @.")
  270.                  )
  271.                  nil ; ~:<newline> -> Newline ignorieren, Whitespace dalassen
  272.                )
  273.                (progn
  274.                  (when (csd-atsign-p newcsd)
  275.                    ; ~@<newline> -> Stringstⁿck mit Newline zum Ausgeben
  276.                    (setf (csd-type newcsd) 1)
  277.                    (setf (csd-cs-index newcsd) (1- index))
  278.                    (setf (csd-data newcsd) index)
  279.                  )
  280.                  (setq index
  281.                    (or (position-if-not #'whitespacep control-string :start index)
  282.                        (length control-string)
  283.           ) )) ) ) )
  284.         ) ; tagbody zu Ende
  285.       ) ; loop zu Ende
  286.  
  287.       string-ended
  288.       (when stop-at
  289.         (format-error control-string index
  290.           (DEUTSCH "Schlie▀ende Klammer '~A' fehlt."
  291.            ENGLISH "An opening directive is never closed; expecting '~A'."
  292.            FRANCAIS "Il manque la borne fermante '~A'.")
  293.           stop-at
  294.       ) )
  295.  
  296.       end
  297.       (return (values index csdl))
  298. ) ) )
  299.  
  300. ;-------------------------------------------------------------------------------
  301.  
  302. (defvar *FORMAT-CS*) ; control-string
  303. (defvar *FORMAT-CSDL*) ; control-string directive list
  304. (defvar *FORMAT-ARG-LIST*) ; argument-list
  305. (defvar *FORMAT-NEXT-ARG*) ; pointer to next argument in argument-list
  306. (defvar *FORMAT-UP-AND-OUT* nil) ; reason for up-and-out
  307.  
  308. ; (format-error controlstring errorpos errorcode . arguments)
  309. ; signalisiert einen Error, der bei FORMAT aufgetreten ist. Die Stelle im
  310. ; Control-string wird mit einem Pfeil markiert.
  311. (defun format-error (controlstring errorpos errorstring &rest arguments)
  312.   (unless errorpos (setq errorpos (csd-cs-index (car *FORMAT-CSDL*))))
  313.   (setq errorstring
  314.     (string-concat errorstring
  315.       (DEUTSCH "~%Stelle im Kontrollstring:"
  316.        ENGLISH "~%Current point in control string:"
  317.        FRANCAIS "~%Position dans la chaεne de contr⌠le :")
  318.   ) )
  319.   (let ((pos1 0) (pos2 0))
  320.     (declare (simple-string errorstring) (fixnum pos1 pos2))
  321.     (loop
  322.       (setq pos2 (or (position #\Newline controlstring :start pos1)
  323.                      (length controlstring)
  324.       )          )
  325.       (setq errorstring (string-concat errorstring "~%  ~A"))
  326.       (setq arguments
  327.         (nconc arguments (list (substring controlstring pos1 pos2))) )
  328.       (when (<= pos1 errorpos pos2)
  329.         (setq errorstring
  330.           (string-concat errorstring "~%~VT"
  331.                          #+ATARI "" #+(or DOS OS/2) "" #-(or ATARI DOS OS/2) "|"
  332.         ) )
  333.         (setq arguments (nconc arguments (list (+ (- errorpos pos1) 2))))
  334.       )
  335.       (when (= pos2 (length controlstring)) (return))
  336.       (setq pos1 (+ pos2 1))
  337.   ) )
  338.   (apply #'error-of-type 'error errorstring arguments)
  339. )
  340.  
  341. ;-------------------------------------------------------------------------------
  342.  
  343. (defun format (destination control-string &rest arguments)
  344.   (unless (stringp control-string)
  345.     (error-of-type 'type-error
  346.       :datum control-string :expected-type 'string
  347.       (DEUTSCH "Kontrollstring mu▀ ein String sein, nicht ~S"
  348.        ENGLISH "The control-string must be a string, not ~S"
  349.        FRANCAIS "La chaεne de contr⌠le doit Ωtre une chaεne et non ~S")
  350.       control-string
  351.   ) )
  352.   ; evtl. noch control-string zu einem Simple-String machen ??
  353.   (let ((node (list control-string)))
  354.     (format-parse-cs control-string 0 node nil)
  355.     (let* ((*FORMAT-CS*         (car node))
  356.            (*FORMAT-CSDL*       (cdr node))
  357.            (*FORMAT-ARG-LIST*   arguments)
  358.            (*FORMAT-NEXT-ARG*   *FORMAT-ARG-LIST*)
  359.            (*FORMAT-UP-AND-OUT* nil))
  360.       (cond ((null destination)
  361.              (let ((stream (make-string-output-stream)))
  362.                (format-interpret stream)
  363.                (get-output-stream-string stream)
  364.             ))
  365.             ((eq destination 'T)
  366.              (format-interpret *STANDARD-OUTPUT*)
  367.              nil
  368.             )
  369.             ((streamp destination)
  370.              (format-interpret destination)
  371.              nil
  372.             )
  373.             ((stringp destination)
  374.              (if (array-has-fill-pointer-p destination)
  375.                (let ((stream (sys::make-string-push-stream destination)))
  376.                  (format-interpret stream)
  377.                )
  378.                (error-of-type 'error
  379.                  (DEUTSCH "String zum Vollschreiben ~S hat keinen Fill-Pointer."
  380.                   ENGLISH "The destination string ~S should have a fill pointer."
  381.                   FRANCAIS "La chaεne destination n'a pas de pointeur de remplissage.")
  382.                  destination
  383.              ) )
  384.              nil
  385.             )
  386.             (t (error-of-type 'type-error
  387.                  :datum destination :expected-type '(or (member nil t) stream string)
  388.                  (DEUTSCH "Das ist weder NIL noch T noch ein Stream noch ein String: ~S"
  389.                   ENGLISH "The destination argument ~S is invalid (not NIL or T or a stream or a string)."
  390.                   FRANCAIS "L'argument de destination n'est ni NIL, ni T, ni un ½stream╗ ni une chaεne : ~S")
  391.                  destination
  392.             )  )
  393. ) ) ) )
  394.  
  395. ;-------------------------------------------------------------------------------
  396.  
  397. ; (next-arg) liefert (und verbraucht) das nΣchste Argument aus der Argument-
  398. ; liste *FORMAT-NEXT-ARG*.
  399. (defun next-arg ()
  400.   (if (atom *FORMAT-NEXT-ARG*)
  401.     (format-error *FORMAT-CS* nil
  402.       (DEUTSCH "Nicht genⁿgend Argumente fⁿr diese Direktive ⁿbrig."
  403.        ENGLISH "There are not enough arguments left for this directive."
  404.        FRANCAIS "Il ne reste pas assez d'arguments pour cette directive.")
  405.     )
  406.     (pop *FORMAT-NEXT-ARG*)
  407. ) )
  408.  
  409. ; (format-interpret stream [endmarker]) interpretiert *FORMAT-CSDL* ab.
  410. ; Fluid vars:
  411. ;   *FORMAT-ARG-LIST*
  412. ;   *FORMAT-NEXT-ARG*
  413. ;   *FORMAT-CS*
  414. ;   *FORMAT-CSDL*
  415. ;   *FORMAT-UP-AND-OUT*
  416. ; Abbruch des Interpretierens bei Antreffen der Direktive endmarker
  417. ; oder der Direktive ~; .
  418. (defun format-interpret (stream &optional (endmarker nil))
  419.   (loop
  420.     (when *FORMAT-UP-AND-OUT* (return))
  421.     (when (endp *FORMAT-CSDL*) (return))
  422.     (let ((csd (car *FORMAT-CSDL*)))
  423.       (case (csd-type csd)
  424.         (0 )
  425.         (1 (write-string *FORMAT-CS* stream
  426.              :start (csd-cs-index csd) :end (csd-data csd)
  427.         )  )
  428.         (2 (let ((directive-name (csd-data csd)))
  429.              (if (eq directive-name endmarker) (return))
  430.              (if (eq directive-name 'FORMAT-SEPARATOR) (return))
  431.              (apply directive-name
  432.                stream
  433.                (csd-colon-p csd)
  434.                (csd-atsign-p csd)
  435.                (format-resolve-parms csd)
  436.         )  ) )
  437.     ) )
  438.     (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  439. ) )
  440.  
  441. ; liefert die korrekte Argumentliste einer CSD, evtl. mit eingesetzten
  442. ; Parametern: V (als :NEXT-ARG) und # (als :ARG-COUNT) werden aufgel÷st.
  443. (defun format-resolve-parms (csd)
  444.   (let ((arglist (csd-parm-list csd)))
  445.     (if (csd-v-or-#-p csd)
  446.       (mapcar #'(lambda (arg)
  447.                   (case arg
  448.                     (:NEXT-ARG (next-arg))
  449.                     (:ARG-COUNT (list-length *FORMAT-NEXT-ARG*))
  450.                     (T arg)
  451.                 ) )
  452.               arglist
  453.       )
  454.       arglist
  455. ) ) )
  456.  
  457. ; Bewegt den Stand des "Pointers in die Argumentliste" in eine Richtung.
  458. (defun format-goto-new-arg (backwardp index)
  459.   (if backwardp
  460.     ; rⁿckwΣrts
  461.     (setq *FORMAT-NEXT-ARG*
  462.       (nthcdr
  463.         (max (- (list-length *FORMAT-ARG-LIST*) (list-length *FORMAT-NEXT-ARG*) index) 0)
  464.         *FORMAT-ARG-LIST*
  465.     ) )
  466.     ; vorwΣrts ist einfacher:
  467.     (setq *FORMAT-NEXT-ARG* (nthcdr index *FORMAT-NEXT-ARG*))
  468. ) )
  469.  
  470. ; gibt arg als r÷mische Zahl auf stream aus, z.B. 4 als IIII.
  471. (defun format-old-roman (arg stream)
  472.   (unless (and (integerp arg) (<= 1 arg 4999))
  473.     (format-error *FORMAT-CS* nil
  474.       (DEUTSCH "Die ~~:@R-Direktive erwartet ein Integer zwischen 1 und 4999, nicht ~S"
  475.        ENGLISH "The ~~:@R directive requires an integer in the range 1 - 4999, not ~S"
  476.        FRANCAIS "La directive ~~:@R requiert un entier compris entre 1 et 4999 et non ~S")
  477.       arg
  478.   ) )
  479.   (do ((charlistr  '(#\M  #\D #\C #\L #\X #\V #\I) (cdr charlistr))
  480.        (valuelistr '(1000 500 100 50  10   5   1) (cdr valuelistr))
  481.        (value arg (multiple-value-bind (multiplicity restvalue)
  482.                       (floor value (first valuelistr))
  483.                     (dotimes (i multiplicity)
  484.                       (write-char (first charlistr) stream)
  485.                     )
  486.                     restvalue
  487.       ))          )
  488.       ((zerop value))
  489. ) )
  490.  
  491. ; gibt arg als r÷mische Zahl auf stream aus, z.B. 4 als IV.
  492. (defun format-new-roman (arg stream)
  493.   (unless (and (integerp arg) (<= 1 arg 3999))
  494.     (format-error *FORMAT-CS* nil
  495.       (DEUTSCH "Die ~~@R-Direktive erwartet ein Integer zwischen 1 und 3999, nicht ~S"
  496.        ENGLISH "The ~~@R directive requires an integer in the range 1 - 3999, not ~S"
  497.        FRANCAIS "La directive ~~@R requiert un entier compris entre 1 et 3999 et non ~S")
  498.       arg
  499.   ) )
  500.   (do ((charlistr       '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr))
  501.        (valuelistr     '(1000 500 100 50  10   5   1 ) (cdr valuelistr))
  502.        (lowercharlistr  '(#\C #\C #\X #\X #\I #\I    ) (cdr lowercharlistr))
  503.        (lowervaluelistr '(100 100 10  10   1   1   0 ) (cdr lowervaluelistr))
  504.        (value arg
  505.          (multiple-value-bind (multiplicity restvalue)
  506.              (floor value (first valuelistr))
  507.            (dotimes (i multiplicity) (write-char (first charlistr) stream))
  508.            (let ((loweredvalue (- (first valuelistr) (first lowervaluelistr))))
  509.              (if (>= restvalue loweredvalue)
  510.                (progn
  511.                  (write-char (first lowercharlistr) stream)
  512.                  (write-char (first charlistr) stream)
  513.                  (- restvalue loweredvalue)
  514.                )
  515.                restvalue
  516.       )) ) ) )
  517.       ((zerop value))
  518. ) )
  519.  
  520. (defconstant FORMAT-CARDINAL-ONES
  521.   '#(NIL "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
  522.      "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen"
  523.      "seventeen" "eighteen" "nineteen"
  524. )   )
  525.  
  526. (defconstant FORMAT-CARDINAL-TENS
  527.   '#(NIL NIL "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")
  528. )
  529.  
  530. ; (format-small-cardinal arg stream) gibt eine ganze Zahl >0, <1000 im
  531. ; Klartext auf englisch auf den stream aus. (arg=0 -> gibt nichts aus.)
  532. (defun format-small-cardinal (arg stream)
  533.   (multiple-value-bind (hundreds tens-and-ones) (truncate arg 100)
  534.     (when (> hundreds 0)
  535.       (write-string (svref FORMAT-CARDINAL-ONES hundreds) stream)
  536.       (write-string " hundred" stream)
  537.     )
  538.     (when (> tens-and-ones 0)
  539.       (when (> hundreds 0) (write-string " and " stream))
  540.       (multiple-value-bind (tens ones) (truncate tens-and-ones 10)
  541.         (if (< tens 2)
  542.           (write-string (svref FORMAT-CARDINAL-ONES tens-and-ones) stream)
  543.           (progn
  544.             (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
  545.             (when (> ones 0)
  546.               (write-char #\- stream)
  547.               (write-string (svref FORMAT-CARDINAL-ONES ones) stream)
  548. ) ) ) ) ) ) )
  549.  
  550. ; (format-cardinal arg stream) gibt die ganze Zahl arg im Klartext auf englisch
  551. ; auf den Stream aus.
  552. (defun format-cardinal (arg stream) ; arg Integer
  553.   (if (zerop arg)
  554.     (write-string "zero" stream)
  555.     (progn
  556.       (when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
  557.       (labels
  558.         ((blocks1000 (illions-list arg) ; Zerlegung in 1000er-Bl÷cke
  559.            (when (null illions-list)
  560.              (format-error *FORMAT-CS* nil
  561.                (DEUTSCH "Zu gro▀es Argument fⁿr ~~R-Direktive."
  562.                 ENGLISH "The argument for the ~~R directive is too large."
  563.                 FRANCAIS "L'argument pour la directive ~~R est trop grand.")
  564.            ) )
  565.            (multiple-value-bind (thousands small) (truncate arg 1000)
  566.              (when (> thousands 0) (blocks1000 (cdr illions-list) thousands))
  567.              (when (> small 0)
  568.                (when (> thousands 0) (write-string ", " stream))
  569.                (format-small-cardinal small stream)
  570.                (write-string (car illions-list) stream)
  571.         )) ) )
  572.         (blocks1000
  573.           ; amerikanisch (billion=10^9)
  574.           '("" " thousand" " million" " billion" " trillion" " quadrillion"
  575.             " quintillion" " sextillion" " septillion" " octillion" " nonillion"
  576.             " decillion" " undecillion" " duodecillion" " tredecillion"
  577.             " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
  578.             " octodecillion" " novemdecillion" " vigintillion")
  579.           arg
  580. ) ) ) ) )
  581.  
  582. (defconstant FORMAT-ORDINAL-ONES
  583.   '#(NIL "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth"
  584.      "ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
  585.      "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"
  586. )   )
  587.  
  588. ; (format-ordinal arg stream) gibt eine ganze Zahl arg als AbzΣhlnummer im
  589. ; Klartext auf englisch auf den stream aus.
  590. (defun format-ordinal (arg stream) ; arg Integer
  591.   (if (zerop arg)
  592.     (write-string "zeroth" stream)
  593.     (progn
  594.       (when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
  595.       (multiple-value-bind (hundreds tens-and-ones) (floor arg 100)
  596.         (when (> hundreds 0) (format-cardinal (* hundreds 100) stream))
  597.         (if (zerop tens-and-ones)
  598.           (write-string "th" stream)
  599.           (multiple-value-bind (tens ones) (floor tens-and-ones 10)
  600.             (when (> hundreds 0) (write-char #\Space stream))
  601.             (cond ((< tens 2)
  602.                    (write-string (svref FORMAT-ORDINAL-ONES tens-and-ones) stream)
  603.                   )
  604.                   ((zerop ones)
  605.                    (write-string
  606.                      (svref '#(NIL "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth"
  607.                                "sixtieth" "seventieth" "eightieth" "ninetieth")
  608.                             tens
  609.                      )
  610.                      stream
  611.                   ))
  612.                   (t (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
  613.                      (write-char #\- stream)
  614.                      (write-string (svref FORMAT-ORDINAL-ONES ones) stream)
  615. ) ) ) ) ) ) )     )
  616.  
  617. ; (format-padding count char stream) gibt count (ein Fixnum >=0) Zeichen char
  618. ; auf stream aus.
  619. (defun format-padding (count char stream)
  620.   (dotimes (i count) (write-char char stream))
  621. )
  622.  
  623. ; gibt auf den Stream stream aus:
  624. ; den String str, eventuell aufgefⁿllt mit Padding characters padchar.
  625. ; Und zwar so, da▀ die Breite mindestens mincol ist. Um das zu erreichen,
  626. ; werden mindestens minpad Zeichen eingefⁿgt, eventuelle weitere dann in
  627. ; Bl÷cken α colinc Zeichen. Falls padleftflag, werden sie links eingefⁿgt,
  628. ; sonst rechts vom String.
  629. (defun format-padded-string
  630.        (mincol colinc minpad padchar padleftflag str stream)
  631.   (let* ((need (+ (length str) minpad)) ; so viele Zeichen mindestens
  632.          (auxpad (if (< need mincol)
  633.                    (* (ceiling (- mincol need) colinc) colinc)
  634.                    0
  635.         ))       ) ; so viele Zeichen zusΣtzlich
  636.     (unless padleftflag (write-string str stream))
  637.     (format-padding (+ minpad auxpad) padchar stream)
  638.     (when padleftflag (write-string str stream))
  639. ) )
  640.  
  641. ; gibt den Integer arg auf den Stream aus:
  642. ; in Zahlenbasis base, mit Vorzeichen (+ nur falls >0 und positive-sign-flag),
  643. ; bei commaflag alle drei Stellen unterbrochen durch ein Zeichen commachar.
  644. ; Das Ganze links aufgefⁿllt mit padchar's, so da▀ die Gesamtbreite mindestens
  645. ; mincol ist.
  646. (defun format-integer (base
  647.                        mincol
  648.                        padchar
  649.                        commachar
  650.                        commaflag
  651.                        positive-sign-flag
  652.                        arg
  653.                        stream
  654.                       )
  655.   (let* ((*print-base* base)
  656.          (*print-radix* nil)
  657.          (*print-readably* nil))
  658.     (if (and (zerop mincol) (not commaflag) (not positive-sign-flag))
  659.       (princ arg stream) ; normale Ausgabe tut's
  660.       (let* ((oldstring (princ-to-string arg))
  661.              (oldstring-length (length oldstring))
  662.              (number-of-digits
  663.                (if (minusp arg) (1- oldstring-length) oldstring-length) )
  664.              (number-of-commas
  665.                (if commaflag (floor (1- number-of-digits) 3) 0) )
  666.              (positive-sign (and positive-sign-flag (> arg 0)))
  667.              (newstring-length
  668.                (+ (if positive-sign 1 0) ; Vorzeichen
  669.                   oldstring-length number-of-commas ; Ziffern, Kommas
  670.              ) )
  671.              (newstring (make-string newstring-length)) )
  672.         ; Erst Vorzeichen +:
  673.         (when positive-sign (setf (schar newstring 0) #\+))
  674.         ; Dann oldstring in newstring ⁿbertragen, dabei Kommata ⁿberspringen:
  675.         (let ((oldpos oldstring-length) (newpos newstring-length))
  676.           (loop
  677.             (decf oldpos)
  678.             (when (minusp oldpos) (return))
  679.             (decf newpos)
  680.             (setf (schar newstring newpos) (schar oldstring oldpos))
  681.             (when (and (plusp number-of-commas)
  682.                        (zerop (mod (- oldstring-length oldpos) 3))
  683.                   ) ; noch ein Komma einzufⁿgen?
  684.               (decf newpos)
  685.               (setf (schar newstring newpos) commachar)
  686.               (decf number-of-commas)
  687.         ) ) )
  688.         (if (zerop mincol)
  689.           (write-string newstring stream) ; schneller
  690.           (format-padded-string mincol 1 0 padchar t newstring stream)
  691. ) ) ) ) )
  692.  
  693. ; was ~D bei non-Integer-Argument tut: Argument mit ~A, aber dezimal ausgeben
  694. (defun format-ascii-decimal (arg stream)
  695.   (let ((*print-base* 10.)
  696.         (*print-radix* nil)
  697.         (*print-readably* nil))
  698.     (princ arg stream)
  699. ) )
  700.  
  701. ; Unterprogramm fⁿr ~D, ~B, ~O, ~X:
  702. (defun format-base (base stream colon-modifier atsign-modifier
  703.                     mincol padchar commachar)
  704.   (if (null mincol) (setq mincol 0))
  705.   (if (null padchar) (setq padchar #\Space))
  706.   (if (null commachar) (setq commachar #\,))
  707.   (let ((arg (next-arg)))
  708.     (if (or (and (zerop mincol) (not colon-modifier) (not atsign-modifier))
  709.             (not (integerp arg))
  710.         )
  711.       (let ((*print-base* base)
  712.             (*print-radix* nil)
  713.             (*print-readably* nil))
  714.         (princ arg stream)
  715.       )
  716.       (format-integer base mincol padchar commachar
  717.                       colon-modifier atsign-modifier arg stream
  718. ) ) ) )
  719.  
  720. ; (format-scale-exponent-aux arg null eins zehn zehntel lg2)
  721. ; liefert zur Floating-Point-Zahl arg >= 0 und
  722. ; null = 0.0, eins = 1.0, zehn = 10.0, zehntel = 0.1, lg2 = log(2)/log(10)
  723. ; (erste vier in derselben Floating-Point-Precision wie arg)
  724. ; zwei Werte: mantissa und n, mit
  725. ; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
  726. ; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
  727. ; (Bei arg=null: null und n=0.)
  728. (defun format-scale-exponent-aux (arg null eins zehn zehntel lg2)
  729.   (multiple-value-bind (significand expon) (decode-float arg)
  730.     (declare (ignore significand))
  731.     (if (zerop arg)
  732.       (values null 0)
  733.       (let* ((expon10a (truncate (* expon lg2))) ; nicht round, um ▄berlauf zu vermeiden
  734.              (signif10a (/ arg (expt zehn expon10a))))
  735.         (do ((zehnpot zehn (* zehnpot zehn))
  736.              (signif10b signif10a (/ signif10a zehnpot))
  737.              (expon10b expon10a (1+ expon10b)))
  738.             ((< signif10b eins)
  739.              (do ((zehnpot zehn (* zehnpot zehn))
  740.                   (signif10c signif10b (* signif10c zehnpot))
  741.                   (expon10c expon10b (1- expon10c)))
  742.                  ((>= signif10c zehntel)
  743.                   (values signif10c expon10c)
  744.              )   )
  745.         )   )
  746. ) ) ) )
  747.  
  748. ; (format-scale-exponent arg) liefert zur Floating-Point-Zahl arg >= 0
  749. ; zwei Werte: mantissa und n, mit
  750. ; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
  751. ; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
  752. ; (Bei arg=null: 0.0 und n=0.)
  753. (defun format-scale-exponent (arg)
  754.   (cond ((short-float-p arg)
  755.          (format-scale-exponent-aux arg 0.0s0 1.0s0 10.0s0 0.1s0 0.30103s0)
  756.         )
  757.         ((single-float-p arg)
  758.          (format-scale-exponent-aux arg 0.0f0 1.0f0 10.0f0 0.1f0 0.30103s0)
  759.         )
  760.         ((double-float-p arg)
  761.          (format-scale-exponent-aux arg 0.0d0 1.0d0 10.0d0 0.1d0 0.30103s0)
  762.         )
  763.         ((long-float-p arg)
  764.          (format-scale-exponent-aux arg
  765.            (float 0 arg) (float 1 arg) (float 10 arg) (float 1/10 arg)
  766.            0.30102999566d0 ; lg2 wird mit 32 Bit Genauigkeit gebraucht
  767. ) )     ))
  768.  
  769. ; (format-float-to-string arg width d k dmin)
  770. ; ergibt einen String zum Floating-point arg:
  771. ; er hat den Wert von (* (abs arg) (expt 10 k)), dabei mind. d Nachkommastellen
  772. ; und h÷chstens die LΣnge width (width=nil -> keine EinschrΣnkung).
  773. ; Trotzdem wird nicht auf weniger als dmin Stellen gerundet.
  774. (let ((digit-string
  775.         (make-array 20 :element-type 'string-char :adjustable t :fill-pointer t)
  776.      ))
  777. (defun format-float-to-string (arg width d k dmin)
  778.   (if (zerop arg)
  779.     (let ((places (max (or d 0) (or dmin 0))))
  780.       (when width ; width angegeben -> places := (min places (1- width))
  781.         (when (>= places width) (setq places (1- width)))
  782.       )
  783.       (values
  784.         (let ((str (make-string (1+ places) :initial-element #\0)))
  785.           (setf (schar str 0) #\.)
  786.           str          ; ein Punkt und places Nullen
  787.         )
  788.         (1+ places)    ; Stellenzahl
  789.         t              ; Punkt ganz vorne
  790.         (zerop places) ; Punkt ganz hinten ?
  791.         0              ; Position des Punktes
  792.     ) )
  793.     (multiple-value-bind (significand expon) (integer-decode-float arg)
  794. ; significand : Integer >0
  795. ; expon : Integer
  796. ; mantprec : Anzahl der echten Mantissenbits von significand
  797. ; (also 2^mantprec <= significand < 2^(mantprec+1))
  798. ; width : Anzahl Stellen, die die Zahl (inklusive Punkt) nicht ⁿberschreiten
  799. ;         soll, oder NIL
  800. ; d : Mindestanzahl Nachkommastellen oder NIL
  801. ; k : Skalierungsfaktor (siehe CLTL S.394)
  802. ; dmin : Mindestanzahl von Dezimaltellen, die (trotz Angabe von width oder d)
  803. ;        nicht gerundet werden dⁿrfen.
  804. ;        (Nur interessant, falls d <= dmin <= (precision der Zahl).)
  805. ; wandelt die Zahl significand*2^expon um in einen Dezimalstring um.
  806. ; Es ist kein Exponent dabei.
  807.       (let* ((mantprec (1- (float-digits arg)))
  808.              (numerator significand)
  809.              (denominator 1)
  810.              (abrund-einh 1) ; Abrundungseinheit:
  811.                ; Abrunden um 1 in der letzten abrundbaren Stelle entspricht
  812.                ; einer Erniedrigung von numerator um abrund-einh.
  813.              (aufrund-einh 1) ; Aufrundungseinheit:
  814.                ; Aufrunden um 1 in der letzten aufrundbaren Stelle entspricht
  815.                ; einer Erh÷hung von numerator um aufrund-einh.
  816.              ; Stellen: 0 = 1. Stelle vor dem Punkt, -1 = 1. Stelle nach dem Punkt.
  817.              (stelle 0) ; Stelle der als nΣchstes auszugebenden Ziffer
  818.              (digit-count 0) ; Zahl der bisher in digit-string ausgegebenen
  819.                              ; Ziffern (exklusive den Punkt)
  820.              (point-pos 0) ; Punkt-Position = Zahl fⁿhrender Stellen
  821.                            ; = Zahl der Ziffern vor dem Punkt
  822.              (letzte-stelle nil) ; NIL oder (falls d oder width angegeben waren)
  823.                            ; Stelle der letzten signifikanten Ziffer
  824.              (halbzahlig nil) ; zeigt an, ob hinten genau ein 0.500000 wegfΣllt
  825.              digit ; die laufende Ziffer, >=0, <10
  826.              (abrunden nil) ; T falls letzte Ziffer abzurunden ist
  827.              (aufrunden nil) ; T falls letzte Ziffer aufzurunden ist
  828.             )
  829.         (setf (fill-pointer digit-string) 0) ; digit-string leeren
  830.         (cond
  831.           ((> expon 0)
  832.            (setq numerator (ash significand expon))
  833.            (setq aufrund-einh (setq abrund-einh (ash 1 expon)))
  834.           )
  835.           ((< expon 0)
  836.            (setq denominator (ash 1 (- expon))) ; aufrund-einh = abrund-einh = 1
  837.         ) )
  838.         ; Zahl = numerator/denominator
  839.         (when (= significand (ash 1 mantprec))
  840.           ; Ist der Significand=2^mantprec, so ist abrund-einh zu halbieren.
  841.           ; Man kann stattdessen auch alle 3 anderen Gr÷ssen verdoppeln:
  842.           (setq aufrund-einh (ash aufrund-einh 1))
  843.           (setq numerator (ash numerator 1))
  844.           (setq denominator (ash denominator 1))
  845.         )
  846.         ; DefaultmΣ▀ig: Auf-/Abrunde-Einheit = eine Einheit in der letzten
  847.         ; BIN─Rstelle.
  848.         ; Zahl = numerator/denominator
  849.         ; Skalierungsfaktor k in die Zahl mit einbeziehen (vgl. CLTL S.394)
  850.         ; k<0 -> Mantisse durch 10^(abs k) dividieren
  851.         ; k>0 -> Mantisse mit 10^k multiplizieren
  852.         ; Dabei aufrund-einh, abrund-einh im VerhΣltnis zu numerator beibehalten.
  853.         (when k
  854.           (if (< k 0)
  855.             (let ((skal-faktor (expt 10 (- k))))
  856.               (setq denominator (* denominator skal-faktor))
  857.             )
  858.             (let ((skal-faktor (expt 10 k)))
  859.               (setq numerator (* numerator skal-faktor))
  860.               (setq aufrund-einh (* aufrund-einh skal-faktor))
  861.               (setq abrund-einh (* abrund-einh skal-faktor))
  862.             )
  863.         ) )
  864.         ; auf >= 1/10 adjustieren:
  865.         ; (jeweils numerator mit 10 multiplizieren, eine fⁿhrende 0 mehr vorsehen)
  866.         (do ()
  867.             ((>= (* numerator 10) denominator))
  868.           (setq stelle (1- stelle))
  869.           (setq numerator (* numerator 10))
  870.           (setq abrund-einh (* abrund-einh 10))
  871.           (setq aufrund-einh (* aufrund-einh 10))
  872.         )
  873.         ; stelle = Stelle der letzten fⁿhrenden 0
  874.         ;        = 1 + Stelle der 1. signifikanten Ziffer
  875.         ;        oder =0, falls k>=0
  876.         ; Ausfⁿhrung der Rundung:
  877.         (loop
  878.           ; Solange das Ergebnis auch nach Aufrundung >= 1 bliebe,
  879.           ; eine Vorkommastelle mehr einplanen:
  880.           (do ()
  881.               ((< (+ (ash numerator 1) aufrund-einh) (ash denominator 1)))
  882.             (setq denominator (* denominator 10))
  883.             (setq stelle (1+ stelle))
  884.           )
  885.           ; Falls d oder width angegeben:
  886.           ; letzte-stelle ausrechnen
  887.           (if d
  888.             ; Falls dmin angegeben: (min (- d) (- dmin)) = (- (max d dmin)).
  889.             ; Sonst (- d).
  890.             (progn
  891.               (setq letzte-stelle (- d))
  892.               (when (and dmin (> letzte-stelle (- dmin)))
  893.                 (setq letzte-stelle (- dmin))
  894.             ) )
  895.             ; Falls nicht d, nur width angegeben:
  896.             (when width
  897.               (if (< stelle 0)
  898.                 ; Es kommen fⁿhrende Nullen nach dem Punkt -> d:=(1- width)
  899.                 (setq letzte-stelle (- 1 width))
  900.                 ; Es kommen keine fⁿhrenden Nullen nach dem Punkt ->
  901.                 ; Es wird stelle Vorkommaziffern geben, d:=(- (1- width) stelle)
  902.                 (setq letzte-stelle (1+ (- stelle width)))
  903.               )
  904.               ; also letzte-stelle = (- (- (1- width) (max stelle 0)))
  905.               ; wieder dmin berⁿcksichtigen:
  906.               (when (and dmin (> letzte-stelle (- dmin)))
  907.                 (setq letzte-stelle (- dmin))
  908.           ) ) )
  909.           (when (or d width)
  910.             (let* ((ziffernzahl (- letzte-stelle stelle))
  911.                    ; ziffernzahl = Zahl signifikanter Stellen oder <0.
  912.                    (dezimal-einh denominator))
  913.               ; dezimal-einh := (ceiling (* dezimal-einh (expt 10 ziffernzahl)))
  914.               (if (>= ziffernzahl 0)
  915.                 (dotimes (i ziffernzahl)
  916.                   (setq dezimal-einh (* dezimal-einh 10))
  917.                 )
  918.                 (dotimes (i (- ziffernzahl))
  919.                   (setq dezimal-einh (ceiling dezimal-einh 10))
  920.                 )
  921.               )
  922.               ; dezimal-einh = Um wieviel numerator erh÷ht bzw. erniedigt werden
  923.               ; mⁿ▀te, damit sich die Dezimaldarstellung um genau 1 an der
  924.               ; Position letzte-stelle verΣndert.
  925.               (setq abrund-einh (max dezimal-einh abrund-einh))
  926.               (setq aufrund-einh (max dezimal-einh aufrund-einh))
  927.               ; Jetzt darf auch um eine (halbe) DEZIMAL-Einheit gerundet werden.
  928.               (when (= aufrund-einh dezimal-einh) (setq halbzahlig T))
  929.           ) )
  930.           (when (< (+ (ash numerator 1) aufrund-einh) (ash denominator 1))
  931.             (return)
  932.         ) )
  933.         ; stelle = Position der ersten signifikanten Stelle + 1
  934.         ; Fⁿhrenden Punkt und nachfolgende Nullen ausgeben:
  935.         (when (< stelle 0)
  936.           (setq point-pos digit-count)
  937.           (vector-push-extend #\. digit-string)
  938.           (dotimes (i (- stelle))
  939.             (incf digit-count)
  940.             (vector-push-extend #\0 digit-string)
  941.         ) )
  942.         ; Ziffern der Mantisse ausgeben:
  943.         (loop
  944.           (when (zerop stelle)
  945.             (vector-push-extend #\. digit-string)
  946.             (setq point-pos digit-count)
  947.           )
  948.           (decf stelle)
  949.           (multiple-value-setq (digit numerator)
  950.             (truncate (* numerator 10) denominator)
  951.           )
  952.           (setq abrund-einh (* abrund-einh 10))
  953.           (setq aufrund-einh (* aufrund-einh 10))
  954.           (setq abrunden (< (ash numerator 1) abrund-einh))
  955.           (if halbzahlig
  956.             (setq aufrunden
  957.               (>= (ash numerator 1) (- (ash denominator 1) aufrund-einh))
  958.             )
  959.             (setq aufrunden
  960.               (> (ash numerator 1) (- (ash denominator 1) aufrund-einh))
  961.             )
  962.           )
  963.           (when (or abrunden aufrunden
  964.                     (and letzte-stelle (<= stelle letzte-stelle))
  965.                 )
  966.             (return)
  967.           )
  968.           (vector-push-extend (schar "0123456789" digit) digit-string)
  969.           (incf digit-count)
  970.         )
  971.         ; letzte signifikante Ziffer ausgeben:
  972.         (when (or (null letzte-stelle) (>= stelle letzte-stelle))
  973.           (vector-push-extend
  974.             (schar "0123456789"
  975.               (cond
  976.                 ((and abrunden (not aufrunden)) digit)
  977.                 ((and aufrunden (not abrunden)) (1+ digit))
  978.                 ((<= (ash numerator 1) denominator) digit)
  979.                 (t (1+ digit))
  980.             ) )
  981.             digit-string
  982.           )
  983.           (incf digit-count)
  984.         )
  985.         ; Nachfolgende Nullen und Punkt ausgeben
  986.         (when (>= stelle 0)
  987.           (dotimes (i stelle)
  988.             (incf digit-count)
  989.             (vector-push-extend #\0 digit-string)
  990.           )
  991.           (vector-push-extend #\. digit-string)
  992.           (setq point-pos digit-count)
  993.         )
  994.         (when d
  995.           (dotimes (i (- d (- digit-count point-pos)))
  996.             (incf digit-count)
  997.             (vector-push-extend #\0 digit-string)
  998.         ) )
  999.         (values
  1000.                   digit-string               ; Ziffern
  1001.                   (1+ digit-count)           ; Anzahl der Ziffern
  1002.                   (= point-pos 0)            ; Punkt ganz vorne?
  1003.                   (= point-pos digit-count)  ; Punkt ganz hinten?
  1004.                   point-pos                  ; Position des Punktes
  1005.         ) ; 5 Werte
  1006. ) ) ) )
  1007. )
  1008.  
  1009. ; (format-float-for-f w d k overflowchar padchar plus-sign-flag arg stream)
  1010. ; gibt die Floating-Point-Zahl arg in Festkommadarstellung auf stream aus.
  1011. (defun format-float-for-f (w d k overflowchar padchar plus-sign-flag arg stream)
  1012.   (let ((width (if w (if (or plus-sign-flag (minusp arg)) (1- w) w) nil)))
  1013.     ; width = zur Verfⁿgung stehende Zeichen ohne Vorzeichen
  1014.     (multiple-value-bind (digits digitslength leadingpoint trailingpoint)
  1015.         (format-float-to-string arg width d k nil)
  1016.       (when (eql d 0) (setq trailingpoint nil)) ; d=0 -> keine Zusatz-Null hinten
  1017.       (when w
  1018.         (setq width (- width digitslength))
  1019.         (when leadingpoint ; evtl. Zusatz-Null vorne einplanen
  1020.           (if (> width 0) (setq width (1- width)) (setq leadingpoint nil))
  1021.         )
  1022.         (when trailingpoint ; evtl. Zusatz-Null hinten einplanen
  1023.           (if (> width 0) (setq width (1- width)) (setq trailingpoint nil))
  1024.         )
  1025.       )
  1026.       ; Es bleiben noch width Zeichen ⁿbrig.
  1027.       (if (and overflowchar w (minusp width))
  1028.         (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
  1029.         (progn
  1030.           (when (and w (> width 0)) (format-padding width padchar stream))
  1031.           (if (minusp arg)
  1032.             (write-char #\- stream)
  1033.             (if plus-sign-flag (write-char #\+ stream))
  1034.           )
  1035.           (when leadingpoint (write-char #\0 stream))
  1036.           (write-string digits stream)
  1037.           (when trailingpoint (write-char #\0 stream))
  1038.       ) )
  1039. ) ) )
  1040.  
  1041. ; (format-float-for-e w d e k overflowchar padchar exponentchar plus-sign-flag
  1042. ;                     arg stream)
  1043. ; gibt die Floating-point-Zahl arg in Exponentialdarstellung auf den stream aus.
  1044. ; (vgl. CLTL S.392-394)
  1045. ; Aufteilung der Mantisse:
  1046. ;   Falls k<=0, erst 1 Null (falls von der Breite her passend), dann der Punkt,
  1047. ;               dann |k| Nullen, dann d-|k| signifikante Stellen;
  1048. ;               zusammen also d Nachkommastellen.
  1049. ;   Falls k>0,  erst k signifikante Stellen, dann der Punkt,
  1050. ;               dann weitere d-k+1 signifikante Stellen;
  1051. ;               zusammen also d+1 signifikante Stellen. Keine Nullen vorne.
  1052. ;   (Der Defaultwert in FORMAT-EXPONENTIAL-FLOAT ist k=1.)
  1053. ; Vor der Mantisse das Vorzeichen (ein + nur falls arg>=0 und plus-sign-flag).
  1054. ; Dann der Exponent, eingeleitet durch exponentchar, dann Vorzeichen des
  1055. ; Exponenten (stets + oder -), dann e Stellen fⁿr den Exponenten.
  1056. ; Dann wird das Ganze mit padchars auf w Zeichen Breite aufgefⁿllt.
  1057. ; Sollte das (auch nach evtl. Unterdrⁿckung einer fⁿhrenden Null) mehr als
  1058. ; w Zeichen ergeben, so werden statt dessen w overflowchars ausgegeben, oder
  1059. ; (falls overflowchar = nil) die Zahl mit so vielen Stellen wie n÷tig
  1060. ; ausgegeben.
  1061. (defun format-float-for-e (w d e k
  1062.        overflowchar padchar exponentchar plus-sign-flag arg stream)
  1063.   (multiple-value-bind (mantissa oldexponent) (format-scale-exponent (abs arg))
  1064.     (let* ((exponent (if (zerop arg) 0 (- oldexponent k))) ; auszugebender Exponent
  1065.            (expdigits (write-to-string (abs exponent) :base 10. :radix nil :readably nil))
  1066.            (expdigitsneed (if e (max (length expdigits) e) (length expdigits)))
  1067.            ; expdigitsneed = Anzahl der Stellen, die fⁿr die Ziffern des
  1068.            ; Exponenten n÷tig sind.
  1069.            (mantd (if d (if (> k 0) (1+ (- d k)) d) nil))
  1070.            ; mantd = Anzahl der Mantissenstellen hinter dem Punkt
  1071.            (dmin (if (minusp k) (- 1 k) nil)) ; nachher: fordere, da▀
  1072.            ; nicht in die ersten (+ 1 (abs k)) Stellen hineingerundet wird.
  1073.            (mantwidth (if w (- w 2 expdigitsneed) nil))
  1074.            ; mantwidth = Anzahl der fⁿr die Mantisse (inkl. Vorzeichen, Punkt)
  1075.            ; zur Verfⁿgung stehenden Zeichen (oder nil)
  1076.           )
  1077.       (declare (simple-string expdigits) (fixnum exponent expdigitsneed))
  1078.       (if (and overflowchar w e (> expdigitsneed e))
  1079.         ; Falls Overflowchar und w und e angegeben, Exponent mehr braucht:
  1080.         (format-padding w overflowchar stream)
  1081.         (progn
  1082.           (if w
  1083.             (if (or plus-sign-flag (minusp arg)) (setq mantwidth (1- mantwidth)))
  1084.           )
  1085.           ; mantwidth = Anzahl der fⁿr die Mantisse (ohne Vorzeichen,
  1086.           ; inklusive Punkt) zur Verfⁿgung stehenden Zeichen (oder nil)
  1087.           (multiple-value-bind (mantdigits mantdigitslength
  1088.                                 leadingpoint trailingpoint)
  1089.               (format-float-to-string mantissa mantwidth mantd k dmin)
  1090.             (when w
  1091.               (setq mantwidth (- mantwidth mantdigitslength))
  1092.               (if trailingpoint
  1093.                 (if (or (null mantd) (> mantd 0))
  1094.                   (setq mantwidth (- mantwidth 1))
  1095.                   (setq trailingpoint nil)
  1096.               ) )
  1097.               (if leadingpoint
  1098.                 (if (> mantwidth 0)
  1099.                   (setq mantwidth (- mantwidth 1))
  1100.                   (setq leadingpoint nil)
  1101.               ) )
  1102.             )
  1103.             ; Es bleiben noch mantwidth Zeichen ⁿbrig.
  1104.             (if (and overflowchar w (minusp mantwidth))
  1105.               (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
  1106.               (progn
  1107.                 (when (and w (> mantwidth 0))
  1108.                   (format-padding mantwidth padchar stream)
  1109.                 )
  1110.                 (if (minusp arg)
  1111.                   (write-char #\- stream)
  1112.                   (if plus-sign-flag (write-char #\+ stream))
  1113.                 )
  1114.                 (if leadingpoint (write-char #\0 stream))
  1115.                 (write-string mantdigits stream)
  1116.                 (if trailingpoint (write-char #\0 stream))
  1117.                 (write-char
  1118.                   (cond (exponentchar)
  1119.                         ((and (not *PRINT-READABLY*)
  1120.                               (typep arg *READ-DEFAULT-FLOAT-FORMAT*)
  1121.                          )
  1122.                          #\E
  1123.                         )
  1124.                         ((short-float-p arg) #\s)
  1125.                         ((single-float-p arg) #\f)
  1126.                         ((double-float-p arg) #\d)
  1127.                         ((long-float-p arg) #\L)
  1128.                   )
  1129.                   stream
  1130.                 )
  1131.                 (write-char (if (minusp exponent) #\- #\+) stream)
  1132.                 (when (and e (> e (length expdigits)))
  1133.                   (format-padding (- e (length expdigits)) #\0 stream)
  1134.                 )
  1135.                 (write-string expdigits stream)
  1136.           ) ) )
  1137.     ) ) )
  1138. ) )
  1139.  
  1140. ; Rⁿckt *FORMAT-CSDL* vor bis zum Ende des momentanen ~[ bzw. ~{ bzw. ~< .
  1141. (defun format-skip-to-end ()
  1142.   (do ()
  1143.       ((null (csd-clause-chain (car *FORMAT-CSDL*))))
  1144.     (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
  1145. ) )
  1146.  
  1147. ; (format-justified-segments mincol colinc minpad justify-left justify-right
  1148. ;   piecelist) berechnet, an welchen Stellen zwischen den einzelnen Strings in
  1149. ; piecelist wieviele Leerstellen zu setzen sind.
  1150. ; Zwischen die einzelnen Strings aus piecelist (auch vorher, falls justify-left;
  1151. ; auch nachher, falls justify-right) werden mindestens minpad padding-characters
  1152. ; eingefⁿgt. Dann werden nochmals weitere padding-characters dazugenommen,
  1153. ; damit die Gesamtbreite >= mincol wird. Ist die Breite > mincol, werden weitere
  1154. ; padding-characters dazugenommen, so da▀ die Breite von der Form
  1155. ; mincol + k * colinc wird. Diese padding-characters werden auf die einzelnen
  1156. ; Stellen gleichmΣ▀ig verteilt.
  1157. ; 1. Wert: Ein Vektor, der zu jeder Stelle angibt, wieviele padding-characters
  1158. ; einzufⁿgen sind (NIL = keine).
  1159. ; Erstes Element: ganz links, zweites: nach 1. String, ..., letztes: rechts.
  1160. ; 2. Wert: Die sich ergebende Gesamtbreite.
  1161. (defun format-justified-segments
  1162.        (mincol colinc minpad justify-left justify-right piecelist)
  1163.   (declare (fixnum mincol colinc minpad))
  1164.   (let ((piecesnumber 0)
  1165.         (pieceswidth 0))
  1166.     (dolist (piece piecelist)
  1167.       (declare (simple-string piece))
  1168.       (incf piecesnumber)
  1169.       (incf pieceswidth (length piece))
  1170.     )
  1171.     (let* ((new-justify-left
  1172.              (or justify-left (and (= piecesnumber 1) (not justify-right))))
  1173.            (padblocks (+ piecesnumber -1       ; Anzahl der Einfⁿge-Stellen
  1174.                          (if new-justify-left 1 0) (if justify-right 1 0)
  1175.            )          )
  1176.            (width-need (+ pieceswidth (* padblocks minpad)))
  1177.            (width (+ mincol
  1178.                      (if (<= width-need mincol)
  1179.                          0
  1180.                          (* (ceiling (- width-need mincol) colinc) colinc)
  1181.           ))      )  )
  1182.       (declare (fixnum piecesnumber pieceswidth padblocks width-need width))
  1183.       (multiple-value-bind (padwidth rest) (floor (- width pieceswidth) padblocks)
  1184.         (let ((padblock-lengths
  1185.                 (make-array (1+ piecesnumber) :initial-element padwidth)
  1186.              ))
  1187.           (unless new-justify-left (setf (svref padblock-lengths 0) nil))
  1188.           (unless justify-right (setf (svref padblock-lengths piecesnumber) nil))
  1189.           (do ((i 0 (1+ i)))
  1190.               ((zerop rest))
  1191.             (when (svref padblock-lengths i)
  1192.               (incf (svref padblock-lengths i))
  1193.               (decf rest)
  1194.           ) )
  1195.           (values padblock-lengths width)
  1196. ) ) ) ) )
  1197.  
  1198. ;-------------------------------------------------------------------------------
  1199.  
  1200. ; ~A CLTL S.387-388
  1201. (defun format-ascii (stream colon-modifier atsign-modifier
  1202.              &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1203.   (if (null mincol) (setq mincol 0))
  1204.   (if (null colinc) (setq colinc 1))
  1205.   (if (null minpad) (setq minpad 0))
  1206.   (if (null padchar) (setq padchar #\Space))
  1207.   (let ((arg (next-arg)))
  1208.     (when (and colon-modifier (null arg)) (setq arg "()"))
  1209.     (if (and (zerop mincol) (zerop minpad))
  1210.       (princ arg stream)
  1211.       (format-padded-string mincol colinc minpad padchar
  1212.         atsign-modifier ; =: padleftflag
  1213.         (princ-to-string arg)
  1214.         stream
  1215. ) ) ) )
  1216.  
  1217. ; ~S CLTL S.388
  1218. (defun format-s-expression (stream colon-modifier atsign-modifier
  1219.              &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1220.   (if (null mincol) (setq mincol 0))
  1221.   (if (null colinc) (setq colinc 1))
  1222.   (if (null minpad) (setq minpad 0))
  1223.   (if (null padchar) (setq padchar #\Space))
  1224.   (let ((arg (next-arg)))
  1225.     (if (and (zerop mincol) (zerop minpad))
  1226.       (if (and colon-modifier (null arg))
  1227.         (write-string "()" stream)
  1228.         (prin1 arg stream)
  1229.       )
  1230.       (format-padded-string mincol colinc minpad padchar
  1231.         atsign-modifier ; =: padleftflag
  1232.         (if (and colon-modifier (null arg)) "()" (prin1-to-string arg))
  1233.         stream
  1234. ) ) ) )
  1235.  
  1236. ; ~W
  1237. (defun format-write (stream colon-modifier atsign-modifier
  1238.              &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1239.   (declare (ignore colon-modifier))
  1240.   (if (null mincol) (setq mincol 0))
  1241.   (if (null colinc) (setq colinc 1))
  1242.   (if (null minpad) (setq minpad 0))
  1243.   (if (null padchar) (setq padchar #\Space))
  1244.   (let ((arg (next-arg)))
  1245.     (if (and (zerop mincol) (zerop minpad))
  1246.       (write arg :stream stream)
  1247.       (format-padded-string mincol colinc minpad padchar
  1248.         atsign-modifier ; =: padleftflag
  1249.         (write-to-string arg)
  1250.         stream
  1251. ) ) ) )
  1252.  
  1253. ; ~D, CLTL S.388
  1254. (defun format-decimal (stream colon-modifier atsign-modifier
  1255.                        &optional (mincol 0) (padchar #\Space) (commachar #\,))
  1256.   (format-base 10 stream colon-modifier atsign-modifier mincol padchar commachar)
  1257. )
  1258.  
  1259. ; ~B, CLTL S.388
  1260. (defun format-binary (stream colon-modifier atsign-modifier
  1261.                       &optional (mincol 0) (padchar #\Space) (commachar #\,))
  1262.   (format-base 2 stream colon-modifier atsign-modifier mincol padchar commachar)
  1263. )
  1264.  
  1265. ; ~O, CLTL S.388
  1266. (defun format-octal (stream colon-modifier atsign-modifier
  1267.                      &optional (mincol 0) (padchar #\Space) (commachar #\,))
  1268.   (format-base 8 stream colon-modifier atsign-modifier mincol padchar commachar)
  1269. )
  1270.  
  1271. ; ~X, CLTL S.388-389
  1272. (defun format-hexadecimal (stream colon-modifier atsign-modifier
  1273.                         &optional (mincol 0) (padchar #\Space) (commachar #\,))
  1274.   (format-base 16 stream colon-modifier atsign-modifier mincol padchar commachar)
  1275. )
  1276.  
  1277. ; ~R, CLTL S.389
  1278. (defun format-radix (stream colon-modifier atsign-modifier
  1279.             &optional (radix nil) (mincol 0) (padchar #\Space) (commachar #\,))
  1280.   (if (null mincol) (setq mincol 0))
  1281.   (if (null padchar) (setq padchar #\Space))
  1282.   (if (null commachar) (setq commachar #\,))
  1283.   (let ((arg (next-arg)))
  1284.     (if radix
  1285.       (format-integer radix mincol padchar commachar
  1286.                       colon-modifier atsign-modifier
  1287.                       arg stream
  1288.       )
  1289.       (if atsign-modifier
  1290.         (if (integerp arg)
  1291.           (if colon-modifier
  1292.             (format-old-roman arg stream)
  1293.             (format-new-roman arg stream)
  1294.           )
  1295.           (format-error *FORMAT-CS* nil
  1296.             (DEUTSCH "Die ~~R- und ~~:R-Direktiven erwarten ein Integer als Argument, nicht ~S"
  1297.              ENGLISH "The ~~R and ~~:R directives require an integer argument, not ~S"
  1298.              FRANCAIS "Les directives ~~R et ~~:R nΘcessitent un argument de type entier et non ~S")
  1299.             arg
  1300.         ) )
  1301.         (if colon-modifier
  1302.           (format-ordinal arg stream)
  1303.           (format-cardinal arg stream)
  1304. ) ) ) ) )
  1305.  
  1306. ; ~P, CLTL S. 389
  1307. (defun format-plural (stream colon-modifier atsign-modifier)
  1308.   (when colon-modifier (format-goto-new-arg t 1))
  1309.   (let ((singular (eql (next-arg) 1)))
  1310.     (if atsign-modifier
  1311.       (write-string (if singular "y" "ies") stream)
  1312.       (unless singular (write-char #\s stream))
  1313. ) ) )
  1314.  
  1315. ; ~C, CLTL S.389-390
  1316. (defun format-character (stream colon-modifier atsign-modifier)
  1317.   (let ((arg (next-arg)))
  1318.     (unless (characterp arg)
  1319.       (format-error *FORMAT-CS* nil
  1320.         (DEUTSCH "Die ~~C-Direktive erwartet ein Character, nicht ~S"
  1321.          ENGLISH "The ~~C directive requires a character argument, not ~S"
  1322.          FRANCAIS "La directive ~~C requiert un caractΦre et non ~S")
  1323.         arg
  1324.     ) )
  1325.     (flet ((write-charname (arg)
  1326.              (let ((name (char-name arg)))
  1327.                (if name
  1328.                  (write-string (string-capitalize name) stream)
  1329.                  (write-char arg stream)
  1330.           )) ) )
  1331.       (if (not atsign-modifier)
  1332.         ; ~C oder ~:C
  1333.         (progn
  1334.           (dolist (name '(:CONTROL :META :SUPER :HYPER))
  1335.             (when (char-bit arg name)
  1336.               (write-string (string-capitalize (symbol-name name)) stream
  1337.                             :end (if colon-modifier nil 1)
  1338.               )
  1339.               (write-char #\- stream)
  1340.           ) )
  1341.           (write-charname (make-char arg))
  1342.         )
  1343.         (if (not colon-modifier)
  1344.           ; ~@C
  1345.           (prin1 arg stream)
  1346.           ; ~:@C -- hier NUR die Anweisung, wie's zu tippen ist.
  1347.           (progn
  1348.             (let ((keynames '("Shift-" "Control-" "Alternate-")))
  1349.               (dolist (name '(:SUPER :CONTROL :META))
  1350.                 (when (char-bit arg name)
  1351.                   (write-string (car keynames) stream)
  1352.                   (setq arg (set-char-bit arg name nil))
  1353.                 )
  1354.                 (setq keynames (cdr keynames))
  1355.             ) )
  1356.             (let* ((hyperkey-alist
  1357.                      #+(or ATARI DOS OS/2 UNIX AMIGA)
  1358.                      '(
  1359.      #-(or UNIX AMIGA) (#\Enter  . "Enter" )
  1360.                #-AMIGA (#\Insert . "Insert")
  1361.                #-AMIGA (#\End    . "End"   )
  1362.                        (#\Down   . #-ATARI "Down"  #+ATARI "")
  1363.                #-AMIGA (#\PgDn   . "PgDn"  )
  1364.                        (#\Left   . #-ATARI "Left"  #+ATARI "")
  1365.                 #+UNIX (#\Center . "Center")
  1366.                        (#\Right  . #-ATARI "Right" #+ATARI "")
  1367.                #-AMIGA (#\Home   . #-ATARI "Home"  #+ATARI "Clr/Home")
  1368.                        (#\Up     . #-ATARI "Up"    #+ATARI "")
  1369.                #-AMIGA (#\PgUp   . "PgUp"  )
  1370.     #+(or ATARI AMIGA) (#\Help   . "Help"  )
  1371.                #+ATARI (#\Undo   . "Undo"  )
  1372.        #+(or DOS OS/2) (#\Prtscr . "PrtScr")
  1373.      #-(or UNIX AMIGA) (#\Delete . "Delete")
  1374.                        (#\F1     . "F1"    )
  1375.                        (#\F2     . "F2"    )
  1376.                        (#\F3     . "F3"    )
  1377.                        (#\F4     . "F4"    )
  1378.                        (#\F5     . "F5"    )
  1379.                        (#\F6     . "F6"    )
  1380.                        (#\F7     . "F7"    )
  1381.                        (#\F8     . "F8"    )
  1382.                        (#\F9     . "F9"    )
  1383.                        (#\F10    . "F10"   )
  1384.                #-AMIGA (#\F11    . "F11"   )
  1385.                #-AMIGA (#\F12    . "F12"   )
  1386.                       )
  1387.                      #-(or ATARI DOS OS/2 UNIX AMIGA)
  1388.                      '()
  1389.                    )
  1390.                    (acons (assoc arg hyperkey-alist)))
  1391.               (if acons
  1392.                 (write-string (cdr acons) stream)
  1393.                 (progn
  1394.                   (when (char-bit arg ':HYPER)
  1395.                     (write-string (DEUTSCH "Ziffernblock-"
  1396.                                    ENGLISH "Keypad-"
  1397.                                    FRANCAIS "bloc numΘrique ")
  1398.                                   stream
  1399.                     )
  1400.                     (setq arg (set-char-bit arg :HYPER nil))
  1401.                   )
  1402.                   (write-charname arg)
  1403.           ) ) ) )
  1404. ) ) ) ) )
  1405.  
  1406. ; ~F, CLTL S.390-392
  1407. (defun format-fixed-float (stream colon-modifier atsign-modifier
  1408.        &optional (w nil) (d nil) (k 0) (overflowchar nil) (padchar #\Space))
  1409.   (declare (ignore colon-modifier))
  1410.   (if (null k) (setq k 0))
  1411.   (if (null padchar) (setq padchar #\Space))
  1412.   (let ((arg (next-arg)))
  1413.     (when (rationalp arg) (setq arg (float arg)))
  1414.     (if (floatp arg)
  1415.       (format-float-for-f w d k overflowchar padchar atsign-modifier arg stream)
  1416.       (format-ascii-decimal arg stream)
  1417. ) ) )
  1418.  
  1419. ; ~E, CLTL S.392-395
  1420. (defun format-exponential-float (stream colon-modifier atsign-modifier
  1421.           &optional (w nil) (d nil) (e nil) (k 1)
  1422.                     (overflowchar nil) (padchar #\Space) (exponentchar nil))
  1423.   (declare (ignore colon-modifier))
  1424.   (if (null k) (setq k 1))
  1425.   (if (null padchar) (setq padchar #\Space))
  1426.   (let ((arg (next-arg)))
  1427.     (when (rationalp arg) (setq arg (float arg)))
  1428.     (if (floatp arg)
  1429.       (format-float-for-e w d e k overflowchar padchar exponentchar
  1430.                           atsign-modifier arg stream
  1431.       )
  1432.       (format-ascii-decimal arg stream)
  1433. ) ) )
  1434.  
  1435. ; ~G, CLTL S.395-396
  1436. (defun format-general-float (stream colon-modifier atsign-modifier
  1437.           &optional (w nil) (d nil) (e nil) (k 1)
  1438.                     (overflowchar nil) (padchar #\Space) (exponentchar nil))
  1439.   (declare (ignore colon-modifier))
  1440.   (if (null k) (setq k 1))
  1441.   (if (null padchar) (setq padchar #\Space))
  1442.   (let ((arg (next-arg)))
  1443.     (if (rationalp arg) (setq arg (float arg)))
  1444.     (if (floatp arg)
  1445.       (multiple-value-bind (mantissa n) (format-scale-exponent (abs arg))
  1446.         (declare (ignore mantissa))
  1447.         (if (null d)
  1448.           (setq d
  1449.             (multiple-value-bind (digits digitslength)
  1450.               (format-float-to-string (abs arg) nil nil nil nil)
  1451.               (declare (ignore digits))
  1452.               (max (max (1- digitslength) 1) (min n 7))
  1453.         ) ) )
  1454.         (let* ((ee (if e (+ 2 e) 4))
  1455.                (dd (- d n)))
  1456.           (if (<= 0 dd d)
  1457.             (progn
  1458.               (format-float-for-f
  1459.                 (if w (- w ee) nil)
  1460.                 dd 0
  1461.                 overflowchar padchar atsign-modifier arg stream
  1462.               )
  1463.               (format-padding ee #\Space stream)
  1464.             )
  1465.             (format-float-for-e w d e k overflowchar padchar exponentchar
  1466.                                 atsign-modifier arg stream
  1467.       ) ) ) )
  1468.       (format-ascii-decimal arg stream)
  1469. ) ) )
  1470.  
  1471. ; ~$, CLTL S.396-397
  1472. (defun format-dollars-float (stream colon-modifier atsign-modifier
  1473.           &optional (d 2) (n 1) (w 0) (padchar #\Space) )
  1474.   (if (null d) (setq d 2))
  1475.   (if (null n) (setq n 1))
  1476.   (if (null w) (setq w 0))
  1477.   (if (null padchar) (setq padchar #\Space))
  1478.   (let ((arg (next-arg)))
  1479.     (when (rationalp arg) (setq arg (float arg)))
  1480.     (if (floatp arg)
  1481.       (multiple-value-bind (digits digitslength
  1482.                             leadingpoint trailingpoint leadings)
  1483.         (format-float-to-string arg nil d 0 nil)
  1484.         (declare (ignore digitslength leadingpoint trailingpoint))
  1485.         (let* ((lefts (max leadings n))
  1486.                (totalwidth (+ (if (or atsign-modifier (minusp arg)) 1 0)
  1487.                               lefts 1 d
  1488.                )           )
  1489.                (padcount (max (- w totalwidth) 0)))
  1490.           (if (not colon-modifier) (format-padding padcount padchar stream))
  1491.           (if (minusp arg)
  1492.             (write-char #\- stream)
  1493.             (if atsign-modifier (write-char #\+ stream))
  1494.           )
  1495.           (if colon-modifier (format-padding padcount padchar stream))
  1496.           (format-padding (- lefts leadings) #\0 stream)
  1497.           (write-string digits stream)
  1498.       ) )
  1499.       (format-ascii-decimal arg stream)
  1500. ) ) )
  1501.  
  1502. ; ~%, CLTL S.397
  1503. (defun format-terpri (stream colon-modifier atsign-modifier &optional (count 1))
  1504.   (declare (ignore colon-modifier atsign-modifier))
  1505.   (if (null count) (setq count 1))
  1506.   (dotimes (i count) (terpri stream))
  1507. )
  1508.  
  1509. ; ~&, CLTL S.397
  1510. (defun format-fresh-line (stream colon-modifier atsign-modifier
  1511.                           &optional (count 1))
  1512.   (declare (ignore colon-modifier atsign-modifier))
  1513.   (if (null count) (setq count 1))
  1514.   (when (plusp count)
  1515.     (fresh-line stream)
  1516.     (dotimes (i (1- count)) (terpri stream))
  1517. ) )
  1518.  
  1519. ; ~|, CLTL S.397
  1520. (defun format-page (stream colon-modifier atsign-modifier &optional (count 1))
  1521.   (declare (ignore colon-modifier atsign-modifier))
  1522.   (if (null count) (setq count 1))
  1523.   (dotimes (i count) (write-char #\Page stream))
  1524. )
  1525.  
  1526. ; ~~, CLTL S.397
  1527. (defun format-tilde (stream colon-modifier atsign-modifier &optional (count 1))
  1528.   (declare (ignore colon-modifier atsign-modifier))
  1529.   (if (null count) (setq count 1))
  1530.   (dotimes (i count) (write-char #\~ stream))
  1531. )
  1532.  
  1533. ; ~T, CLTL S.398-399
  1534. (defun format-tabulate (stream colon-modifier atsign-modifier
  1535.                         &optional (colnum 1) (colinc 1))
  1536.   (declare (ignore colon-modifier))
  1537.   (if (null colnum) (setq colnum 1))
  1538.   (if (null colinc) (setq colinc 1))
  1539.   (let* ((new-colnum (max colnum 0))
  1540.          (new-colinc (max colinc 1)) ; >0
  1541.          (pos (sys::line-position stream))) ; aktuelle Position, Fixnum >=0
  1542.     (if atsign-modifier
  1543.       (format-padding
  1544.         (+ new-colnum (mod (- (+ pos new-colnum)) new-colinc))
  1545.         #\Space stream
  1546.       )
  1547.       (if (< pos new-colnum)
  1548.         (format-padding (- new-colnum pos) #\Space stream)
  1549.         (unless (zerop colinc)
  1550.           (format-padding (+ colinc (mod (- new-colnum pos) (- colinc)))
  1551.                           #\Space stream
  1552. ) ) ) ) ) )
  1553.  
  1554. ; ~*, CLTL S.399
  1555. (defun format-goto (stream colon-modifier atsign-modifier &optional (index nil))
  1556.   (declare (ignore stream))
  1557.   (if atsign-modifier
  1558.     (setq *FORMAT-NEXT-ARG* (nthcdr (or index 0) *FORMAT-ARG-LIST*))
  1559.     (format-goto-new-arg colon-modifier (or index 1))
  1560. ) )
  1561.  
  1562. ; ~?, CLTL S.399-401
  1563. (defun format-indirection (stream colon-modifier atsign-modifier)
  1564.   (declare (ignore colon-modifier))
  1565.   (let ((csarg (next-arg)))
  1566.     (unless (stringp csarg)
  1567.       (format-error *FORMAT-CS* nil
  1568.         (DEUTSCH "Als Kontrollstring fⁿr ~~? ist das untauglich: ~S"
  1569.          ENGLISH "The control string argument for the ~~? directive is invalid: ~S"
  1570.          FRANCAIS "~S ne convient pas comme chaεne de contr⌠le pour ~~?.")
  1571.         csarg
  1572.     ) )
  1573.     ; evtl. noch csarg zu einem Simple-String machen ??
  1574.     (let ((node (list csarg)))
  1575.       (format-parse-cs csarg 0 node nil)
  1576.       (if atsign-modifier
  1577.         (let ((*FORMAT-CS* (car node))
  1578.               (*FORMAT-CSDL* (cdr node))
  1579.               (*FORMAT-UP-AND-OUT* nil))
  1580.           (format-interpret stream)
  1581.         )
  1582.         (let ((arglistarg (next-arg)))
  1583.           (unless (listp arglistarg)
  1584.             (format-error *FORMAT-CS* nil
  1585.               (DEUTSCH "Das ist keine passende Argumentliste fⁿr die ~~?-Direktive: ~S"
  1586.                ENGLISH "The argument list argument for the ~~? directive is invalid: ~S"
  1587.                FRANCAIS "Ceci n'est pas une liste d'arguments convenable pour la directive ~~? : ~S")
  1588.               arglistarg
  1589.           ) )
  1590.           (let* ((*FORMAT-CS* (car node))
  1591.                  (*FORMAT-CSDL* (cdr node))
  1592.                  (*FORMAT-ARG-LIST* arglistarg)
  1593.                  (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*))
  1594.             (format-interpret stream)
  1595. ) ) ) ) ) )
  1596.  
  1597. ; ~(, CLTL S.401
  1598. (defun format-case-conversion (stream colon-modifier atsign-modifier)
  1599.   (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1600.   (let ((tempstr
  1601.           (let ((tempstream (make-string-output-stream (sys::line-position stream))))
  1602.             (format-interpret tempstream 'FORMAT-CASE-CONVERSION-END)
  1603.             (get-output-stream-string tempstream)
  1604.        )) )
  1605.     (if colon-modifier
  1606.       (if atsign-modifier
  1607.         (write-string (nstring-upcase tempstr) stream)
  1608.         (write-string (nstring-capitalize tempstr) stream)
  1609.       )
  1610.       (if atsign-modifier
  1611.         (progn
  1612.           (setq tempstr (nstring-downcase tempstr))
  1613.           (dotimes (i (length tempstr)) ; erstes Zeichen zum Upcase machen
  1614.             (when (both-case-p (schar tempstr i))
  1615.               (setf (schar tempstr i) (char-upcase (schar tempstr i)))
  1616.               (return)
  1617.           ) )
  1618.           (write-string tempstr stream)
  1619.         )
  1620.         (write-string (nstring-downcase tempstr) stream)
  1621. ) ) ) )
  1622.  
  1623. ; ~[, CLTL S.402-403
  1624. (defun format-conditional (stream colon-modifier atsign-modifier
  1625.                            &optional (prefix nil))
  1626.   (if colon-modifier
  1627.     (if atsign-modifier
  1628.       (format-error *FORMAT-CS* nil
  1629.         (DEUTSCH "~~[ geht nicht mit : und @ gleichzeitig."
  1630.          ENGLISH "The ~~[ directive cannot take both modifiers."
  1631.          FRANCAIS "La directive ~~[ ne peut pas accepter les deux qualificateurs : et @ en mΩme temps.")
  1632.       )
  1633.       (progn
  1634.         (when (next-arg)
  1635.           (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
  1636.         )
  1637.         (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1638.         (format-interpret stream 'FORMAT-CONDITIONAL-END)
  1639.       )
  1640.     )
  1641.     (if atsign-modifier
  1642.       (when (next-arg)
  1643.         (format-goto-new-arg t 1)
  1644.         (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1645.         (format-interpret stream 'FORMAT-CONDITIONAL-END)
  1646.       )
  1647.       (let ((index (or prefix (next-arg))))
  1648.         (unless (integerp index)
  1649.           (format-error *FORMAT-CS* nil
  1650.             (DEUTSCH "Argument fⁿr ~~[ mu▀ ein Integer sein, nicht ~S"
  1651.              ENGLISH "The ~~[ parameter must be an integer, not ~S"
  1652.              FRANCAIS "L'argument pour ~~[ doit Ωtre un entier et non ~S")
  1653.             index
  1654.         ) )
  1655.         (dotimes (i (if (minusp index) most-positive-fixnum index))
  1656.           (when (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
  1657.             (return)
  1658.           )
  1659.           (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
  1660.           (when (csd-colon-p (car *FORMAT-CSDL*)) (return))
  1661.         )
  1662.         (unless (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
  1663.           (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1664.         )
  1665.         (format-interpret stream 'FORMAT-CONDITIONAL-END)
  1666.   ) ) )
  1667.   (format-skip-to-end) ; Weiterrⁿcken bis ans Ende der ~[...~]-Direktive
  1668. )
  1669.  
  1670. ; ~{, CLTL S.403-404
  1671. (defun format-iteration (stream colon-modifier atsign-modifier
  1672.                          &optional (prefix nil))
  1673.   (let* ((total-csdl *FORMAT-CSDL*)
  1674.          (max-iteration-count prefix))
  1675.     (format-skip-to-end) ; Weiterrⁿcken bis ans Ende der ~{...~}-Direktive
  1676.     (let* ((min-1-iteration (csd-colon-p (car *FORMAT-CSDL*)))
  1677.            (inner-cs (if (eq (cdr total-csdl) *FORMAT-CSDL*)
  1678.                        (next-arg)
  1679.                        *FORMAT-CS*
  1680.            )         )
  1681.            (inner-csdl (if (eq (cdr total-csdl) *FORMAT-CSDL*)
  1682.                          (let ((node (list inner-cs)))
  1683.                            (format-parse-cs inner-cs 0 node nil)
  1684.                            (cdr node)
  1685.                          )
  1686.                          (cdr total-csdl)
  1687.            )           )
  1688.            (arg-list-rest (if (not atsign-modifier)
  1689.                             (let ((arg (next-arg)))
  1690.                               (unless (listp arg)
  1691.                                 (format-error *FORMAT-CS* nil
  1692.                                   (DEUTSCH "Das Argument zu ~~{ mu▀ eine Liste sein, nicht ~S"
  1693.                                    ENGLISH "The ~~{ directive requires a list argument, not ~S"
  1694.                                    FRANCAIS "L'argument de ~~{ doit Ωtre une liste et non ~S")
  1695.                                   arg
  1696.                               ) )
  1697.                               arg
  1698.           ))              ) )
  1699.       (do* ((iteration-count 0 (1+ iteration-count)))
  1700.            ((or (and max-iteration-count
  1701.                      (>= iteration-count max-iteration-count)
  1702.                 )
  1703.                 (let ((remaining (if atsign-modifier
  1704.                                    *FORMAT-NEXT-ARG*
  1705.                                    arg-list-rest
  1706.                      ))          )
  1707.                   (if min-1-iteration
  1708.                     (and (plusp iteration-count) (null remaining))
  1709.                     (null remaining)
  1710.            ))   ) )
  1711.         (if colon-modifier
  1712.           (let* ((*FORMAT-ARG-LIST*
  1713.                    (if atsign-modifier (next-arg) (pop arg-list-rest))
  1714.                  )
  1715.                  (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
  1716.                  (*FORMAT-CS* inner-cs)
  1717.                  (*FORMAT-CSDL* inner-csdl)
  1718.                  (*FORMAT-UP-AND-OUT* nil))
  1719.             (format-interpret stream 'FORMAT-ITERATION-END)
  1720.             (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
  1721.           )
  1722.           (if atsign-modifier
  1723.             (let* ((*FORMAT-CS* inner-cs)
  1724.                    (*FORMAT-CSDL* inner-csdl)
  1725.                    (*FORMAT-UP-AND-OUT* nil))
  1726.               (format-interpret stream 'FORMAT-ITERATION-END)
  1727.               (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
  1728.             )
  1729.             (let* ((*FORMAT-ARG-LIST* arg-list-rest)
  1730.                    (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
  1731.                    (*FORMAT-CS* inner-cs)
  1732.                    (*FORMAT-CSDL* inner-csdl)
  1733.                    (*FORMAT-UP-AND-OUT* nil))
  1734.               (format-interpret stream 'FORMAT-ITERATION-END)
  1735.               (setq arg-list-rest *FORMAT-NEXT-ARG*)
  1736.               (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
  1737. ) ) ) ) ) ) )
  1738.  
  1739. ; ~<, CLTL S.404-406
  1740. (defun format-justification (stream colon-modifier atsign-modifier
  1741.        &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1742.   (if (null mincol) (setq mincol 0))
  1743.   (if (null colinc) (setq colinc 1))
  1744.   (if (null minpad) (setq minpad 0))
  1745.   (if (null padchar) (setq padchar #\Space))
  1746.   (let* ((saved-csdl *FORMAT-CSDL*)
  1747.          (pos (sys::line-position stream))
  1748.          (tempstream (make-string-output-stream pos))
  1749.          (check-on-line-overflow nil)
  1750.          supplementary-need
  1751.          line-length
  1752.          (old-piecelist
  1753.            (let ((pieces nil))
  1754.              (do ((first-piece-flag t nil))
  1755.                  ((eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-JUSTIFICATION-END))
  1756.                (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1757.                (let ((*FORMAT-UP-AND-OUT* nil))
  1758.                  (format-interpret tempstream 'FORMAT-JUSTIFICATION-END)
  1759.                  (when (and first-piece-flag (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-SEPARATOR))
  1760.                    (when (setq check-on-line-overflow (csd-colon-p (car *FORMAT-CSDL*)))
  1761.                      (multiple-value-setq (supplementary-need line-length)
  1762.                        (values-list (format-resolve-parms (car *FORMAT-CSDL*)))
  1763.                  ) ) )
  1764.                  (when *FORMAT-UP-AND-OUT*
  1765.                    (setq *FORMAT-CSDL* saved-csdl)
  1766.                    (format-skip-to-end)
  1767.                    (return)
  1768.                  )
  1769.                  (push (get-output-stream-string tempstream) pieces)
  1770.              ) )
  1771.              (nreverse pieces)
  1772.          ) )
  1773.          (piecelist
  1774.            (if check-on-line-overflow (cdr old-piecelist) old-piecelist)
  1775.         ))
  1776.     (if piecelist
  1777.       (multiple-value-bind (padblocklengths width)
  1778.         (format-justified-segments mincol colinc minpad
  1779.           colon-modifier atsign-modifier piecelist)
  1780.         (when (and check-on-line-overflow
  1781.                    (> (+ pos width (or supplementary-need 0))
  1782.                       (or line-length #|(sys::line-length stream)|# 72)
  1783.               )    )
  1784.           (write-string (first old-piecelist) stream)
  1785.         )
  1786.         (do ((i 0 (1+ i)))
  1787.             (nil)
  1788.           (when (svref padblocklengths i)
  1789.             (format-padding (svref padblocklengths i) padchar stream)
  1790.           )
  1791.           (when (null piecelist) (return))
  1792.           (write-string (pop piecelist) stream)
  1793.       ) )
  1794.       (format-padding mincol padchar stream)
  1795.     )
  1796. ) )
  1797.  
  1798. ; ~^, CLTL S.406-407
  1799. (defun format-up-and-out (stream colon-modifier atsign-modifier
  1800.                           &optional (a nil) (b nil) (c nil))
  1801.   (declare (ignore stream atsign-modifier))
  1802.   (if (cond ((and (null a) (null b) (null c)) ; keine Parameter
  1803.              (null *FORMAT-NEXT-ARG*)
  1804.             )
  1805.             ((and (null b) (null c)) (eql a 0)) ; ein Parameter
  1806.             ((null c) (eql a b)) ; zwei Parameter
  1807.             ((and (integerp a) (integerp b) (integerp c)) (<= a b c))
  1808.             ((and (characterp a) (characterp b) (characterp c)) (char<= a b c))
  1809.       )
  1810.     (setq *FORMAT-UP-AND-OUT* (if colon-modifier ':TERMINATE-ALL ':TERMINATE))
  1811. ) )
  1812.  
  1813. ;-------------------------------------------------------------------------------
  1814.  
  1815.