home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / format.lsp < prev    next >
Encoding:
Text File  |  1996-06-05  |  119.3 KB  |  2,799 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. ; Weiter umgearbeitet und FORMATTER geschrieben am 9.4.1995-11.4.1995
  6.  
  7. (in-package "SYSTEM")
  8.  
  9. ;-------------------------------------------------------------------------------
  10.  
  11. ; Datenstruktur der Kontrollstring-Direktive:
  12. (defstruct (control-string-directive
  13.              (:copier nil)
  14.              (:conc-name "CSD-")
  15.              (:predicate nil)
  16.              (:constructor make-csd ())
  17.            )
  18.   (type         0 :type fixnum)
  19.   (cs-index     0 :type fixnum)
  20.   (parm-list    nil :type list)
  21.   (v-or-#-p     nil :type symbol)
  22.   (colon-p      nil :type symbol)
  23.   (atsign-p     nil :type symbol)
  24.   (data         nil)
  25.   (clause-chain nil)
  26. )
  27. #+CLISP (remprop 'control-string-directive 'sys::defstruct-description)
  28. ; ErlΣuterung:
  29. ; type=0 : Direktive ~<Newline>, nichts auszugeben.
  30. ;          Weitere Komponenten bedeutungslos
  31. ; type=1 : String auszugeben,
  32. ;          von *FORMAT-CS* die Portion :START cs-index :END data.
  33. ;          Weitere Komponenten bedeutungslos
  34. ; type=2 : Formatier-Direktive auszufⁿhren.
  35. ;          data = Name der Direktive (Symbol),
  36. ;          colon-p gibt an, ob ein ':' da war,
  37. ;          atsign-p gibt an, ob ein '@' da war,
  38. ;          parm-list = Parameterliste an die Direktive,
  39. ;          v-or-#-p gibt an, ob parm-list vor dem Aufruf noch zu behandeln ist.
  40. ;          clause-chain ist eine Verzeigerung: z.B. bei ~[...~;...~;...~]
  41. ;          von der ~[-Direktive auf die Liste ab der ersten ~;-Direktive,
  42. ;          von da auf die Liste ab der nΣchsten ~;-Direktive usw.
  43. ;          bis schlie▀lich auf die Liste ab der ~]-Direktive.
  44.  
  45. ; Zeigt an, ob ein Character ein Whitespace-Character ist.
  46. (defun whitespacep (char)
  47.   (member char '(#\Space #\Newline #\Linefeed #\Tab #\Return #\Page))
  48. )
  49.  
  50. ; (FORMAT-PARSE-CS control-string startindex csdl stop-at)
  51. ; parst einen Kontrollstring (genauer: (subseq control-string startindex))
  52. ; und legt die sich ergebende Control-String-Directive-Liste in (cdr csdl) ab.
  53. ; Das Parsen mu▀ mit der Direktive stop-at enden (ein Character, oder NIL
  54. ; fⁿr Stringende).
  55. ; Falls stop-at /= NIL, ist in (csd-clause-chain (car csdl)) ein Pointer auf
  56. ; die Teilliste ab dem nΣchsten Separator einzutragen. Diese Pointer bilden
  57. ; eine einfach verkettete Liste innerhalb csdl: von einem Separator zum
  58. ; nΣchsten, zum Schlu▀ zum Ende der Clause.
  59. (defun format-parse-cs (control-string startindex csdl stop-at)
  60.   (declare (fixnum startindex))
  61.   (macrolet ((errorstring ()
  62.                (DEUTSCH "Kontrollstring endet mitten in einer Direktive."
  63.                 ENGLISH "The control string terminates within a directive."
  64.                 FRANCAIS "La chaεne de contr⌠le se termine en plein milieu d'une directive.")
  65.             ))
  66.     (prog* ((index startindex) ; cs-index des nΣchsten Zeichens
  67.             ch ; current character
  68.             intparam ; Integer-Parameter
  69.             newcsd ; aktuelle CSD
  70.             (last-separator-csd (car csdl))
  71.            )
  72.       (declare (type simple-string control-string) (type fixnum index))
  73.       (loop ; neue Direktive insgesamt
  74.         (tagbody
  75.           (when (>= index (length control-string))
  76.             (go string-ended)
  77.           )
  78.           (setq ch (schar control-string index))
  79.           (unless (eql ch #\~)
  80.             ; eventuell noch Stringstⁿck zu einer eingenen Direktive machen
  81.             (setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd)))))
  82.             (setf (csd-type     newcsd) 1)
  83.             (setf (csd-cs-index newcsd) index)
  84.             (setq index (position #\~ control-string :start index))
  85.             (unless index
  86.               (setf (csd-data newcsd) (setq index (length control-string)))
  87.               (go string-ended)
  88.             )
  89.             (setf (csd-data newcsd) index)
  90.           )
  91.           (setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd)))))
  92.           (setf (csd-type         newcsd) 2)
  93.           (setf (csd-cs-index     newcsd) index)
  94.           (setf (csd-parm-list    newcsd) nil)
  95.           (setf (csd-v-or-#-p     newcsd) nil)
  96.           (setf (csd-colon-p      newcsd) nil)
  97.           (setf (csd-atsign-p     newcsd) nil)
  98.           (setf (csd-data         newcsd) nil)
  99.           (setf (csd-clause-chain newcsd) nil)
  100.  
  101.           param ; Parameter einer Direktive kann beginnen
  102.           (incf index)
  103.           (when (>= index (length control-string))
  104.             (format-error control-string index (errorstring))
  105.             (go string-ended)
  106.           )
  107.           (setq ch (schar control-string index))
  108.           (when (digit-char-p ch) (go num-param))
  109.           (case ch
  110.             ((#\+ #\-) (go num-param))
  111.             (#\' (go quote-param))
  112.             ((#\V #\v #\#)
  113.              (push (if (eql ch #\#) ':ARG-COUNT ':NEXT-ARG)
  114.                    (csd-parm-list newcsd)
  115.              )
  116.              (setf (csd-v-or-#-p newcsd) T)
  117.              (go param-ok-1)
  118.             )
  119.             (#\, (push nil (csd-parm-list newcsd)) (go param))
  120.             (#\: (go colon-modifier))
  121.             (#\@ (go atsign-modifier))
  122.             (T (go directive))
  123.           )
  124.  
  125.           num-param ; numerischer Parameter
  126.           (multiple-value-setq (intparam index)
  127.             (parse-integer control-string :start index :junk-allowed t)
  128.           )
  129.           (unless intparam
  130.             (format-error control-string index
  131.                           (DEUTSCH "~A mu▀ eine Zahl einleiten."
  132.                            ENGLISH "~A must introduce a number."
  133.                            FRANCAIS "~A doit introduire un nombre.")
  134.                           ch
  135.           ) )
  136.           (push intparam (csd-parm-list newcsd))
  137.           (go param-ok-2)
  138.  
  139.           quote-param ; Quote-Parameter-Behandlung
  140.           (incf index)
  141.           (when (>= index (length control-string))
  142.             (format-error control-string index
  143.               (DEUTSCH "Kontrollstring endet mitten in einem '-Parameter."
  144.                ENGLISH "The control string terminates in the middle of a parameter."
  145.                FRANCAIS "La chaεne de contr⌠le se termine au milieu d'un paramΦtre.")
  146.             )
  147.             (go string-ended)
  148.           )
  149.           (setq ch (schar control-string index))
  150.           (push ch (csd-parm-list newcsd))
  151.  
  152.           param-ok-1 ; Parameter OK
  153.           (incf index)
  154.           param-ok-2 ; Parameter OK
  155.           (when (>= index (length control-string))
  156.             (format-error control-string index (errorstring))
  157.             (go string-ended)
  158.           )
  159.           (setq ch (schar control-string index))
  160.           (case ch
  161.             (#\, (go param))
  162.             (#\: (go colon-modifier))
  163.             (#\@ (go atsign-modifier))
  164.             (T (go directive))
  165.           )
  166.  
  167.           colon-modifier ; nach :
  168.           (setf (csd-colon-p newcsd) T)
  169.           (go passed-modifier)
  170.  
  171.           atsign-modifier ; nach @
  172.           (setf (csd-atsign-p newcsd) T)
  173.           (go passed-modifier)
  174.  
  175.           passed-modifier ; nach : oder @
  176.           (incf index)
  177.           (when (>= index (length control-string))
  178.             (format-error control-string index (errorstring))
  179.             (go string-ended)
  180.           )
  181.           (setq ch (schar control-string index))
  182.           (case ch
  183.             (#\: (go colon-modifier))
  184.             (#\@ (go atsign-modifier))
  185.             (T (go directive))
  186.           )
  187.  
  188.           directive ; Direktive (ihr Name) erreicht
  189.           (setf (csd-parm-list newcsd) (nreverse (csd-parm-list newcsd)))
  190.           (let ((directive-name
  191.                   (cdr (assoc (char-upcase ch)
  192.                          '((#\A . FORMAT-ASCII)
  193.                            (#\S . FORMAT-S-EXPRESSION)
  194.                            (#\W . FORMAT-WRITE)
  195.                            (#\D . FORMAT-DECIMAL)
  196.                            (#\B . FORMAT-BINARY)
  197.                            (#\O . FORMAT-OCTAL)
  198.                            (#\X . FORMAT-HEXADECIMAL)
  199.                            (#\R . FORMAT-RADIX)
  200.                            (#\P . FORMAT-PLURAL)
  201.                            (#\C . FORMAT-CHARACTER)
  202.                            (#\F . FORMAT-FIXED-FLOAT)
  203.                            (#\E . FORMAT-EXPONENTIAL-FLOAT)
  204.                            (#\G . FORMAT-GENERAL-FLOAT)
  205.                            (#\$ . FORMAT-DOLLARS-FLOAT)
  206.                            (#\% . FORMAT-TERPRI)
  207.                            (#\& . FORMAT-FRESH-LINE)      (#\Newline . #\Newline)
  208.                            (#\| . FORMAT-PAGE)
  209.                            (#\~ . FORMAT-TILDE)
  210.                            (#\T . FORMAT-TABULATE)
  211.                            (#\* . FORMAT-GOTO)
  212.                            (#\? . FORMAT-INDIRECTION)
  213.                            (#\( . FORMAT-CASE-CONVERSION) (#\) . FORMAT-CASE-CONVERSION-END)
  214.                            (#\[ . FORMAT-CONDITIONAL)     (#\] . FORMAT-CONDITIONAL-END)
  215.                            (#\{ . FORMAT-ITERATION)       (#\} . FORMAT-ITERATION-END)
  216.                            (#\< . FORMAT-JUSTIFICATION)   (#\> . FORMAT-JUSTIFICATION-END)
  217.                            (#\^ . FORMAT-UP-AND-OUT)      (#\; . FORMAT-SEPARATOR)
  218.                            ; mit Funktionsdefinition      ; ohne Funktionsdefinition
  219.                )) )    )  )
  220.             (if directive-name
  221.               (setf (csd-data newcsd) directive-name)
  222.               (format-error control-string index
  223.                 (DEUTSCH "Diese Direktive gibt es nicht."
  224.                  ENGLISH "Non-existent directive"
  225.                  FRANCAIS "Directive non reconnue.")
  226.           ) ) )
  227.           (incf index)
  228.           (case ch
  229.             (( #\( #\[ #\{ #\< )
  230.              (multiple-value-setq (index csdl)
  231.                (format-parse-cs control-string index csdl
  232.                  (case ch (#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) )
  233.              ) )
  234.             )
  235.             (( #\) #\] #\} #\> )
  236.              (unless stop-at
  237.                (format-error control-string index
  238.                  (DEUTSCH "Schlie▀ende Klammer '~A' ohne vorherige ÷ffnende Klammer"
  239.                   ENGLISH "The closing directive '~A' does not have a corresponding opening one."
  240.                   FRANCAIS "ParenthΦse fermante '~A' sans parenthΦse ouvrante correspondante.")
  241.                  ch
  242.              ) )
  243.              (unless (eql ch stop-at)
  244.                (format-error control-string index
  245.                  (DEUTSCH "Schlie▀ende Klammer '~A' pa▀t nicht; sollte '~A' lauten."
  246.                   ENGLISH "The closing directive '~A' does not match the corresponding opening one. It should read '~A'."
  247.                   FRANCAIS "La parenthΦse fermante '~A' ne correspond pas α celle ouvrante. Il devrait y avoir '~A'.")
  248.                  ch stop-at
  249.              ) )
  250.              (setf (csd-clause-chain last-separator-csd) csdl)
  251.              (go end)
  252.             )
  253.             (#\;
  254.              (unless (or (eql stop-at #\]) (eql stop-at #\>))
  255.                (format-error control-string index
  256.                  (DEUTSCH "Hier ist keine ~~;-Direktive m÷glich."
  257.                   ENGLISH "The ~~; directive is not allowed at this point."
  258.                   FRANCAIS "La directive ~~; n'est pas permise ici.")
  259.              ) )
  260.              (setf (csd-clause-chain last-separator-csd) csdl)
  261.              (setq last-separator-csd newcsd)
  262.             )
  263.             (#\Newline
  264.              (setf (csd-type newcsd) 0)
  265.              (if (csd-colon-p newcsd)
  266.                (if (csd-atsign-p newcsd)
  267.                  (format-error control-string index
  268.                    (DEUTSCH "Die ~~Newline-Direktive ist mit : und @ sinnlos."
  269.                     ENGLISH "The ~~newline directive cannot take both modifiers."
  270.                     FRANCAIS "La directive ~~Newline est insensΘe avec les deux qualificateurs : et @.")
  271.                  )
  272.                  nil ; ~:<newline> -> Newline ignorieren, Whitespace dalassen
  273.                )
  274.                (progn
  275.                  (when (csd-atsign-p newcsd)
  276.                    ; ~@<newline> -> Stringstⁿck mit Newline zum Ausgeben
  277.                    (setf (csd-type newcsd) 1)
  278.                    (setf (csd-cs-index newcsd) (1- index))
  279.                    (setf (csd-data newcsd) index)
  280.                  )
  281.                  (setq index
  282.                    (or (position-if-not #'whitespacep control-string :start index)
  283.                        (length control-string)
  284.           ) )) ) ) )
  285.         ) ; tagbody zu Ende
  286.       ) ; loop zu Ende
  287.  
  288.       string-ended
  289.       (when stop-at
  290.         (format-error control-string index
  291.           (DEUTSCH "Schlie▀ende Klammer '~A' fehlt."
  292.            ENGLISH "An opening directive is never closed; expecting '~A'."
  293.            FRANCAIS "Il manque la borne fermante '~A'.")
  294.           stop-at
  295.       ) )
  296.  
  297.       end
  298.       (return (values index csdl))
  299. ) ) )
  300.  
  301. ;-------------------------------------------------------------------------------
  302.  
  303. (defvar *FORMAT-CS*) ; control-string
  304. (defvar *FORMAT-CSDL*) ; control-string directive list
  305. (defvar *FORMAT-ARG-LIST*) ; argument-list
  306. (defvar *FORMAT-NEXT-ARG*) ; pointer to next argument in argument-list
  307. (defvar *FORMAT-NEXT-ARGLIST*) ; pointer to next sublist in ~:{ iteration
  308. (defvar *FORMAT-UP-AND-OUT* nil) ; reason for up-and-out
  309.  
  310. ; (format-error controlstring errorpos errorcode . arguments)
  311. ; signalisiert einen Error, der bei FORMAT aufgetreten ist. Die Stelle im
  312. ; Control-string wird mit einem Pfeil markiert.
  313. (defun format-error (controlstring errorpos errorstring &rest arguments)
  314.   (when controlstring
  315.     (unless errorpos (setq errorpos (csd-cs-index (car *FORMAT-CSDL*))))
  316.     (setq errorstring
  317.       (string-concat errorstring
  318.         (DEUTSCH "~%Stelle im Kontrollstring:"
  319.          ENGLISH "~%Current point in control string:"
  320.          FRANCAIS "~%Position dans la chaεne de contr⌠le :")
  321.     ) )
  322.     (let ((pos1 0) (pos2 0))
  323.       (declare (simple-string errorstring) (fixnum pos1 pos2))
  324.       (loop
  325.         (setq pos2 (or (position #\Newline controlstring :start pos1)
  326.                        (length controlstring)
  327.         )          )
  328.         (setq errorstring (string-concat errorstring "~%  ~A"))
  329.         (setq arguments
  330.           (nconc arguments (list (substring controlstring pos1 pos2)))
  331.         )
  332.         (when (<= pos1 errorpos pos2)
  333.           (setq errorstring
  334.             (string-concat errorstring "~%~VT"
  335.                            #+(or DOS OS/2) "" #-(or DOS OS/2) "|"
  336.           ) )
  337.           (setq arguments (nconc arguments (list (+ (- errorpos pos1) 2))))
  338.         )
  339.         (when (= pos2 (length controlstring)) (return))
  340.         (setq pos1 (+ pos2 1))
  341.   ) ) )
  342.   (apply #'error-of-type 'error errorstring arguments)
  343. )
  344.  
  345. ;-------------------------------------------------------------------------------
  346.  
  347. (defun format (destination control-string &rest arguments)
  348.   (unless (or (stringp control-string) (functionp control-string))
  349.     (format-cs-error control-string)
  350.   )
  351.   (cond ((null destination)
  352.          (let ((stream (make-string-output-stream)))
  353.            (format-apply stream control-string arguments)
  354.            (get-output-stream-string stream)
  355.         ))
  356.         ((eq destination 'T)
  357.          (format-apply *standard-output* control-string arguments)
  358.          nil
  359.         )
  360.         ((streamp destination)
  361.          (format-apply destination control-string arguments)
  362.          nil
  363.         )
  364.         ((stringp destination)
  365.          (if (array-has-fill-pointer-p destination)
  366.            (let ((stream (sys::make-string-push-stream destination)))
  367.              (format-apply stream control-string arguments)
  368.            )
  369.            (error-of-type 'error
  370.              (DEUTSCH "String zum Vollschreiben ~S hat keinen Fill-Pointer."
  371.               ENGLISH "The destination string ~S should have a fill pointer."
  372.               FRANCAIS "La chaεne destination n'a pas de pointeur de remplissage.")
  373.              destination
  374.          ) )
  375.          nil
  376.         )
  377.         (t (error-of-type 'type-error
  378.              :datum destination :expected-type '(or (member nil t) stream string)
  379.              (DEUTSCH "Das ist weder NIL noch T noch ein Stream noch ein String: ~S"
  380.               ENGLISH "The destination argument ~S is invalid (not NIL or T or a stream or a string)."
  381.               FRANCAIS "L'argument de destination n'est ni NIL, ni T, ni un ½stream╗ ni une chaεne : ~S")
  382.              destination
  383.         )  )
  384. ) )
  385.  
  386. (defun format-apply (stream control-string arguments &optional (whole-arguments arguments))
  387.   (cond ((stringp control-string)
  388.          ; evtl. noch control-string zu einem Simple-String machen ??
  389.          (let ((node (list control-string)))
  390.            (format-parse-cs control-string 0 node nil)
  391.            (let* ((*FORMAT-CS*         (car node))
  392.                   (*FORMAT-CSDL*       (cdr node))
  393.                   (*FORMAT-ARG-LIST*   whole-arguments)
  394.                   (*FORMAT-NEXT-ARG*   arguments)
  395.                   (*FORMAT-NEXT-ARGLIST* nil)
  396.                   (*FORMAT-UP-AND-OUT* nil))
  397.              (format-interpret stream)
  398.              *FORMAT-NEXT-ARG*
  399.         )) )
  400.         ((functionp control-string)
  401.          (let ((*FORMAT-CS* nil)) ; format-error kann nicht mehr auf die Stelle zeigen
  402.            (apply control-string stream arguments)
  403.         ))
  404.         (t (format-cs-error control-string))
  405. ) )
  406.  
  407. (defun format-cs-error (control-string)
  408.   (error-of-type 'type-error
  409.     :datum control-string :expected-type '(or string function)
  410.     (DEUTSCH "~S: Kontrollstring mu▀ ein String sein, nicht ~S"
  411.      ENGLISH "~S: The control-string must be a string, not ~S"
  412.      FRANCAIS "~S : La chaεne de contr⌠le doit Ωtre une chaεne et non ~S")
  413.     'format control-string
  414. ) )
  415.  
  416. ;-------------------------------------------------------------------------------
  417.  
  418. ; (next-arg) liefert (und verbraucht) das nΣchste Argument aus der Argument-
  419. ; liste *FORMAT-NEXT-ARG*.
  420. (defun next-arg ()
  421.   (if (atom *FORMAT-NEXT-ARG*)
  422.     (format-error *FORMAT-CS* nil
  423.       (DEUTSCH "Nicht genⁿgend Argumente fⁿr diese Direktive ⁿbrig."
  424.        ENGLISH "There are not enough arguments left for this directive."
  425.        FRANCAIS "Il ne reste pas assez d'arguments pour cette directive.")
  426.     )
  427.     (pop *FORMAT-NEXT-ARG*)
  428. ) )
  429.  
  430. ; (format-interpret stream [endmarker]) interpretiert *FORMAT-CSDL* ab.
  431. ; Fluid vars:
  432. ;   *FORMAT-ARG-LIST*
  433. ;   *FORMAT-NEXT-ARG*
  434. ;   *FORMAT-NEXT-ARGLIST*
  435. ;   *FORMAT-CS*
  436. ;   *FORMAT-CSDL*
  437. ;   *FORMAT-UP-AND-OUT*
  438. ; Abbruch des Interpretierens bei Antreffen der Direktive endmarker
  439. ; oder der Direktive ~; .
  440. (defun format-interpret (stream &optional (endmarker nil))
  441.   (loop
  442.     (when *FORMAT-UP-AND-OUT* (return))
  443.     (when (endp *FORMAT-CSDL*) (return))
  444.     (let ((csd (car *FORMAT-CSDL*)))
  445.       (case (csd-type csd)
  446.         (0 )
  447.         (1 (write-string *FORMAT-CS* stream
  448.              :start (csd-cs-index csd) :end (csd-data csd)
  449.         )  )
  450.         (2 (let ((directive-name (csd-data csd)))
  451.              (if (eq directive-name endmarker) (return))
  452.              (if (eq directive-name 'FORMAT-SEPARATOR) (return))
  453.              (apply directive-name
  454.                stream
  455.                (csd-colon-p csd)
  456.                (csd-atsign-p csd)
  457.                (format-resolve-parms csd)
  458.         )  ) )
  459.     ) )
  460.     (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  461. ) )
  462.  
  463. ; liefert die korrekte Argumentliste einer CSD, evtl. mit eingesetzten
  464. ; Parametern: V (als :NEXT-ARG) und # (als :ARG-COUNT) werden aufgel÷st.
  465. (defun format-resolve-parms (csd)
  466.   (let ((arglist (csd-parm-list csd)))
  467.     (if (csd-v-or-#-p csd)
  468.       (mapcar #'(lambda (arg)
  469.                   (case arg
  470.                     (:NEXT-ARG (next-arg))
  471.                     (:ARG-COUNT (list-length *FORMAT-NEXT-ARG*))
  472.                     (T arg)
  473.                 ) )
  474.               arglist
  475.       )
  476.       arglist
  477. ) ) )
  478.  
  479. ; Definiert eine einfache FORMAT-Unterfunktion, d.i. eine, die genau ein
  480. ; Argument verbraucht.
  481. (defmacro defformat-simple (name (stream colon atsign . optionals-with-defaults)
  482.                                  (arg) &body body
  483.                             &environment env)
  484.   (multiple-value-bind (body-rest declarations) (sys::parse-body body nil env)
  485.     (let ((name2 (concat-pnames "DO-" name)) ; in #<PACKAGE SYSTEM>
  486.           (optionals (mapcar #'(lambda (opt) (if (consp opt) (first opt) opt))
  487.                              optionals-with-defaults
  488.          ))          )
  489.       `(PROGN
  490.          (DEFUN ,name (,stream ,colon ,atsign &OPTIONAL ,@optionals)
  491.            (,name2 ,stream ,colon ,atsign ,@optionals (next-arg))
  492.          )
  493.          (DEFUN ,name2 (,stream ,colon ,atsign ,@optionals ,arg)
  494.            ,@(if declarations `((DECLARE ,@declarations)))
  495.            ,@(mapcap #'(lambda (opt)
  496.                          (if (and (consp opt) (not (null (second opt))))
  497.                            `((IF (NULL ,(first opt)) (SETQ ,(first opt) ,(second opt))))
  498.                            '()
  499.                        ) )
  500.                      optionals-with-defaults
  501.              )
  502.            ,@body-rest
  503.        ) )
  504. ) ) )
  505.  
  506. ; Bewegt den Stand des "Pointers in die Argumentliste" in eine Richtung.
  507. (defun format-goto-new-arg (backwardp index)
  508.   (if backwardp
  509.     ; rⁿckwΣrts
  510.     (setq *FORMAT-NEXT-ARG*
  511.       (nthcdr
  512.         (max (- (list-length *FORMAT-ARG-LIST*) (list-length *FORMAT-NEXT-ARG*) index) 0)
  513.         *FORMAT-ARG-LIST*
  514.     ) )
  515.     ; vorwΣrts ist einfacher:
  516.     (setq *FORMAT-NEXT-ARG* (nthcdr index *FORMAT-NEXT-ARG*))
  517. ) )
  518.  
  519. ; gibt arg als r÷mische Zahl auf stream aus, z.B. 4 als IIII.
  520. (defun format-old-roman (arg stream)
  521.   (unless (and (integerp arg) (<= 1 arg 4999))
  522.     (format-error *FORMAT-CS* nil
  523.       (DEUTSCH "Die ~~:@R-Direktive erwartet ein Integer zwischen 1 und 4999, nicht ~S"
  524.        ENGLISH "The ~~:@R directive requires an integer in the range 1 - 4999, not ~S"
  525.        FRANCAIS "La directive ~~:@R requiert un entier compris entre 1 et 4999 et non ~S")
  526.       arg
  527.   ) )
  528.   (do ((charlistr  '(#\M  #\D #\C #\L #\X #\V #\I) (cdr charlistr))
  529.        (valuelistr '(1000 500 100 50  10   5   1) (cdr valuelistr))
  530.        (value arg (multiple-value-bind (multiplicity restvalue)
  531.                       (floor value (first valuelistr))
  532.                     (dotimes (i multiplicity)
  533.                       (write-char (first charlistr) stream)
  534.                     )
  535.                     restvalue
  536.       ))          )
  537.       ((zerop value))
  538. ) )
  539.  
  540. ; gibt arg als r÷mische Zahl auf stream aus, z.B. 4 als IV.
  541. (defun format-new-roman (arg stream)
  542.   (unless (and (integerp arg) (<= 1 arg 3999))
  543.     (format-error *FORMAT-CS* nil
  544.       (DEUTSCH "Die ~~@R-Direktive erwartet ein Integer zwischen 1 und 3999, nicht ~S"
  545.        ENGLISH "The ~~@R directive requires an integer in the range 1 - 3999, not ~S"
  546.        FRANCAIS "La directive ~~@R requiert un entier compris entre 1 et 3999 et non ~S")
  547.       arg
  548.   ) )
  549.   (do ((charlistr       '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr))
  550.        (valuelistr     '(1000 500 100 50  10   5   1 ) (cdr valuelistr))
  551.        (lowercharlistr  '(#\C #\C #\X #\X #\I #\I    ) (cdr lowercharlistr))
  552.        (lowervaluelistr '(100 100 10  10   1   1   0 ) (cdr lowervaluelistr))
  553.        (value arg
  554.          (multiple-value-bind (multiplicity restvalue)
  555.              (floor value (first valuelistr))
  556.            (dotimes (i multiplicity) (write-char (first charlistr) stream))
  557.            (let ((loweredvalue (- (first valuelistr) (first lowervaluelistr))))
  558.              (if (>= restvalue loweredvalue)
  559.                (progn
  560.                  (write-char (first lowercharlistr) stream)
  561.                  (write-char (first charlistr) stream)
  562.                  (- restvalue loweredvalue)
  563.                )
  564.                restvalue
  565.       )) ) ) )
  566.       ((zerop value))
  567. ) )
  568.  
  569. (defconstant FORMAT-CARDINAL-ONES
  570.   '#(NIL "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
  571.      "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen"
  572.      "seventeen" "eighteen" "nineteen"
  573. )   )
  574.  
  575. (defconstant FORMAT-CARDINAL-TENS
  576.   '#(NIL NIL "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")
  577. )
  578.  
  579. ; (format-small-cardinal arg stream) gibt eine ganze Zahl >0, <1000 im
  580. ; Klartext auf englisch auf den stream aus. (arg=0 -> gibt nichts aus.)
  581. (defun format-small-cardinal (arg stream)
  582.   (multiple-value-bind (hundreds tens-and-ones) (truncate arg 100)
  583.     (when (> hundreds 0)
  584.       (write-string (svref FORMAT-CARDINAL-ONES hundreds) stream)
  585.       (write-string " hundred" stream)
  586.     )
  587.     (when (> tens-and-ones 0)
  588.       (when (> hundreds 0) (write-string " and " stream))
  589.       (multiple-value-bind (tens ones) (truncate tens-and-ones 10)
  590.         (if (< tens 2)
  591.           (write-string (svref FORMAT-CARDINAL-ONES tens-and-ones) stream)
  592.           (progn
  593.             (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
  594.             (when (> ones 0)
  595.               (write-char #\- stream)
  596.               (write-string (svref FORMAT-CARDINAL-ONES ones) stream)
  597. ) ) ) ) ) ) )
  598.  
  599. ; (format-cardinal arg stream) gibt die ganze Zahl arg im Klartext auf englisch
  600. ; auf den Stream aus.
  601. (defun format-cardinal (arg stream) ; arg Integer
  602.   (if (zerop arg)
  603.     (write-string "zero" stream)
  604.     (progn
  605.       (when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
  606.       (labels
  607.         ((blocks1000 (illions-list arg) ; Zerlegung in 1000er-Bl÷cke
  608.            (when (null illions-list)
  609.              (format-error *FORMAT-CS* nil
  610.                (DEUTSCH "Zu gro▀es Argument fⁿr ~~R-Direktive."
  611.                 ENGLISH "The argument for the ~~R directive is too large."
  612.                 FRANCAIS "L'argument pour la directive ~~R est trop grand.")
  613.            ) )
  614.            (multiple-value-bind (thousands small) (truncate arg 1000)
  615.              (when (> thousands 0) (blocks1000 (cdr illions-list) thousands))
  616.              (when (> small 0)
  617.                (when (> thousands 0) (write-string ", " stream))
  618.                (format-small-cardinal small stream)
  619.                (write-string (car illions-list) stream)
  620.         )) ) )
  621.         (blocks1000
  622.           ; amerikanisch (billion=10^9)
  623.           '("" " thousand" " million" " billion" " trillion" " quadrillion"
  624.             " quintillion" " sextillion" " septillion" " octillion" " nonillion"
  625.             " decillion" " undecillion" " duodecillion" " tredecillion"
  626.             " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
  627.             " octodecillion" " novemdecillion" " vigintillion")
  628.           arg
  629. ) ) ) ) )
  630.  
  631. (defconstant FORMAT-ORDINAL-ONES
  632.   '#(NIL "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth"
  633.      "ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
  634.      "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"
  635. )   )
  636.  
  637. ; (format-ordinal arg stream) gibt eine ganze Zahl arg als AbzΣhlnummer im
  638. ; Klartext auf englisch auf den stream aus.
  639. (defun format-ordinal (arg stream) ; arg Integer
  640.   (if (zerop arg)
  641.     (write-string "zeroth" stream)
  642.     (progn
  643.       (when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
  644.       (multiple-value-bind (hundreds tens-and-ones) (floor arg 100)
  645.         (when (> hundreds 0) (format-cardinal (* hundreds 100) stream))
  646.         (if (zerop tens-and-ones)
  647.           (write-string "th" stream)
  648.           (multiple-value-bind (tens ones) (floor tens-and-ones 10)
  649.             (when (> hundreds 0) (write-char #\Space stream))
  650.             (cond ((< tens 2)
  651.                    (write-string (svref FORMAT-ORDINAL-ONES tens-and-ones) stream)
  652.                   )
  653.                   ((zerop ones)
  654.                    (write-string
  655.                      (svref '#(NIL "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth"
  656.                                "sixtieth" "seventieth" "eightieth" "ninetieth")
  657.                             tens
  658.                      )
  659.                      stream
  660.                   ))
  661.                   (t (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
  662.                      (write-char #\- stream)
  663.                      (write-string (svref FORMAT-ORDINAL-ONES ones) stream)
  664. ) ) ) ) ) ) )     )
  665.  
  666. ; (format-padding count char stream) gibt count (ein Fixnum >=0) Zeichen char
  667. ; auf stream aus.
  668. (defun format-padding (count char stream)
  669.   (dotimes (i count) (write-char char stream))
  670. )
  671.  
  672. ; gibt auf den Stream stream aus:
  673. ; den String str, eventuell aufgefⁿllt mit Padding characters padchar.
  674. ; Und zwar so, da▀ die Breite mindestens mincol ist. Um das zu erreichen,
  675. ; werden mindestens minpad Zeichen eingefⁿgt, eventuelle weitere dann in
  676. ; Bl÷cken α colinc Zeichen. Falls padleftflag, werden sie links eingefⁿgt,
  677. ; sonst rechts vom String.
  678. (defun format-padded-string
  679.        (mincol colinc minpad padchar padleftflag str stream)
  680.   (let* ((need (+ (length str) minpad)) ; so viele Zeichen mindestens
  681.          (auxpad (if (< need mincol)
  682.                    (* (ceiling (- mincol need) colinc) colinc)
  683.                    0
  684.         ))       ) ; so viele Zeichen zusΣtzlich
  685.     (unless padleftflag (write-string str stream))
  686.     (format-padding (+ minpad auxpad) padchar stream)
  687.     (when padleftflag (write-string str stream))
  688. ) )
  689.  
  690. ; gibt den Integer arg auf den Stream aus:
  691. ; in Zahlenbasis base, mit Vorzeichen (+ nur falls >0 und positive-sign-flag),
  692. ; bei commaflag alle drei Stellen unterbrochen durch ein Zeichen commachar.
  693. ; Das Ganze links aufgefⁿllt mit padchar's, so da▀ die Gesamtbreite mindestens
  694. ; mincol ist.
  695. (defun format-integer (base
  696.                        mincol
  697.                        padchar
  698.                        commachar
  699.                        commainterval
  700.                        commaflag
  701.                        positive-sign-flag
  702.                        arg
  703.                        stream
  704.                       )
  705.   (let* ((*print-base* base)
  706.          (*print-radix* nil)
  707.          (*print-readably* nil))
  708.     (if (and (zerop mincol) (not commaflag) (not positive-sign-flag))
  709.       (princ arg stream) ; normale Ausgabe tut's
  710.       (let* ((oldstring (princ-to-string arg))
  711.              (oldstring-length (length oldstring))
  712.              (number-of-digits
  713.                (if (minusp arg) (1- oldstring-length) oldstring-length) )
  714.              (number-of-commas
  715.                (if commaflag (floor (1- number-of-digits) commainterval) 0) )
  716.              (positive-sign (and positive-sign-flag (> arg 0)))
  717.              (newstring-length
  718.                (+ (if positive-sign 1 0) ; Vorzeichen
  719.                   oldstring-length number-of-commas ; Ziffern, Kommas
  720.              ) )
  721.              (newstring (make-string newstring-length)) )
  722.         ; Erst Vorzeichen +:
  723.         (when positive-sign (setf (schar newstring 0) #\+))
  724.         ; Dann oldstring in newstring ⁿbertragen, dabei Kommata ⁿberspringen:
  725.         (let ((oldpos oldstring-length) (newpos newstring-length))
  726.           (loop
  727.             (decf oldpos)
  728.             (when (minusp oldpos) (return))
  729.             (decf newpos)
  730.             (setf (schar newstring newpos) (schar oldstring oldpos))
  731.             (when (and (plusp number-of-commas)
  732.                        (zerop (mod (- oldstring-length oldpos) commainterval))
  733.                   ) ; noch ein Komma einzufⁿgen?
  734.               (decf newpos)
  735.               (setf (schar newstring newpos) commachar)
  736.               (decf number-of-commas)
  737.         ) ) )
  738.         (if (zerop mincol)
  739.           (write-string newstring stream) ; schneller
  740.           (format-padded-string mincol 1 0 padchar t newstring stream)
  741. ) ) ) ) )
  742.  
  743. ; was ~D bei non-Integer-Argument tut: Argument mit ~A, aber dezimal ausgeben
  744. (defun format-ascii-decimal (arg stream)
  745.   (let ((*print-base* 10.)
  746.         (*print-radix* nil)
  747.         (*print-readably* nil))
  748.     (princ arg stream)
  749. ) )
  750.  
  751. ; Unterprogramm fⁿr ~D, ~B, ~O, ~X:
  752. (defun format-base (base stream colon-modifier atsign-modifier
  753.                     mincol padchar commachar commainterval
  754.                     arg)
  755.   (if (or (and (zerop mincol) (not colon-modifier) (not atsign-modifier))
  756.           (not (integerp arg))
  757.       )
  758.     (let ((*print-base* base)
  759.           (*print-radix* nil)
  760.           (*print-readably* nil))
  761.       (princ arg stream)
  762.     )
  763.     (format-integer base mincol padchar commachar commainterval
  764.                     colon-modifier atsign-modifier arg stream
  765. ) ) )
  766.  
  767. ; (format-scale-exponent-aux arg null eins zehn zehntel lg2)
  768. ; liefert zur Floating-Point-Zahl arg >= 0 und
  769. ; null = 0.0, eins = 1.0, zehn = 10.0, zehntel = 0.1, lg2 = log(2)/log(10)
  770. ; (erste vier in derselben Floating-Point-Precision wie arg)
  771. ; zwei Werte: mantissa und n, mit
  772. ; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
  773. ; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
  774. ; (Bei arg=null: null und n=0.)
  775. (defun format-scale-exponent-aux (arg null eins zehn zehntel lg2)
  776.   (multiple-value-bind (significand expon) (decode-float arg)
  777.     (declare (ignore significand))
  778.     (if (zerop arg)
  779.       (values null 0)
  780.       (let* ((expon10a (truncate (* expon lg2))) ; nicht round, um ▄berlauf zu vermeiden
  781.              (signif10a (/ arg (expt zehn expon10a))))
  782.         (do ((zehnpot zehn (* zehnpot zehn))
  783.              (signif10b signif10a (/ signif10a zehnpot))
  784.              (expon10b expon10a (1+ expon10b)))
  785.             ((< signif10b eins)
  786.              (do ((zehnpot zehn (* zehnpot zehn))
  787.                   (signif10c signif10b (* signif10b zehnpot))
  788.                   (expon10c expon10b (1- expon10c)))
  789.                  ((>= signif10c zehntel)
  790.                   (values signif10c expon10c)
  791.              )   )
  792.         )   )
  793. ) ) ) )
  794.  
  795. ; (format-scale-exponent arg) liefert zur Floating-Point-Zahl arg >= 0
  796. ; zwei Werte: mantissa und n, mit
  797. ; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
  798. ; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
  799. ; (Bei arg=null: 0.0 und n=0.)
  800. (defun format-scale-exponent (arg)
  801.   (cond ((short-float-p arg)
  802.          (format-scale-exponent-aux arg 0.0s0 1.0s0 10.0s0 0.1s0 0.30103s0)
  803.         )
  804.         ((single-float-p arg)
  805.          (format-scale-exponent-aux arg 0.0f0 1.0f0 10.0f0 0.1f0 0.30103s0)
  806.         )
  807.         ((double-float-p arg)
  808.          (format-scale-exponent-aux arg 0.0d0 1.0d0 10.0d0 0.1d0 0.30103s0)
  809.         )
  810.         ((long-float-p arg)
  811.          (format-scale-exponent-aux arg
  812.            (float 0 arg) (float 1 arg) (float 10 arg) (float 1/10 arg)
  813.            0.30102999566d0 ; lg2 wird mit 32 Bit Genauigkeit gebraucht
  814. ) )     ))
  815.  
  816. ; (format-float-to-string arg width d k dmin)
  817. ; ergibt einen String zum Floating-point arg:
  818. ; er hat den Wert von (* (abs arg) (expt 10 k)), dabei mind. d Nachkommastellen
  819. ; und h÷chstens die LΣnge width (width=nil -> keine EinschrΣnkung).
  820. ; Trotzdem wird nicht auf weniger als dmin Stellen gerundet.
  821. (let ((digit-string
  822.         (make-array 20 :element-type 'string-char :adjustable t :fill-pointer t)
  823.      ))
  824. (defun format-float-to-string (arg width d k dmin)
  825.   (if (zerop arg)
  826.     (let ((places (max (or d 0) (or dmin 0))))
  827.       (when width ; width angegeben -> places := (min places (1- width))
  828.         (when (>= places width) (setq places (1- width)))
  829.       )
  830.       (values
  831.         (let ((str (make-string (1+ places) :initial-element #\0)))
  832.           (setf (schar str 0) #\.)
  833.           str          ; ein Punkt und places Nullen
  834.         )
  835.         (1+ places)    ; Stellenzahl
  836.         t              ; Punkt ganz vorne
  837.         (zerop places) ; Punkt ganz hinten ?
  838.         0              ; Position des Punktes
  839.     ) )
  840.     (multiple-value-bind (significand expon) (integer-decode-float arg)
  841. ; significand : Integer >0
  842. ; expon : Integer
  843. ; mantprec : Anzahl der echten Mantissenbits von significand
  844. ; (also 2^mantprec <= significand < 2^(mantprec+1))
  845. ; width : Anzahl Stellen, die die Zahl (inklusive Punkt) nicht ⁿberschreiten
  846. ;         soll, oder NIL
  847. ; d : Mindestanzahl Nachkommastellen oder NIL
  848. ; k : Skalierungsfaktor (siehe CLTL S.394)
  849. ; dmin : Mindestanzahl von Dezimaltellen, die (trotz Angabe von width oder d)
  850. ;        nicht gerundet werden dⁿrfen.
  851. ;        (Nur interessant, falls d <= dmin <= (precision der Zahl).)
  852. ; wandelt die Zahl significand*2^expon um in einen Dezimalstring um.
  853. ; Es ist kein Exponent dabei.
  854.       (let* ((mantprec (1- (float-digits arg)))
  855.              (numerator significand)
  856.              (denominator 1)
  857.              (abrund-einh 1) ; Abrundungseinheit:
  858.                ; Abrunden um 1 in der letzten abrundbaren Stelle entspricht
  859.                ; einer Erniedrigung von numerator um abrund-einh.
  860.              (aufrund-einh 1) ; Aufrundungseinheit:
  861.                ; Aufrunden um 1 in der letzten aufrundbaren Stelle entspricht
  862.                ; einer Erh÷hung von numerator um aufrund-einh.
  863.              ; Stellen: 0 = 1. Stelle vor dem Punkt, -1 = 1. Stelle nach dem Punkt.
  864.              (stelle 0) ; Stelle der als nΣchstes auszugebenden Ziffer
  865.              (digit-count 0) ; Zahl der bisher in digit-string ausgegebenen
  866.                              ; Ziffern (exklusive den Punkt)
  867.              (point-pos 0) ; Punkt-Position = Zahl fⁿhrender Stellen
  868.                            ; = Zahl der Ziffern vor dem Punkt
  869.              (letzte-stelle nil) ; NIL oder (falls d oder width angegeben waren)
  870.                            ; Stelle der letzten signifikanten Ziffer
  871.              (halbzahlig nil) ; zeigt an, ob hinten genau ein 0.500000 wegfΣllt
  872.              digit ; die laufende Ziffer, >=0, <10
  873.              (abrunden nil) ; T falls letzte Ziffer abzurunden ist
  874.              (aufrunden nil) ; T falls letzte Ziffer aufzurunden ist
  875.             )
  876.         (setf (fill-pointer digit-string) 0) ; digit-string leeren
  877.         (cond
  878.           ((> expon 0)
  879.            (setq numerator (ash significand expon))
  880.            (setq aufrund-einh (setq abrund-einh (ash 1 expon)))
  881.           )
  882.           ((< expon 0)
  883.            (setq denominator (ash 1 (- expon))) ; aufrund-einh = abrund-einh = 1
  884.         ) )
  885.         ; Zahl = numerator/denominator
  886.         (when (= significand (ash 1 mantprec))
  887.           ; Ist der Significand=2^mantprec, so ist abrund-einh zu halbieren.
  888.           ; Man kann stattdessen auch alle 3 anderen Gr÷ssen verdoppeln:
  889.           (setq aufrund-einh (ash aufrund-einh 1))
  890.           (setq numerator (ash numerator 1))
  891.           (setq denominator (ash denominator 1))
  892.         )
  893.         ; DefaultmΣ▀ig: Auf-/Abrunde-Einheit = eine Einheit in der letzten
  894.         ; BIN─Rstelle.
  895.         ; Zahl = numerator/denominator
  896.         ; Skalierungsfaktor k in die Zahl mit einbeziehen (vgl. CLTL S.394)
  897.         ; k<0 -> Mantisse durch 10^(abs k) dividieren
  898.         ; k>0 -> Mantisse mit 10^k multiplizieren
  899.         ; Dabei aufrund-einh, abrund-einh im VerhΣltnis zu numerator beibehalten.
  900.         (when k
  901.           (if (< k 0)
  902.             (let ((skal-faktor (expt 10 (- k))))
  903.               (setq denominator (* denominator skal-faktor))
  904.             )
  905.             (let ((skal-faktor (expt 10 k)))
  906.               (setq numerator (* numerator skal-faktor))
  907.               (setq aufrund-einh (* aufrund-einh skal-faktor))
  908.               (setq abrund-einh (* abrund-einh skal-faktor))
  909.             )
  910.         ) )
  911.         ; auf >= 1/10 adjustieren:
  912.         ; (jeweils numerator mit 10 multiplizieren, eine fⁿhrende 0 mehr vorsehen)
  913.         (do ()
  914.             ((>= (* numerator 10) denominator))
  915.           (setq stelle (1- stelle))
  916.           (setq numerator (* numerator 10))
  917.           (setq abrund-einh (* abrund-einh 10))
  918.           (setq aufrund-einh (* aufrund-einh 10))
  919.         )
  920.         ; stelle = Stelle der letzten fⁿhrenden 0
  921.         ;        = 1 + Stelle der 1. signifikanten Ziffer
  922.         ;        oder =0, falls k>=0
  923.         ; Ausfⁿhrung der Rundung:
  924.         (loop
  925.           ; Solange das Ergebnis auch nach Aufrundung >= 1 bliebe,
  926.           ; eine Vorkommastelle mehr einplanen:
  927.           (do ()
  928.               ((< (+ (ash numerator 1) aufrund-einh) (ash denominator 1)))
  929.             (setq denominator (* denominator 10))
  930.             (setq stelle (1+ stelle))
  931.           )
  932.           ; Falls d oder width angegeben:
  933.           ; letzte-stelle ausrechnen
  934.           (if d
  935.             ; Falls dmin angegeben: (min (- d) (- dmin)) = (- (max d dmin)).
  936.             ; Sonst (- d).
  937.             (progn
  938.               (setq letzte-stelle (- d))
  939.               (when (and dmin (> letzte-stelle (- dmin)))
  940.                 (setq letzte-stelle (- dmin))
  941.             ) )
  942.             ; Falls nicht d, nur width angegeben:
  943.             (when width
  944.               (if (< stelle 0)
  945.                 ; Es kommen fⁿhrende Nullen nach dem Punkt -> d:=(1- width)
  946.                 (setq letzte-stelle (- 1 width))
  947.                 ; Es kommen keine fⁿhrenden Nullen nach dem Punkt ->
  948.                 ; Es wird stelle Vorkommaziffern geben, d:=(- (1- width) stelle)
  949.                 (setq letzte-stelle (1+ (- stelle width)))
  950.               )
  951.               ; also letzte-stelle = (- (- (1- width) (max stelle 0)))
  952.               ; wieder dmin berⁿcksichtigen:
  953.               (when (and dmin (> letzte-stelle (- dmin)))
  954.                 (setq letzte-stelle (- dmin))
  955.           ) ) )
  956.           (when (or d width)
  957.             (let* ((ziffernzahl (- letzte-stelle stelle))
  958.                    ; ziffernzahl = - Zahl signifikanter Stellen oder >=0.
  959.                    (dezimal-einh denominator))
  960.               ; dezimal-einh := (ceiling (* dezimal-einh (expt 10 ziffernzahl)))
  961.               (if (>= ziffernzahl 0)
  962.                 (dotimes (i ziffernzahl)
  963.                   (setq dezimal-einh (* dezimal-einh 10))
  964.                 )
  965.                 (dotimes (i (- ziffernzahl))
  966.                   (setq dezimal-einh (ceiling dezimal-einh 10))
  967.                 )
  968.               )
  969.               ; dezimal-einh = Um wieviel numerator erh÷ht bzw. erniedigt werden
  970.               ; mⁿ▀te, damit sich die Dezimaldarstellung um genau 1 an der
  971.               ; Position letzte-stelle verΣndert.
  972.               (setq abrund-einh (max dezimal-einh abrund-einh))
  973.               (setq aufrund-einh (max dezimal-einh aufrund-einh))
  974.               ; Jetzt darf auch um eine (halbe) DEZIMAL-Einheit gerundet werden.
  975.               (when (= aufrund-einh dezimal-einh) (setq halbzahlig T))
  976.           ) )
  977.           (when (< (+ (ash numerator 1) aufrund-einh) (ash denominator 1))
  978.             (return)
  979.         ) )
  980.         ; stelle = Position der ersten signifikanten Stelle + 1
  981.         ; Fⁿhrenden Punkt und nachfolgende Nullen ausgeben:
  982.         (when (< stelle 0)
  983.           (setq point-pos digit-count)
  984.           (vector-push-extend #\. digit-string)
  985.           (dotimes (i (- stelle))
  986.             (incf digit-count)
  987.             (vector-push-extend #\0 digit-string)
  988.         ) )
  989.         ; Ziffern der Mantisse ausgeben:
  990.         (loop
  991.           (when (zerop stelle)
  992.             (vector-push-extend #\. digit-string)
  993.             (setq point-pos digit-count)
  994.           )
  995.           (decf stelle)
  996.           (multiple-value-setq (digit numerator)
  997.             (truncate (* numerator 10) denominator)
  998.           )
  999.           (setq abrund-einh (* abrund-einh 10))
  1000.           (setq aufrund-einh (* aufrund-einh 10))
  1001.           (setq abrunden (< (ash numerator 1) abrund-einh))
  1002.           (if halbzahlig
  1003.             (setq aufrunden
  1004.               (>= (ash numerator 1) (- (ash denominator 1) aufrund-einh))
  1005.             )
  1006.             (setq aufrunden
  1007.               (> (ash numerator 1) (- (ash denominator 1) aufrund-einh))
  1008.             )
  1009.           )
  1010.           (when (or abrunden aufrunden
  1011.                     (and letzte-stelle (<= stelle letzte-stelle))
  1012.                 )
  1013.             (return)
  1014.           )
  1015.           (vector-push-extend (schar "0123456789" digit) digit-string)
  1016.           (incf digit-count)
  1017.         )
  1018.         ; letzte signifikante Ziffer ausgeben:
  1019.         (when (or (null letzte-stelle) (>= stelle letzte-stelle))
  1020.           (vector-push-extend
  1021.             (schar "0123456789"
  1022.               (cond
  1023.                 ((and abrunden (not aufrunden)) digit)
  1024.                 ((and aufrunden (not abrunden)) (1+ digit))
  1025.                 ((<= (ash numerator 1) denominator) digit)
  1026.                 (t (1+ digit))
  1027.             ) )
  1028.             digit-string
  1029.           )
  1030.           (incf digit-count)
  1031.         )
  1032.         ; Nachfolgende Nullen und Punkt ausgeben
  1033.         (when (>= stelle 0)
  1034.           (dotimes (i stelle)
  1035.             (incf digit-count)
  1036.             (vector-push-extend #\0 digit-string)
  1037.           )
  1038.           (vector-push-extend #\. digit-string)
  1039.           (setq point-pos digit-count)
  1040.         )
  1041.         (when d
  1042.           (dotimes (i (- d (- digit-count point-pos)))
  1043.             (incf digit-count)
  1044.             (vector-push-extend #\0 digit-string)
  1045.         ) )
  1046.         (values
  1047.                   digit-string               ; Ziffern
  1048.                   (1+ digit-count)           ; Anzahl der Ziffern
  1049.                   (= point-pos 0)            ; Punkt ganz vorne?
  1050.                   (= point-pos digit-count)  ; Punkt ganz hinten?
  1051.                   point-pos                  ; Position des Punktes
  1052.         ) ; 5 Werte
  1053. ) ) ) )
  1054. )
  1055.  
  1056. ; (format-float-for-f w d k overflowchar padchar plus-sign-flag arg stream)
  1057. ; gibt die Floating-Point-Zahl arg in Festkommadarstellung auf stream aus.
  1058. (defun format-float-for-f (w d k overflowchar padchar plus-sign-flag arg stream)
  1059.   (let ((width (if w (if (or plus-sign-flag (minusp arg)) (1- w) w) nil)))
  1060.     ; width = zur Verfⁿgung stehende Zeichen ohne Vorzeichen
  1061.     (multiple-value-bind (digits digitslength leadingpoint trailingpoint)
  1062.         (format-float-to-string arg width d k nil)
  1063.       (when (eql d 0) (setq trailingpoint nil)) ; d=0 -> keine Zusatz-Null hinten
  1064.       (when w
  1065.         (setq width (- width digitslength))
  1066.         (when leadingpoint ; evtl. Zusatz-Null vorne einplanen
  1067.           (if (> width 0) (setq width (1- width)) (setq leadingpoint nil))
  1068.         )
  1069.         (when trailingpoint ; evtl. Zusatz-Null hinten einplanen
  1070.           (if (> width 0) (setq width (1- width)) (setq trailingpoint nil))
  1071.         )
  1072.       )
  1073.       ; Es bleiben noch width Zeichen ⁿbrig.
  1074.       (if (and overflowchar w (minusp width))
  1075.         (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
  1076.         (progn
  1077.           (when (and w (> width 0)) (format-padding width padchar stream))
  1078.           (if (minusp arg)
  1079.             (write-char #\- stream)
  1080.             (if plus-sign-flag (write-char #\+ stream))
  1081.           )
  1082.           (when leadingpoint (write-char #\0 stream))
  1083.           (write-string digits stream)
  1084.           (when trailingpoint (write-char #\0 stream))
  1085.       ) )
  1086. ) ) )
  1087.  
  1088. ; (format-float-for-e w d e k overflowchar padchar exponentchar plus-sign-flag
  1089. ;                     arg stream)
  1090. ; gibt die Floating-point-Zahl arg in Exponentialdarstellung auf den stream aus.
  1091. ; (vgl. CLTL S.392-394)
  1092. ; Aufteilung der Mantisse:
  1093. ;   Falls k<=0, erst 1 Null (falls von der Breite her passend), dann der Punkt,
  1094. ;               dann |k| Nullen, dann d-|k| signifikante Stellen;
  1095. ;               zusammen also d Nachkommastellen.
  1096. ;   Falls k>0,  erst k signifikante Stellen, dann der Punkt,
  1097. ;               dann weitere d-k+1 signifikante Stellen;
  1098. ;               zusammen also d+1 signifikante Stellen. Keine Nullen vorne.
  1099. ;   (Der Defaultwert in FORMAT-EXPONENTIAL-FLOAT ist k=1.)
  1100. ; Vor der Mantisse das Vorzeichen (ein + nur falls arg>=0 und plus-sign-flag).
  1101. ; Dann der Exponent, eingeleitet durch exponentchar, dann Vorzeichen des
  1102. ; Exponenten (stets + oder -), dann e Stellen fⁿr den Exponenten.
  1103. ; Dann wird das Ganze mit padchars auf w Zeichen Breite aufgefⁿllt.
  1104. ; Sollte das (auch nach evtl. Unterdrⁿckung einer fⁿhrenden Null) mehr als
  1105. ; w Zeichen ergeben, so werden statt dessen w overflowchars ausgegeben, oder
  1106. ; (falls overflowchar = nil) die Zahl mit so vielen Stellen wie n÷tig
  1107. ; ausgegeben.
  1108. (defun format-float-for-e (w d e k
  1109.        overflowchar padchar exponentchar plus-sign-flag arg stream)
  1110.   (multiple-value-bind (mantissa oldexponent) (format-scale-exponent (abs arg))
  1111.     (let* ((exponent (if (zerop arg) 0 (- oldexponent k))) ; auszugebender Exponent
  1112.            (expdigits (write-to-string (abs exponent) :base 10. :radix nil :readably nil))
  1113.            (expdigitsneed (if e (max (length expdigits) e) (length expdigits)))
  1114.            ; expdigitsneed = Anzahl der Stellen, die fⁿr die Ziffern des
  1115.            ; Exponenten n÷tig sind.
  1116.            (mantd (if d (if (> k 0) (1+ (- d k)) d) nil))
  1117.            ; mantd = Anzahl der Mantissenstellen hinter dem Punkt
  1118.            (dmin (if (minusp k) (- 1 k) nil)) ; nachher: fordere, da▀
  1119.            ; nicht in die ersten (+ 1 (abs k)) Stellen hineingerundet wird.
  1120.            (mantwidth (if w (- w 2 expdigitsneed) nil))
  1121.            ; mantwidth = Anzahl der fⁿr die Mantisse (inkl. Vorzeichen, Punkt)
  1122.            ; zur Verfⁿgung stehenden Zeichen (oder nil)
  1123.           )
  1124.       (declare (simple-string expdigits) (fixnum exponent expdigitsneed))
  1125.       (if (and overflowchar w e (> expdigitsneed e))
  1126.         ; Falls Overflowchar und w und e angegeben, Exponent mehr braucht:
  1127.         (format-padding w overflowchar stream)
  1128.         (progn
  1129.           (if w
  1130.             (if (or plus-sign-flag (minusp arg)) (setq mantwidth (1- mantwidth)))
  1131.           )
  1132.           ; mantwidth = Anzahl der fⁿr die Mantisse (ohne Vorzeichen,
  1133.           ; inklusive Punkt) zur Verfⁿgung stehenden Zeichen (oder nil)
  1134.           (multiple-value-bind (mantdigits mantdigitslength
  1135.                                 leadingpoint trailingpoint)
  1136.               (format-float-to-string mantissa mantwidth mantd k dmin)
  1137.             (when w
  1138.               (setq mantwidth (- mantwidth mantdigitslength))
  1139.               (if trailingpoint
  1140.                 (if (or (null mantd) (> mantd 0))
  1141.                   (setq mantwidth (- mantwidth 1))
  1142.                   (setq trailingpoint nil)
  1143.               ) )
  1144.               (if leadingpoint
  1145.                 (if (> mantwidth 0)
  1146.                   (setq mantwidth (- mantwidth 1))
  1147.                   (setq leadingpoint nil)
  1148.               ) )
  1149.             )
  1150.             ; Es bleiben noch mantwidth Zeichen ⁿbrig.
  1151.             (if (and overflowchar w (minusp mantwidth))
  1152.               (format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
  1153.               (progn
  1154.                 (when (and w (> mantwidth 0))
  1155.                   (format-padding mantwidth padchar stream)
  1156.                 )
  1157.                 (if (minusp arg)
  1158.                   (write-char #\- stream)
  1159.                   (if plus-sign-flag (write-char #\+ stream))
  1160.                 )
  1161.                 (if leadingpoint (write-char #\0 stream))
  1162.                 (write-string mantdigits stream)
  1163.                 (if trailingpoint (write-char #\0 stream))
  1164.                 (write-char
  1165.                   (cond (exponentchar)
  1166.                         ((and (not *PRINT-READABLY*)
  1167.                               (typep arg *READ-DEFAULT-FLOAT-FORMAT*)
  1168.                          )
  1169.                          #\E
  1170.                         )
  1171.                         ((short-float-p arg) #\s)
  1172.                         ((single-float-p arg) #\f)
  1173.                         ((double-float-p arg) #\d)
  1174.                         ((long-float-p arg) #\L)
  1175.                   )
  1176.                   stream
  1177.                 )
  1178.                 (write-char (if (minusp exponent) #\- #\+) stream)
  1179.                 (when (and e (> e (length expdigits)))
  1180.                   (format-padding (- e (length expdigits)) #\0 stream)
  1181.                 )
  1182.                 (write-string expdigits stream)
  1183.           ) ) )
  1184.     ) ) )
  1185. ) )
  1186.  
  1187. ; Rⁿckt *FORMAT-CSDL* vor bis zum Ende des momentanen ~[ bzw. ~{ bzw. ~< .
  1188. (defun format-skip-to-end ()
  1189.   (do ()
  1190.       ((null (csd-clause-chain (car *FORMAT-CSDL*))))
  1191.     (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
  1192. ) )
  1193.  
  1194. ; (format-justified-segments mincol colinc minpad justify-left justify-right
  1195. ;   piecelist) berechnet, an welchen Stellen zwischen den einzelnen Strings in
  1196. ; piecelist wieviele Leerstellen zu setzen sind.
  1197. ; Zwischen die einzelnen Strings aus piecelist (auch vorher, falls justify-left;
  1198. ; auch nachher, falls justify-right) werden mindestens minpad padding-characters
  1199. ; eingefⁿgt. Dann werden nochmals weitere padding-characters dazugenommen,
  1200. ; damit die Gesamtbreite >= mincol wird. Ist die Breite > mincol, werden weitere
  1201. ; padding-characters dazugenommen, so da▀ die Breite von der Form
  1202. ; mincol + k * colinc wird. Diese padding-characters werden auf die einzelnen
  1203. ; Stellen gleichmΣ▀ig verteilt.
  1204. ; 1. Wert: Ein Vektor, der zu jeder Stelle angibt, wieviele padding-characters
  1205. ; einzufⁿgen sind (NIL = keine).
  1206. ; Erstes Element: ganz links, zweites: nach 1. String, ..., letztes: rechts.
  1207. ; 2. Wert: Die sich ergebende Gesamtbreite.
  1208. (defun format-justified-segments
  1209.        (mincol colinc minpad justify-left justify-right piecelist)
  1210.   (declare (fixnum mincol colinc minpad))
  1211.   (let ((piecesnumber 0)
  1212.         (pieceswidth 0))
  1213.     (dolist (piece piecelist)
  1214.       (declare (simple-string piece))
  1215.       (incf piecesnumber)
  1216.       (incf pieceswidth (length piece))
  1217.     )
  1218.     (let* ((new-justify-left
  1219.              (or justify-left (and (= piecesnumber 1) (not justify-right))))
  1220.            (padblocks (+ piecesnumber -1       ; Anzahl der Einfⁿge-Stellen
  1221.                          (if new-justify-left 1 0) (if justify-right 1 0)
  1222.            )          )
  1223.            (width-need (+ pieceswidth (* padblocks minpad)))
  1224.            (width (+ mincol
  1225.                      (if (<= width-need mincol)
  1226.                          0
  1227.                          (* (ceiling (- width-need mincol) colinc) colinc)
  1228.           ))      )  )
  1229.       (declare (fixnum piecesnumber pieceswidth padblocks width-need width))
  1230.       (multiple-value-bind (padwidth rest) (floor (- width pieceswidth) padblocks)
  1231.         (let ((padblock-lengths
  1232.                 (make-array (1+ piecesnumber) :initial-element padwidth)
  1233.              ))
  1234.           (unless new-justify-left (setf (svref padblock-lengths 0) nil))
  1235.           (unless justify-right (setf (svref padblock-lengths piecesnumber) nil))
  1236.           (do ((i 0 (1+ i)))
  1237.               ((zerop rest))
  1238.             (when (svref padblock-lengths i)
  1239.               (incf (svref padblock-lengths i))
  1240.               (decf rest)
  1241.           ) )
  1242.           (values padblock-lengths width)
  1243. ) ) ) ) )
  1244.  
  1245. ;-------------------------------------------------------------------------------
  1246.  
  1247. ; ~A, CLTL S.387-388, CLtL2 S. 584
  1248. (defformat-simple format-ascii (stream colon-modifier atsign-modifier
  1249.                   (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1250.                   (arg)
  1251.   (when (and colon-modifier (null arg)) (setq arg "()"))
  1252.   (if (and (zerop mincol) (zerop minpad))
  1253.     (princ arg stream)
  1254.     (format-padded-string mincol colinc minpad padchar
  1255.       atsign-modifier ; =: padleftflag
  1256.       (princ-to-string arg)
  1257.       stream
  1258. ) ) )
  1259.  
  1260. ; ~S, CLTL S.388, CLtL2 S. 584
  1261. (defformat-simple format-s-expression (stream colon-modifier atsign-modifier
  1262.                   (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1263.                   (arg)
  1264.   (if (and (zerop mincol) (zerop minpad))
  1265.     (if (and colon-modifier (null arg))
  1266.       (write-string "()" stream)
  1267.       (prin1 arg stream)
  1268.     )
  1269.     (format-padded-string mincol colinc minpad padchar
  1270.       atsign-modifier ; =: padleftflag
  1271.       (if (and colon-modifier (null arg)) "()" (prin1-to-string arg))
  1272.       stream
  1273. ) ) )
  1274.  
  1275. ; ~W
  1276. (defformat-simple format-write (stream colon-modifier atsign-modifier
  1277.                   (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1278.                   (arg)
  1279.   (declare (ignore colon-modifier))
  1280.   (if (and (zerop mincol) (zerop minpad))
  1281.     (write arg :stream stream)
  1282.     (format-padded-string mincol colinc minpad padchar
  1283.       atsign-modifier ; =: padleftflag
  1284.       (write-to-string arg)
  1285.       stream
  1286. ) ) )
  1287.  
  1288. ; ~D, CLTL S.388, CLtL2 S. 585
  1289. (defformat-simple format-decimal (stream colon-modifier atsign-modifier
  1290.                   (mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
  1291.                   (arg)
  1292.   (format-base 10 stream colon-modifier atsign-modifier mincol padchar commachar commainterval arg)
  1293. )
  1294.  
  1295. ; ~B, CLTL S.388, CLtL2 S. 585
  1296. (defformat-simple format-binary (stream colon-modifier atsign-modifier
  1297.                   (mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
  1298.                   (arg)
  1299.   (format-base 2 stream colon-modifier atsign-modifier mincol padchar commachar commainterval arg)
  1300. )
  1301.  
  1302. ; ~O, CLTL S.388, CLtL2 S. 585
  1303. (defformat-simple format-octal (stream colon-modifier atsign-modifier
  1304.                   (mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
  1305.                   (arg)
  1306.   (format-base 8 stream colon-modifier atsign-modifier mincol padchar commachar commainterval arg)
  1307. )
  1308.  
  1309. ; ~X, CLTL S.388-389, CLtL2 S. 586
  1310. (defformat-simple format-hexadecimal (stream colon-modifier atsign-modifier
  1311.                   (mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
  1312.                   (arg)
  1313.   (format-base 16 stream colon-modifier atsign-modifier mincol padchar commachar commainterval arg)
  1314. )
  1315.  
  1316. ; ~R, CLTL S.389, CLtL2 S. 586-587
  1317. (defformat-simple format-radix (stream colon-modifier atsign-modifier
  1318.                   (radix nil) (mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
  1319.                   (arg)
  1320.   (if radix
  1321.     (format-integer radix mincol padchar commachar commainterval
  1322.                     colon-modifier atsign-modifier
  1323.                     arg stream
  1324.     )
  1325.     (if atsign-modifier
  1326.       (if (integerp arg)
  1327.         (if colon-modifier
  1328.           (format-old-roman arg stream)
  1329.           (format-new-roman arg stream)
  1330.         )
  1331.         (format-error *FORMAT-CS* nil
  1332.           (DEUTSCH "Die ~~R- und ~~:R-Direktiven erwarten ein Integer als Argument, nicht ~S"
  1333.            ENGLISH "The ~~R and ~~:R directives require an integer argument, not ~S"
  1334.            FRANCAIS "Les directives ~~R et ~~:R nΘcessitent un argument de type entier et non ~S")
  1335.           arg
  1336.       ) )
  1337.       (if colon-modifier
  1338.         (format-ordinal arg stream)
  1339.         (format-cardinal arg stream)
  1340. ) ) ) )
  1341.  
  1342. ; ~P, CLTL S. 389, CLtL2 S. 587-588
  1343. (defun format-plural (stream colon-modifier atsign-modifier)
  1344.   (when colon-modifier (format-goto-new-arg t 1))
  1345.   (let ((singular (eql (next-arg) 1)))
  1346.     (if atsign-modifier
  1347.       (write-string (if singular "y" "ies") stream)
  1348.       (unless singular (write-char #\s stream))
  1349. ) ) )
  1350.  
  1351. ; ~C, CLTL S.389-390, CLtL2 S. 588
  1352. (defformat-simple format-character (stream colon-modifier atsign-modifier)
  1353.                   (arg)
  1354.   (unless (characterp arg)
  1355.     (format-error *FORMAT-CS* nil
  1356.       (DEUTSCH "Die ~~C-Direktive erwartet ein Character, nicht ~S"
  1357.        ENGLISH "The ~~C directive requires a character argument, not ~S"
  1358.        FRANCAIS "La directive ~~C requiert un caractΦre et non ~S")
  1359.       arg
  1360.   ) )
  1361.   (flet ((write-charname (arg)
  1362.            (let ((name (char-name arg)))
  1363.              (if name
  1364.                (write-string (string-capitalize name) stream)
  1365.                (write-char arg stream)
  1366.         )) ) )
  1367.     (if (not atsign-modifier)
  1368.       ; ~C oder ~:C
  1369.       (progn
  1370.         (dolist (name '(:CONTROL :META :SUPER :HYPER))
  1371.           (when (char-bit arg name)
  1372.             (write-string (string-capitalize (symbol-name name)) stream
  1373.                           :end (if colon-modifier nil 1)
  1374.             )
  1375.             (write-char #\- stream)
  1376.         ) )
  1377.         (if (not colon-modifier)
  1378.           ; ~C
  1379.           (write-char (make-char arg 0 (char-font arg)) stream)
  1380.           ; ~:C
  1381.           (write-charname (make-char arg))
  1382.       ) )
  1383.       (if (not colon-modifier)
  1384.         ; ~@C
  1385.         (prin1 arg stream)
  1386.         ; ~:@C -- hier NUR die Anweisung, wie's zu tippen ist.
  1387.         (progn
  1388.           (let ((keynames '("Shift-" "Control-" "Alternate-")))
  1389.             (dolist (name '(:SUPER :CONTROL :META))
  1390.               (when (char-bit arg name)
  1391.                 (write-string (car keynames) stream)
  1392.                 (setq arg (set-char-bit arg name nil))
  1393.               )
  1394.               (setq keynames (cdr keynames))
  1395.           ) )
  1396.           (let* ((hyperkey-alist
  1397.                    #+(or DOS OS/2 UNIX AMIGA)
  1398.                    '(
  1399.    #-(or UNIX AMIGA) (#\Enter  . "Enter" )
  1400.              #-AMIGA (#\Insert . "Insert")
  1401.              #-AMIGA (#\End    . "End"   )
  1402.                      (#\Down   . "Down"  )
  1403.              #-AMIGA (#\PgDn   . "PgDn"  )
  1404.                      (#\Left   . "Left"  )
  1405.               #+UNIX (#\Center . "Center")
  1406.                      (#\Right  . "Right" )
  1407.              #-AMIGA (#\Home   . "Home"  )
  1408.                      (#\Up     . "Up"    )
  1409.              #-AMIGA (#\PgUp   . "PgUp"  )
  1410.              #+AMIGA (#\Help   . "Help"  )
  1411.      #+(or DOS OS/2) (#\Prtscr . "PrtScr")
  1412.    #-(or UNIX AMIGA) (#\Delete . "Delete")
  1413.                      (#\F1     . "F1"    )
  1414.                      (#\F2     . "F2"    )
  1415.                      (#\F3     . "F3"    )
  1416.                      (#\F4     . "F4"    )
  1417.                      (#\F5     . "F5"    )
  1418.                      (#\F6     . "F6"    )
  1419.                      (#\F7     . "F7"    )
  1420.                      (#\F8     . "F8"    )
  1421.                      (#\F9     . "F9"    )
  1422.                      (#\F10    . "F10"   )
  1423.              #-AMIGA (#\F11    . "F11"   )
  1424.              #-AMIGA (#\F12    . "F12"   )
  1425.                     )
  1426.                    #-(or DOS OS/2 UNIX AMIGA)
  1427.                    '()
  1428.                  )
  1429.                  (acons (assoc arg hyperkey-alist)))
  1430.             (if acons
  1431.               (write-string (cdr acons) stream)
  1432.               (progn
  1433.                 (when (char-bit arg ':HYPER)
  1434.                   (write-string (DEUTSCH "Ziffernblock-"
  1435.                                  ENGLISH "Keypad-"
  1436.                                  FRANCAIS "bloc numΘrique ")
  1437.                                 stream
  1438.                   )
  1439.                   (setq arg (set-char-bit arg :HYPER nil))
  1440.                 )
  1441.                 (write-charname arg)
  1442.         ) ) ) )
  1443. ) ) ) )
  1444.  
  1445. ; ~F, CLTL S.390-392, CLtL2 S. 588-590
  1446. (defformat-simple format-fixed-float (stream colon-modifier atsign-modifier
  1447.                   (w nil) (d nil) (k 0) (overflowchar nil) (padchar #\Space))
  1448.                   (arg)
  1449.   (declare (ignore colon-modifier))
  1450.   (when (rationalp arg) (setq arg (float arg)))
  1451.   (if (floatp arg)
  1452.     (format-float-for-f w d k overflowchar padchar atsign-modifier arg stream)
  1453.     (format-ascii-decimal arg stream)
  1454. ) )
  1455.  
  1456. ; ~E, CLTL S.392-395, CLtL2 S. 590-593
  1457. (defformat-simple format-exponential-float (stream colon-modifier atsign-modifier
  1458.                   (w nil) (d nil) (e nil) (k 1)
  1459.                   (overflowchar nil) (padchar #\Space) (exponentchar nil))
  1460.                   (arg)
  1461.   (declare (ignore colon-modifier))
  1462.   (when (rationalp arg) (setq arg (float arg)))
  1463.   (if (floatp arg)
  1464.     (format-float-for-e w d e k overflowchar padchar exponentchar
  1465.                         atsign-modifier arg stream
  1466.     )
  1467.     (format-ascii-decimal arg stream)
  1468. ) )
  1469.  
  1470. ; ~G, CLTL S.395-396, CLtL2 S. 594-595
  1471. (defformat-simple format-general-float (stream colon-modifier atsign-modifier
  1472.                   (w nil) (d nil) (e nil) (k 1)
  1473.                   (overflowchar nil) (padchar #\Space) (exponentchar nil))
  1474.                   (arg)
  1475.   (declare (ignore colon-modifier))
  1476.   (if (rationalp arg) (setq arg (float arg)))
  1477.   (if (floatp arg)
  1478.     (multiple-value-bind (mantissa n) (format-scale-exponent (abs arg))
  1479.       (declare (ignore mantissa))
  1480.       (if (null d)
  1481.         (setq d
  1482.           (multiple-value-bind (digits digitslength)
  1483.             (format-float-to-string (abs arg) nil nil nil nil)
  1484.             (declare (ignore digits))
  1485.             (max (max (1- digitslength) 1) (min n 7))
  1486.       ) ) )
  1487.       (let* ((ee (if e (+ 2 e) 4))
  1488.              (dd (- d n)))
  1489.         (if (<= 0 dd d)
  1490.           (progn
  1491.             (format-float-for-f
  1492.               (if w (- w ee) nil)
  1493.               dd 0
  1494.               overflowchar padchar atsign-modifier arg stream
  1495.             )
  1496.             (format-padding ee #\Space stream)
  1497.           )
  1498.           (format-float-for-e w d e k overflowchar padchar exponentchar
  1499.                               atsign-modifier arg stream
  1500.     ) ) ) )
  1501.     (format-ascii-decimal arg stream)
  1502. ) )
  1503.  
  1504. ; ~$, CLTL S.396-397, CLtL2 S. 595-596
  1505. (defformat-simple format-dollars-float (stream colon-modifier atsign-modifier
  1506.                   (d 2) (n 1) (w 0) (padchar #\Space))
  1507.                   (arg)
  1508.   (when (rationalp arg) (setq arg (float arg)))
  1509.   (if (floatp arg)
  1510.     (multiple-value-bind (digits digitslength
  1511.                           leadingpoint trailingpoint leadings)
  1512.       (format-float-to-string arg nil d 0 nil)
  1513.       (declare (ignore digitslength leadingpoint trailingpoint))
  1514.       (let* ((lefts (max leadings n))
  1515.              (totalwidth (+ (if (or atsign-modifier (minusp arg)) 1 0)
  1516.                             lefts 1 d
  1517.              )           )
  1518.              (padcount (max (- w totalwidth) 0)))
  1519.         (if (not colon-modifier) (format-padding padcount padchar stream))
  1520.         (if (minusp arg)
  1521.           (write-char #\- stream)
  1522.           (if atsign-modifier (write-char #\+ stream))
  1523.         )
  1524.         (if colon-modifier (format-padding padcount padchar stream))
  1525.         (format-padding (- lefts leadings) #\0 stream)
  1526.         (write-string digits stream)
  1527.     ) )
  1528.     (format-ascii-decimal arg stream)
  1529. ) )
  1530.  
  1531. ; ~%, CLTL S.397, CLtL2 S. 596
  1532. (defun format-terpri (stream colon-modifier atsign-modifier &optional (count 1))
  1533.   (declare (ignore colon-modifier atsign-modifier))
  1534.   (if (null count) (setq count 1))
  1535.   (dotimes (i count) (terpri stream))
  1536. )
  1537.  
  1538. ; ~&, CLTL S.397, CLtL2 S. 596
  1539. (defun format-fresh-line (stream colon-modifier atsign-modifier
  1540.                           &optional (count 1))
  1541.   (declare (ignore colon-modifier atsign-modifier))
  1542.   (if (null count) (setq count 1))
  1543.   (when (plusp count)
  1544.     (fresh-line stream)
  1545.     (dotimes (i (1- count)) (terpri stream))
  1546. ) )
  1547.  
  1548. ; ~|, CLTL S.397, CLtL2 S. 596
  1549. (defun format-page (stream colon-modifier atsign-modifier &optional (count 1))
  1550.   (declare (ignore colon-modifier atsign-modifier))
  1551.   (if (null count) (setq count 1))
  1552.   (dotimes (i count) (write-char #\Page stream))
  1553. )
  1554.  
  1555. ; ~~, CLTL S.397, CLtL2 S. 596
  1556. (defun format-tilde (stream colon-modifier atsign-modifier &optional (count 1))
  1557.   (declare (ignore colon-modifier atsign-modifier))
  1558.   (if (null count) (setq count 1))
  1559.   (dotimes (i count) (write-char #\~ stream))
  1560. )
  1561.  
  1562. ; ~T, CLTL S.398-399, CLtL2 S. 597-598
  1563. (defun format-tabulate (stream colon-modifier atsign-modifier
  1564.                         &optional (colnum 1) (colinc 1))
  1565.   (declare (ignore colon-modifier))
  1566.   (if (null colnum) (setq colnum 1))
  1567.   (if (null colinc) (setq colinc 1))
  1568.   (let* ((new-colnum (max colnum 0))
  1569.          (new-colinc (max colinc 1)) ; >0
  1570.          (pos (sys::line-position stream))) ; aktuelle Position, Fixnum >=0
  1571.     (if atsign-modifier
  1572.       (format-padding
  1573.         (+ new-colnum (mod (- (+ pos new-colnum)) new-colinc))
  1574.         #\Space stream
  1575.       )
  1576.       (if (< pos new-colnum)
  1577.         (format-padding (- new-colnum pos) #\Space stream)
  1578.         (unless (zerop colinc)
  1579.           (format-padding (+ colinc (mod (- new-colnum pos) (- colinc)))
  1580.                           #\Space stream
  1581. ) ) ) ) ) )
  1582.  
  1583. ; ~*, CLTL S.399, CLtL2 S. 598
  1584. (defun format-goto (stream colon-modifier atsign-modifier &optional (index nil))
  1585.   (declare (ignore stream))
  1586.   (if atsign-modifier
  1587.     (setq *FORMAT-NEXT-ARG* (nthcdr (or index 0) *FORMAT-ARG-LIST*))
  1588.     (format-goto-new-arg colon-modifier (or index 1))
  1589. ) )
  1590.  
  1591. ; ~?, CLTL S.399-401, CLtL2 S. 598-599
  1592. (defun format-indirection (stream colon-modifier atsign-modifier)
  1593.   (declare (ignore colon-modifier))
  1594.   (let* ((csarg (next-arg))
  1595.          (node (do-format-indirection-1 csarg)))
  1596.     (if atsign-modifier
  1597.       (if (consp node)
  1598.         (let ((*FORMAT-CS* (car node))
  1599.               (*FORMAT-CSDL* (cdr node))
  1600.              ;(*FORMAT-ARG-LIST* *FORMAT-NEXT-ARG*) ; ??
  1601.               (*FORMAT-UP-AND-OUT* nil))
  1602.           (format-interpret stream)
  1603.         )
  1604.         (setq *FORMAT-NEXT-ARG*
  1605.           (let ((*FORMAT-CS* nil))
  1606.             (apply node stream *FORMAT-NEXT-ARG*)
  1607.       ) ) )
  1608.       (let ((arglistarg (next-arg)))
  1609.         (do-format-indirection-2 stream node arglistarg arglistarg)
  1610. ) ) ) )
  1611. (defun do-format-indirection (stream csarg arguments)
  1612.   (unless (or (stringp csarg) (functionp csarg))
  1613.     (format-indirection-cserror csarg)
  1614.   )
  1615.   (unless (listp arguments) (format-indirection-lerror arguments))
  1616.   (format-apply stream csarg arguments)
  1617. )
  1618. (defun do-format-indirection-1 (csarg)
  1619.   (cond ((stringp csarg)
  1620.          (let ((node (list csarg)))
  1621.            (format-parse-cs csarg 0 node nil)
  1622.            node
  1623.         ))
  1624.         ((functionp csarg)
  1625.          csarg
  1626.         )
  1627.         (t (format-indirection-cserror csarg))
  1628. ) )
  1629. (defun do-format-indirection-2 (stream node arglistarg wholelistarg)
  1630.   (unless (listp arglistarg) (format-indirection-lerror arglistarg))
  1631.   (if (consp node)
  1632.     (let* ((*FORMAT-CS*         (car node))
  1633.            (*FORMAT-CSDL*       (cdr node))
  1634.            (*FORMAT-ARG-LIST*   wholelistarg)
  1635.            (*FORMAT-NEXT-ARG*   arglistarg)
  1636.            (*FORMAT-NEXT-ARGLIST* nil)
  1637.            (*FORMAT-UP-AND-OUT* nil))
  1638.       (format-interpret stream)
  1639.       *FORMAT-NEXT-ARG*
  1640.     )
  1641.     (let ((*FORMAT-CS* nil))
  1642.       (apply node stream arglistarg) ; wholelistarg??
  1643. ) ) )
  1644. (defun format-indirection-cserror (csarg)
  1645.   (format-error *FORMAT-CS* nil
  1646.     (DEUTSCH "Als Kontrollstring fⁿr ~~? ist das untauglich: ~S"
  1647.      ENGLISH "The control string argument for the ~~? directive is invalid: ~S"
  1648.      FRANCAIS "~S ne convient pas comme chaεne de contr⌠le pour ~~?.")
  1649.     csarg
  1650. ) )
  1651. (defun format-indirection-lerror (arguments)
  1652.   (format-error *FORMAT-CS* nil
  1653.     (DEUTSCH "Das ist keine passende Argumentliste fⁿr die ~~?-Direktive: ~S"
  1654.      ENGLISH "The argument list argument for the ~~? directive is invalid: ~S"
  1655.      FRANCAIS "Ceci n'est pas une liste d'arguments convenable pour la directive ~~? : ~S")
  1656.     arguments
  1657. ) )
  1658.  
  1659. ; ~(, CLTL S.401, CLtL2 S. 600-601
  1660. (defun format-case-conversion (stream colon-modifier atsign-modifier)
  1661.   (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1662.   (let ((tempstr
  1663.           (let ((tempstream (make-string-output-stream (sys::line-position stream))))
  1664.             (format-interpret tempstream 'FORMAT-CASE-CONVERSION-END)
  1665.             ; Was bewirkt UP-AND-OUT in ~{...~(...~^...~)...~} ??
  1666.             (get-output-stream-string tempstream)
  1667.        )) )
  1668.     (if colon-modifier
  1669.       (if atsign-modifier
  1670.         (write-string (nstring-upcase tempstr) stream)
  1671.         (write-string (nstring-capitalize tempstr) stream)
  1672.       )
  1673.       (if atsign-modifier
  1674.         (write-string (nstring-capitalize1 tempstr) stream)
  1675.         (write-string (nstring-downcase tempstr) stream)
  1676. ) ) ) )
  1677. (defun nstring-capitalize1 (string)
  1678.   (setq string (nstring-downcase string))
  1679.   (dotimes (i (length string)) ; erstes Zeichen zum Upcase machen
  1680.     (when (both-case-p (schar string i))
  1681.       (setf (schar string i) (char-upcase (schar string i)))
  1682.       (return)
  1683.   ) )
  1684.   string
  1685. )
  1686.  
  1687. ; ~[, CLTL S.402-403, CLtL2 S. 601-602
  1688. (defun format-conditional (stream colon-modifier atsign-modifier
  1689.                            &optional (prefix nil))
  1690.   (if colon-modifier
  1691.     (if atsign-modifier
  1692.       (format-conditional-error)
  1693.       (progn
  1694.         (when (next-arg)
  1695.           (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
  1696.         )
  1697.         (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1698.         (format-interpret stream 'FORMAT-CONDITIONAL-END)
  1699.       )
  1700.     )
  1701.     (if atsign-modifier
  1702.       (when (next-arg)
  1703.         (format-goto-new-arg t 1)
  1704.         (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1705.         (format-interpret stream 'FORMAT-CONDITIONAL-END)
  1706.         (unless (null (csd-clause-chain (car *FORMAT-CSDL*)))
  1707.           (format-error *FORMAT-CS* nil
  1708.             (DEUTSCH "Hier ist keine ~~;-Direktive m÷glich."
  1709.              ENGLISH "The ~~; directive is not allowed at this point."
  1710.              FRANCAIS "La directive ~~; n'est pas permise ici.")
  1711.       ) ) )
  1712.       (let ((index (or prefix (next-arg))))
  1713.         (unless (integerp index)
  1714.           (format-error *FORMAT-CS* nil
  1715.             (DEUTSCH "Argument fⁿr ~~[ mu▀ ein Integer sein, nicht ~S"
  1716.              ENGLISH "The ~~[ parameter must be an integer, not ~S"
  1717.              FRANCAIS "L'argument pour ~~[ doit Ωtre un entier et non ~S")
  1718.             index
  1719.         ) )
  1720.         (dotimes (i (if (minusp index) most-positive-fixnum index))
  1721.           (when (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
  1722.             (return)
  1723.           )
  1724.           (setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
  1725.           (when (csd-colon-p (car *FORMAT-CSDL*)) (return))
  1726.         )
  1727.         (unless (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
  1728.           (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1729.         )
  1730.         (format-interpret stream 'FORMAT-CONDITIONAL-END)
  1731.   ) ) )
  1732.   (format-skip-to-end) ; Weiterrⁿcken bis ans Ende der ~[...~]-Direktive
  1733. )
  1734. (defun format-conditional-error ()
  1735.   (format-error *FORMAT-CS* nil
  1736.     (DEUTSCH "~~[ geht nicht mit : und @ gleichzeitig."
  1737.      ENGLISH "The ~~[ directive cannot take both modifiers."
  1738.      FRANCAIS "La directive ~~[ ne peut pas accepter les deux qualificateurs : et @ en mΩme temps.")
  1739. ) )
  1740.  
  1741. ; ~{, CLTL S.403-404, CLtL2 S. 602-604
  1742. (defun format-iteration (stream colon-modifier atsign-modifier
  1743.                          &optional (prefix nil))
  1744.   (let* ((total-csdl *FORMAT-CSDL*)
  1745.          (max-iteration-count prefix))
  1746.     (format-skip-to-end) ; Weiterrⁿcken bis ans Ende der ~{...~}-Direktive
  1747.     (let* ((min-1-iteration (csd-colon-p (car *FORMAT-CSDL*)))
  1748.            (inner-cs (if (eq (cdr total-csdl) *FORMAT-CSDL*)
  1749.                        (next-arg)
  1750.                        *FORMAT-CS*
  1751.            )         )
  1752.            (inner-csdl (if (stringp inner-cs)
  1753.                          (if (eq (cdr total-csdl) *FORMAT-CSDL*)
  1754.                            (let ((node (list inner-cs)))
  1755.                              (format-parse-cs inner-cs 0 node nil)
  1756.                              (cdr node)
  1757.                            )
  1758.                            (cdr total-csdl)
  1759.            )           ) )
  1760.            (arg-list-rest (if (not atsign-modifier)
  1761.                             (let ((arg (next-arg)))
  1762.                               (unless (listp arg)
  1763.                                 (format-error *FORMAT-CS* nil
  1764.                                   (DEUTSCH "Das Argument zu ~~{ mu▀ eine Liste sein, nicht ~S"
  1765.                                    ENGLISH "The ~~{ directive requires a list argument, not ~S"
  1766.                                    FRANCAIS "L'argument de ~~{ doit Ωtre une liste et non ~S")
  1767.                                   arg
  1768.                               ) )
  1769.                               arg
  1770.           ))              ) )
  1771.       (do* ((iteration-count 0 (1+ iteration-count)))
  1772.            ((or (and max-iteration-count
  1773.                      (>= iteration-count max-iteration-count)
  1774.                 )
  1775.                 (let ((remaining (if atsign-modifier
  1776.                                    *FORMAT-NEXT-ARG*
  1777.                                    arg-list-rest
  1778.                      ))          )
  1779.                   (if min-1-iteration
  1780.                     (and (plusp iteration-count) (null remaining))
  1781.                     (null remaining)
  1782.            ))   ) )
  1783.         (if (stringp inner-cs)
  1784.           (if colon-modifier
  1785.             (let* ((*FORMAT-ARG-LIST*
  1786.                      (if atsign-modifier (next-arg) (pop arg-list-rest))
  1787.                    )
  1788.                    (*FORMAT-NEXT-ARGLIST* ; fⁿr ~:^
  1789.                      (if atsign-modifier *FORMAT-NEXT-ARG* arg-list-rest)
  1790.                    )
  1791.                    (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
  1792.                    (*FORMAT-CS* inner-cs)
  1793.                    (*FORMAT-CSDL* inner-csdl)
  1794.                    (*FORMAT-UP-AND-OUT* nil))
  1795.               (format-interpret stream 'FORMAT-ITERATION-END)
  1796.               (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
  1797.             )
  1798.             (if atsign-modifier
  1799.               (let* (; CLtL2 S. 598: "When within a ~{ construct, the "goto" is
  1800.                      ; relative to the list of arguments being processed by the
  1801.                      ; iteration." Soll das hei▀en, da▀ man bei ~@{ zu Beginn
  1802.                      ; jeder Iteration *FORMAT-ARG-LIST* neu binden mu▀ ??
  1803.                      ; (*FORMAT-ARG-LIST* *FORMAT-NEXT-ARG*) ??
  1804.                      (*FORMAT-CS* inner-cs)
  1805.                      (*FORMAT-CSDL* inner-csdl)
  1806.                      (*FORMAT-UP-AND-OUT* nil))
  1807.                 (format-interpret stream 'FORMAT-ITERATION-END)
  1808.                 (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
  1809.               )
  1810.               (let* ((*FORMAT-ARG-LIST* arg-list-rest)
  1811.                      (*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
  1812.                      (*FORMAT-CS* inner-cs)
  1813.                      (*FORMAT-CSDL* inner-csdl)
  1814.                      (*FORMAT-UP-AND-OUT* nil))
  1815.                 (format-interpret stream 'FORMAT-ITERATION-END)
  1816.                 (setq arg-list-rest *FORMAT-NEXT-ARG*)
  1817.                 (when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
  1818.           ) ) )
  1819.           ; inner-cs may be a function in the ~{~} case
  1820.           (if (functionp inner-cs)
  1821.             (if colon-modifier
  1822.               (let* ((arglist (if atsign-modifier (next-arg) (pop arg-list-rest)))
  1823.                      (*FORMAT-CS* nil))
  1824.                 (apply inner-cs stream arglist)
  1825.               )
  1826.               (if atsign-modifier
  1827.                 (setq *FORMAT-NEXT-ARG*
  1828.                   (let ((*FORMAT-CS* nil))
  1829.                     (apply inner-cs stream *FORMAT-NEXT-ARG*)
  1830.                 ) )
  1831.                 (setq arg-list-rest
  1832.                   (let ((*FORMAT-CS* nil))
  1833.                     (apply inner-cs stream arg-list-rest)
  1834.             ) ) ) )
  1835.             (format-indirection-cserror inner-cs)
  1836. ) ) ) ) ) )
  1837.  
  1838. ; ~<, CLTL S.404-406, CLtL2 S. 604-605
  1839. (defun format-justification (stream colon-modifier atsign-modifier
  1840.        &optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
  1841.   (let* ((saved-csdl *FORMAT-CSDL*)
  1842.          (pos (sys::line-position stream))
  1843.          (tempstream (make-string-output-stream pos))
  1844.          (check-on-line-overflow nil)
  1845.          supplementary-need
  1846.          line-length
  1847.          (old-piecelist
  1848.            (let ((pieces nil))
  1849.              (do ((first-piece-flag t nil))
  1850.                  ((eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-JUSTIFICATION-END))
  1851.                (setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
  1852.                (let ((*FORMAT-UP-AND-OUT* nil))
  1853.                  (format-interpret tempstream 'FORMAT-JUSTIFICATION-END)
  1854.                  (when (and first-piece-flag (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-SEPARATOR))
  1855.                    (when (setq check-on-line-overflow (csd-colon-p (car *FORMAT-CSDL*)))
  1856.                      (multiple-value-setq (supplementary-need line-length)
  1857.                        (values-list (format-resolve-parms (car *FORMAT-CSDL*)))
  1858.                  ) ) )
  1859.                  (when *FORMAT-UP-AND-OUT*
  1860.                    (setq *FORMAT-CSDL* saved-csdl)
  1861.                    (format-skip-to-end)
  1862.                    (return)
  1863.                  )
  1864.                  (push (get-output-stream-string tempstream) pieces)
  1865.              ) )
  1866.              (nreverse pieces)
  1867.         )) )
  1868.     (do-format-justification stream colon-modifier atsign-modifier
  1869.                              mincol colinc minpad padchar
  1870.                              pos check-on-line-overflow
  1871.                              (if check-on-line-overflow (car old-piecelist))
  1872.                              supplementary-need line-length
  1873.                              (if check-on-line-overflow (cdr old-piecelist) old-piecelist)
  1874. ) ) )
  1875. (defun do-format-justification (stream colon-modifier atsign-modifier
  1876.                                 mincol colinc minpad padchar
  1877.                                 pos check-on-line-overflow firstpiece
  1878.                                 supplementary-need line-length piecelist)
  1879.   (if (null mincol) (setq mincol 0))
  1880.   (if (null colinc) (setq colinc 1))
  1881.   (if (null minpad) (setq minpad 0))
  1882.   (if (null padchar) (setq padchar #\Space))
  1883.   (if piecelist
  1884.     (multiple-value-bind (padblocklengths width)
  1885.       (format-justified-segments mincol colinc minpad
  1886.         colon-modifier atsign-modifier piecelist)
  1887.       (when (and check-on-line-overflow
  1888.                  (> (+ pos width (or supplementary-need 0))
  1889.                     (or line-length #|(sys::line-length stream)|# 72)
  1890.             )    )
  1891.         (write-string firstpiece stream)
  1892.       )
  1893.       (do ((i 0 (1+ i)))
  1894.           (nil)
  1895.         (when (svref padblocklengths i)
  1896.           (format-padding (svref padblocklengths i) padchar stream)
  1897.         )
  1898.         (when (null piecelist) (return))
  1899.         (write-string (pop piecelist) stream)
  1900.     ) )
  1901.     (format-padding mincol padchar stream)
  1902. ) )
  1903.  
  1904. ; ~^, CLTL S.406-407, CLtL2 S. 605-606
  1905. (defun format-up-and-out (stream colon-modifier atsign-modifier
  1906.                           &optional (a nil) (b nil) (c nil))
  1907.   (declare (ignore stream atsign-modifier))
  1908.   (if (up-and-out-p a b c
  1909.         (if colon-modifier *FORMAT-NEXT-ARGLIST* *FORMAT-NEXT-ARG*)
  1910.       )
  1911.     (setq *FORMAT-UP-AND-OUT* (if colon-modifier ':TERMINATE-ALL ':TERMINATE))
  1912. ) )
  1913. (defun up-and-out-p (a b c &optional args)
  1914.   (cond ((and (null a) (null b) (null c)) ; keine Parameter
  1915.          (null args)
  1916.         )
  1917.         ((and (null b) (null c)) (eql a 0)) ; ein Parameter
  1918.         ((null c) (eql a b)) ; zwei Parameter
  1919.         ((and (integerp a) (integerp b) (integerp c)) (<= a b c))
  1920.         ((and (characterp a) (characterp b) (characterp c)) (char<= a b c))
  1921. ) )
  1922.  
  1923. ;-------------------------------------------------------------------------------
  1924.  
  1925. ;; FORMATTER - Compilation von FORMAT-Strings.
  1926.  
  1927.  
  1928. ; Fall-back function if control-string cannot be compiled.
  1929. (defun formatter-hairy (control-string)
  1930.   ; control-string is known to be a string
  1931.   #'(lambda (stream &rest args)
  1932.       (let ((node (list control-string)))
  1933.         (format-parse-cs control-string 0 node nil)
  1934.         (let* ((*FORMAT-CS*         (car node))
  1935.                (*FORMAT-CSDL*       (cdr node))
  1936.                (*FORMAT-ARG-LIST*   args)
  1937.                (*FORMAT-NEXT-ARG*   *FORMAT-ARG-LIST*)
  1938.                (*FORMAT-NEXT-ARGLIST* nil)
  1939.                (*FORMAT-UP-AND-OUT* nil))
  1940.           (format-interpret stream)
  1941.           *FORMAT-NEXT-ARG*
  1942.     ) ) )
  1943. )
  1944.  
  1945.  
  1946. ; Block fⁿr ~^
  1947. (defvar *format-terminate*)
  1948. ; Block fⁿr ~:^
  1949. (defvar *format-terminate-all*)
  1950.  
  1951. ; Der Block wird nur bei Bedarf bereitgestellt.
  1952. ; Um unn÷tige UNWIND-PROTECTs zu vermeiden, wird eine Liste der anhΣngigen
  1953. ; UNWIND-PROTECTs gefⁿhrt. Jeder Blockname (ein Gensym) enthΣlt einen Verweis
  1954. ; auf diese Liste zum Zeitpunkt seiner Bildung.
  1955.  
  1956. ; Liste der anhΣngigen UNWIND-PROTECTs
  1957. (defvar *format-uwps*)
  1958.  
  1959. (defun formatter-block (prefix)
  1960.   (let ((sym (gensym prefix)))
  1961.     (setf (get sym 'uwps) *format-uwps*)
  1962.     sym
  1963. ) )
  1964.  
  1965. (flet ((mark-used (blockname)
  1966.          ; Markiere den Block, so da▀ er nicht wegoptimiert wird.
  1967.          (setf (get blockname 'used) t)
  1968.          ; Markiere alle ⁿbersprungenen UNWIND-PROTECTs, so da▀ sie nicht
  1969.          ; wegoptimiert werden.
  1970.          (do ((L1 *format-uwps* (cdr L1))
  1971.               (L2 (get blockname 'uwps)))
  1972.              ((eq L1 L2))
  1973.            (setf (car L1) 'T)
  1974.          )
  1975.          blockname
  1976.       ))
  1977.   (defun formatter-terminate ()
  1978.     (mark-used *format-terminate*)
  1979.   )
  1980.   (defun formatter-terminate-all ()
  1981.     (mark-used *format-terminate-all*)
  1982.   )
  1983. )
  1984.  
  1985. (defmacro formatter-bind-terminator (&body body)
  1986.   `(let ((*format-terminate* (formatter-block "TERMINATE-")))
  1987.      (formatter-bind-terminator-1 (progn ,@body))
  1988.    )
  1989. )
  1990. (defun formatter-bind-terminator-1 (forms)
  1991.   (when (get *format-terminate* 'used)
  1992.     (setq forms `((BLOCK ,*format-terminate* ,@forms)))
  1993.   )
  1994.   forms
  1995. )
  1996.  
  1997. (defmacro formatter-bind-terminators (&body body)
  1998.   `(let ((*format-terminate* (formatter-block "TERMINATE-"))
  1999.          (*format-terminate-all* (formatter-block "TERMINATE-ALL-")))
  2000.      (formatter-bind-terminators-1 (progn ,@body))
  2001.    )
  2002. )
  2003. (defun formatter-bind-terminators-1 (forms)
  2004.   (when (get *format-terminate* 'used)
  2005.     (setq forms `((BLOCK ,*format-terminate* ,@forms)))
  2006.   )
  2007.   (when (get *format-terminate-all* 'used)
  2008.     (setq forms `((BLOCK ,*format-terminate-all* ,@forms)))
  2009.   )
  2010.   forms
  2011. )
  2012.  
  2013.  
  2014. ; Flag, ob innerhalb von ~(...~)
  2015. (defvar *format-case*)
  2016.  
  2017.  
  2018. ; Wegen ~:^ kann die Argumentliste nicht immer denselben Namen ARGS haben.
  2019. ; Ihr Name.
  2020. (defvar *args*)
  2021.  
  2022. ; Name der Argumentliste der umschlie▀enden ~:{ Iteration.
  2023. (defvar *iterargs*)
  2024.  
  2025.  
  2026. ; Zugriff auf die normale Argumentliste:
  2027. ; Normalfall:
  2028. ;   Argumentliste &REST ARGS,
  2029. ;   Zugriff auf das nΣchste Element ist (POP ARGS),
  2030. ;   ~# ist (LENGTH ARGS),
  2031. ;   Gesamtliste fⁿr ~:* ist WHOLE-ARGS.
  2032. ; Optimiert, falls kein (LENGTH ARGS) und kein WHOLE-ARGS n÷tig ist:
  2033. ;   Argumentliste #:ARG1 #:ARG2 ... &REST ARGS
  2034. ;   Zugriff auf das nΣchste Element ist #:ARGi oder (POP ARGS).
  2035.  
  2036. ; Flag, das anzeigt, ob man sich noch in der linearen Abarbeitungsphase der
  2037. ; Argumente befindet (jedes genau einmal, bekannte Position).
  2038. (defvar *formatter-linear-args*)
  2039.  
  2040. ; Anzahl der Argumente, die bisher zur linearen Abarbeitungsphase geh÷ren.
  2041. ; Wichtig: Diese kann hinterher erniedrigt werden!!
  2042. (defvar *formatter-linear-argcount*)
  2043.  
  2044. ; Position in der Argumentliste wΣhrend der linearen Abarbeitungsphase.
  2045. ; Stets <= *formatter-linear-argcount*.
  2046. (defvar *formatter-linear-position*)
  2047.  
  2048. ; Flag, ob WHOLE-ARGS gebunden werden soll.
  2049. (defvar *formatter-whole-args*)
  2050.  
  2051. ; Beginnt eine Iteration, die ARGS und evtl. WHOLE-ARGS bindet.
  2052. (defmacro formatter-bind-args (&body body)
  2053.   `(let ((*args* (gensym "ARGS"))
  2054.          (*formatter-linear-args* t)
  2055.          (*formatter-linear-argcount* 0)
  2056.          (*formatter-linear-position* 0)
  2057.          (*formatter-whole-args* nil))
  2058.      (formatter-bind-args-1 (progn ,@body))
  2059.    )
  2060. )
  2061. (defun formatter-bind-args-1 (forms)
  2062.   (when *formatter-whole-args*
  2063.     (subst-if-then #'(lambda (x) ; x = `(WHOLE-ARGS ,i)
  2064.                        (setq *formatter-linear-argcount*
  2065.                              (min *formatter-linear-argcount* (second x))
  2066.                      ) )
  2067.                    #'(lambda (x) ; x = `(WHOLE-ARGS ,i) ?
  2068.                        (and (consp x) (eq (car x) 'WHOLE-ARGS)
  2069.                             (consp (cdr x)) (numberp (cadr x)) (null (cddr x))
  2070.                      ) )
  2071.                    forms
  2072.   ) )
  2073.   (let ((argsyms nil))
  2074.     (dotimes (i *formatter-linear-argcount*) (push (gensym "ARG") argsyms))
  2075.     (setq argsyms (nreverse argsyms))
  2076.     (setq forms
  2077.       (subst-if-then #'(lambda (x) ; x = `(ARG ,i)
  2078.                          (if (< (second x) *formatter-linear-argcount*)
  2079.                            (nth (second x) argsyms)
  2080.                            `(POP ,*args*)
  2081.                        ) )
  2082.                      #'(lambda (x) ; x = `(ARG ,i) ?
  2083.                          (and (consp x) (eq (car x) 'ARG) (consp (cdr x)) (null (cddr x)))
  2084.                        )
  2085.                      forms
  2086.     ) )
  2087.     (setq forms
  2088.       (subst-if-then #'(lambda (x) ; x = `(SETQ-ARGS-WHOLE-ARGS ,old-pos ,new-pos)
  2089.                          (let ((old-pos (second x)) (new-pos (third x)))
  2090.                            (if (<= old-pos *formatter-linear-argcount*)
  2091.                              ; no need for WHOLE-ARGS since ARGS = WHOLE-ARGS at this point
  2092.                              (if (<= new-pos *formatter-linear-argcount*)
  2093.                                `(PROGN)
  2094.                                `(SETQ ,*args* (NTHCDR ,(- new-pos *formatter-linear-argcount*) ,*args*))
  2095.                              )
  2096.                              (progn
  2097.                                (setq *formatter-whole-args* t)
  2098.                                `(SETQ ,*args* (WHOLE-ARGS ,(max new-pos *formatter-linear-argcount*)))
  2099.                        ) ) ) )
  2100.                      #'(lambda (x) ; x = `(SETQ-ARGS-WHOLE-ARGS ,i ,j) ?
  2101.                          (and (consp x) (eq (car x) 'SETQ-ARGS-WHOLE-ARGS)
  2102.                               (consp (cdr x)) (consp (cddr x)) (null (cdddr x)))
  2103.                        )
  2104.                      forms
  2105.     ) )
  2106.     (when *formatter-whole-args*
  2107.       (setq forms
  2108.         (subst-if-then #'(lambda (x) ; x = `(WHOLE-ARGS ,i)
  2109.                            (let ((i (- (second x) *formatter-linear-argcount*)))
  2110.                              (if (zerop i)
  2111.                                `WHOLE-ARGS
  2112.                                `(NTHCDR ,i WHOLE-ARGS)
  2113.                          ) ) )
  2114.                        #'(lambda (x) ; x = `(WHOLE-ARGS ,i) ?
  2115.                            (and (consp x) (eq (car x) 'WHOLE-ARGS)
  2116.                                 (consp (cdr x)) (numberp (cadr x)) (null (cddr x))
  2117.                          ) )
  2118.                        forms
  2119.       ) )
  2120.       (setq forms `((LET ((WHOLE-ARGS ,*args*)) ,@forms)))
  2121.     )
  2122.     (values `(,@argsyms &REST ,*args*)
  2123.             `((DECLARE (IGNORABLE ,@argsyms ,*args*)) ,@forms)
  2124. ) ) )
  2125.  
  2126. ; Beendet den linearen Modus. Ab jetzt kann auf die Argumentliste
  2127. ; als ARGS zugegriffen werden.
  2128. (defun formatter-stop-linear ()
  2129.   (when *formatter-linear-args*
  2130.     (setq *formatter-linear-argcount*
  2131.           (min *formatter-linear-argcount* *formatter-linear-position*)
  2132.     )
  2133.     ; Jetzt ist *formatter-linear-argcount* = *formatter-linear-position*.
  2134.     (setq *formatter-linear-args* nil)
  2135. ) )
  2136.  
  2137. ; Holt eine Form, die die LΣnge der Argumentliste liefert.
  2138. (defun formatter-length-args ()
  2139.   (formatter-stop-linear)
  2140.   `(LENGTH ,*args*)
  2141. )
  2142.  
  2143. ; Holt eine Form fⁿr das nΣchste Argument.
  2144. ; Diese Form mu▀ nachher mit SUBST ersetzt werden.
  2145. (defun formatter-next-arg ()
  2146.   (if *formatter-linear-args*
  2147.     (prog1
  2148.       `(ARG ,*formatter-linear-position*)
  2149.       (incf *formatter-linear-position*)
  2150.       (setq *formatter-linear-argcount*
  2151.             (max *formatter-linear-argcount* *formatter-linear-position*)
  2152.     ) )
  2153.     `(POP ,*args*)
  2154. ) )
  2155.  
  2156. ; Holt eine Form, die ein nthcdr der ganzen Argumentliste liefert.
  2157. ; Diese Form mu▀ nachher mit SUBST ersetzt werden.
  2158. (defun formatter-whole-args (n)
  2159.   (formatter-stop-linear)
  2160.   (setq *formatter-whole-args* t)
  2161.   `(WHOLE-ARGS ,n)
  2162. )
  2163.  
  2164. ; Holt eine Formenliste zum ▄berspringen (vor/zurⁿck) von Argumenten.
  2165. (defun formatter-goto-arg (absolute-p backward-p n)
  2166.   (if absolute-p
  2167.     ; im einfachsten Fall: (setq args (nthcdr n whole-args))
  2168.     (if (numberp n)
  2169.       (progn
  2170.         (setq n (max n 0))
  2171.         (if *formatter-linear-args*
  2172.           (if (< n *formatter-linear-position*)
  2173.             (prog1
  2174.               `((SETQ-ARGS-WHOLE-ARGS ,*formatter-linear-position* ,n))
  2175.               (setq *formatter-linear-position* n)
  2176.             )
  2177.             ; n >= *formatter-linear-position*
  2178.             (formatter-goto-arg nil nil (- n *formatter-linear-position*))
  2179.           )
  2180.           (progn
  2181.             (formatter-stop-linear)
  2182.             `((SETQ ,*args* ,(formatter-whole-args n)))
  2183.       ) ) )
  2184.       (progn
  2185.         (formatter-stop-linear)
  2186.         `((SETQ ,*args* (NTHCDR ,n ,(formatter-whole-args 0))))
  2187.     ) )
  2188.     (if backward-p
  2189.       ; im einfachsten Fall:
  2190.       ; (setq args (nthcdr (max (- (length whole-args) (length args) n) 0) whole-args))
  2191.       (if (and (numberp n) *formatter-linear-args*)
  2192.         (formatter-goto-arg t nil (- *formatter-linear-position* n))
  2193.         (progn
  2194.           (formatter-stop-linear)
  2195.           `((SETQ ,*args* ,(if *formatter-linear-args*
  2196.                              `(NTHCDR (MAX (- ,*formatter-linear-position* ,n) 0) ,(formatter-whole-args 0))
  2197.                              `(LIST-BACKWARD ,n ; n zuerst auswerten, da es (POP ARGS) enthalten kann
  2198.                                 ,(formatter-whole-args 0) ,*args*
  2199.                               )
  2200.                            )
  2201.            ))
  2202.       ) )
  2203.       ; im einfachsten Fall: (setq args (nthcdr n args))
  2204.       (if (and (numberp n) (<= n 100) *formatter-linear-args*)
  2205.         (do ((l '() (cons (formatter-next-arg) l)) (i 0 (1+ i)))
  2206.             ((>= i n) (nreverse l))
  2207.         )
  2208.         (progn
  2209.           (formatter-stop-linear)
  2210.           `((SETQ ,*args* (NTHCDR ,n ,*args*)))
  2211.       ) )
  2212. ) ) )
  2213. (defun list-backward (n whole-list list)
  2214.   (nthcdr (max (- (length whole-list) (length list) n) 0) whole-list)
  2215. )
  2216.  
  2217. ; Holt eine Form, der ein Direktiven-Argument liefert.
  2218. (defun formatter-arg (arg)
  2219.   (case arg
  2220.     (:NEXT-ARG (formatter-next-arg))
  2221.     (:ARG-COUNT (formatter-length-args))
  2222.     (T ; arg ist NIL oder Integer oder Character, braucht nicht quotiert zu werden.
  2223.        arg
  2224. ) ) )
  2225.  
  2226.  
  2227. ; Haupt-Compilier-Funktion. Liefert eine Formenliste.
  2228. ; Fluid ⁿbergeben: *format-cs* und *format-csdl* (wird weitergerⁿckt).
  2229. (defun formatter-main-1 (&optional (endmarker nil))
  2230.   (let ((forms '()))
  2231.     (loop
  2232.       (when (endp *format-csdl*) (return))
  2233.       (let ((csd (car *format-csdl*)))
  2234.         (case (csd-type csd)
  2235.           (0 )
  2236.           (1 (push (subseq *format-cs* (csd-cs-index csd) (csd-data csd))
  2237.                    forms
  2238.           )  )
  2239.           (2 (let ((directive-name (csd-data csd)))
  2240.                (if (eq directive-name endmarker) (return))
  2241.                (if (eq directive-name 'FORMAT-SEPARATOR) (return))
  2242.                (let ((colon-p (csd-colon-p csd))
  2243.                      (atsign-p (csd-atsign-p csd))
  2244.                      (arglist (mapcar #'formatter-arg (csd-parm-list csd)))
  2245.                     )
  2246.                  (labels ((simple-arglist (n)
  2247.                             (unless (<= (length arglist) n)
  2248.                               (format-error *format-cs* nil
  2249.                                 (DEUTSCH "Zu viele Argumente fⁿr diese Direktive."
  2250.                                  ENGLISH "Too many arguments for this directive"
  2251.                                  FRANCAIS "Trop d'arguments pour cette directive.")
  2252.                             ) )
  2253.                             (setq arglist
  2254.                                   (append arglist
  2255.                                           (make-list (- n (length arglist))
  2256.                                                      :initial-element 'NIL
  2257.                           ) )     )       )
  2258.                           (trivial-call ()
  2259.                             (push `(,directive-name
  2260.                                     STREAM
  2261.                                     ,colon-p
  2262.                                     ,atsign-p
  2263.                                     ,@arglist
  2264.                                    )
  2265.                                   forms
  2266.                           ) )
  2267.                           (trivial (n)
  2268.                             (simple-arglist n)
  2269.                             (trivial-call)
  2270.                           )
  2271.                           (simple-call ()
  2272.                             (push `(,(intern (string-concat "DO-" (string directive-name))
  2273.                                              (find-package "SYSTEM")
  2274.                                      )
  2275.                                     STREAM
  2276.                                     ,colon-p
  2277.                                     ,atsign-p
  2278.                                     ,@arglist
  2279.                                     ; Pass the actual argument last because
  2280.                                     ; ,@arglist may contain `(POP ,*args*) as well.
  2281.                                     ,(formatter-next-arg)
  2282.                                    )
  2283.                                   forms
  2284.                           ) )
  2285.                           (simple (n)
  2286.                             (simple-arglist n)
  2287.                             (simple-call)
  2288.                          ))
  2289.                    (case directive-name
  2290.                      (FORMAT-ASCII                  ; #\A
  2291.                        (simple-arglist 4)
  2292.                        (if (and (member (first arglist) '(nil 0)) ; mincol
  2293.                                 (member (third arglist) '(nil 0)) ; minpad
  2294.                            )
  2295.                          (progn
  2296.                            (setq forms (revappend (remove 'NIL arglist) forms))
  2297.                            (push `(PRINC ,(if colon-p
  2298.                                             `(OR ,(formatter-next-arg) "()")
  2299.                                             (formatter-next-arg)
  2300.                                           )
  2301.                                          STREAM
  2302.                                   )
  2303.                                  forms
  2304.                          ) )
  2305.                          (simple-call)
  2306.                      ) )
  2307.                      (FORMAT-S-EXPRESSION           ; #\S
  2308.                        (simple-arglist 4)
  2309.                        (if (and (member (first arglist) '(nil 0)) ; mincol
  2310.                                 (member (third arglist) '(nil 0)) ; minpad
  2311.                                 (not colon-p)
  2312.                            )
  2313.                          (progn
  2314.                            (setq forms (revappend (remove 'NIL arglist) forms))
  2315.                            (push `(PRIN1 ,(formatter-next-arg) STREAM) forms)
  2316.                          )
  2317.                          (simple-call)
  2318.                      ) )
  2319.                      (FORMAT-WRITE                  ; #\W
  2320.                        (simple-arglist 4)
  2321.                        (if (and (member (first arglist) '(nil 0)) ; mincol
  2322.                                 (member (third arglist) '(nil 0)) ; minpad
  2323.                            )
  2324.                          (progn
  2325.                            (setq forms (revappend (remove 'NIL arglist) forms))
  2326.                            (push `(WRITE ,(formatter-next-arg) :STREAM STREAM) forms)
  2327.                          )
  2328.                          (simple-call)
  2329.                      ) )
  2330.                      (FORMAT-DECIMAL                ; #\D
  2331.                        (simple 4) )
  2332.                      (FORMAT-BINARY                 ; #\B
  2333.                        (simple 4) )
  2334.                      (FORMAT-OCTAL                  ; #\O
  2335.                        (simple 4) )
  2336.                      (FORMAT-HEXADECIMAL            ; #\X
  2337.                        (simple 4) )
  2338.                      (FORMAT-RADIX                  ; #\R
  2339.                        (simple-arglist 5)
  2340.                        (if (and (null (first arglist)) (not atsign-p))
  2341.                          (progn
  2342.                            (setq forms (revappend (remove 'NIL arglist) forms))
  2343.                            (push `(,(if colon-p 'FORMAT-ORDINAL 'FORMAT-CARDINAL)
  2344.                                    ,(formatter-next-arg) STREAM
  2345.                                   )
  2346.                                  forms
  2347.                          ) )
  2348.                          (simple-call)
  2349.                      ) )
  2350.                      (FORMAT-PLURAL                 ; #\P
  2351.                        (simple-arglist 0)
  2352.                        (when colon-p
  2353.                          (setq forms (revappend (formatter-goto-arg nil t 1) forms))
  2354.                        )
  2355.                        (push (if atsign-p
  2356.                                `(WRITE-STRING
  2357.                                   (IF (EQL ,(formatter-next-arg) 1) "y" "ies")
  2358.                                   STREAM
  2359.                                 )
  2360.                                `(UNLESS (EQL ,(formatter-next-arg) 1)
  2361.                                   (WRITE-CHAR #\s STREAM)
  2362.                                 )
  2363.                              )
  2364.                              forms
  2365.                      ) )
  2366.                      (FORMAT-CHARACTER              ; #\C
  2367.                        (simple 0) )
  2368.                      (FORMAT-FIXED-FLOAT            ; #\F
  2369.                        (simple 5) )
  2370.                      (FORMAT-EXPONENTIAL-FLOAT      ; #\E
  2371.                        (simple 7) )
  2372.                      (FORMAT-GENERAL-FLOAT          ; #\G
  2373.                        (simple 7) )
  2374.                      (FORMAT-DOLLARS-FLOAT          ; #\$
  2375.                        (simple 4) )
  2376.                      (FORMAT-TERPRI                 ; #\%
  2377.                        (simple-arglist 1)
  2378.                        (if (member (first arglist) '(nil 1))
  2379.                          (push #\Newline forms) ; equiv. to `(TERPRI STREAM)
  2380.                          (trivial-call)
  2381.                      ) )
  2382.                      (FORMAT-FRESH-LINE             ; #\&
  2383.                        (simple-arglist 1)
  2384.                        (if (member (first arglist) '(nil 1))
  2385.                          (push `(FRESH-LINE STREAM) forms)
  2386.                          (trivial-call)
  2387.                      ) )
  2388.                      (FORMAT-PAGE                   ; #\|
  2389.                        (simple-arglist 1)
  2390.                        (if (member (first arglist) '(nil 1))
  2391.                          (push #\Page forms)
  2392.                          (trivial-call)
  2393.                      ) )
  2394.                      (FORMAT-TILDE                  ; #\~
  2395.                        (simple-arglist 1)
  2396.                        (if (member (first arglist) '(nil 1))
  2397.                          (push #\~ forms)
  2398.                          (trivial-call)
  2399.                      ) )
  2400.                      (FORMAT-TABULATE               ; #\T
  2401.                        (trivial 2) )
  2402.                      (FORMAT-GOTO                   ; #\*
  2403.                        (simple-arglist 1)
  2404.                        (setq forms
  2405.                              (revappend
  2406.                                (formatter-goto-arg atsign-p colon-p
  2407.                                  (or (first arglist) (if atsign-p 0 1))
  2408.                                )
  2409.                                forms
  2410.                      ) )     )
  2411.                      (FORMAT-INDIRECTION            ; #\?
  2412.                        (simple-arglist 0)
  2413.                        (if atsign-p
  2414.                          (push `(SETQ ,*args*
  2415.                                   (DO-FORMAT-INDIRECTION STREAM
  2416.                                     ,(formatter-next-arg)
  2417.                                     ,(progn (formatter-stop-linear) `,*args*)
  2418.                                 ) )
  2419.                                forms
  2420.                          )
  2421.                          (push `(DO-FORMAT-INDIRECTION STREAM ,(formatter-next-arg) ,(formatter-next-arg))
  2422.                                forms
  2423.                      ) ) )
  2424.                      (FORMAT-CASE-CONVERSION        ; #\(
  2425.                        (simple-arglist 0)
  2426.                        (setq *format-csdl* (cdr *format-csdl*))
  2427.                        (if *format-case*
  2428.                          ; Richard Waters notes: It is possible for ~(...~) to
  2429.                          ; be nested in a format string, but note that inner
  2430.                          ; nested modes never have any effect. You can just
  2431.                          ; ignore them.
  2432.                          (let ((inner-forms
  2433.                                  ; no need to bind *format-case* to t here
  2434.                                  (formatter-main-1 'FORMAT-CASE-CONVERSION-END)
  2435.                               ))
  2436.                            (setq forms (revappend inner-forms forms))
  2437.                          )
  2438.                          (push `(LET ((ORIG-STREAM STREAM)
  2439.                                       (STREAM (MAKE-STRING-OUTPUT-STREAM (SYS::LINE-POSITION STREAM))))
  2440.                                   ,@(let* ((*format-uwps* (cons 'NIL *format-uwps*))
  2441.                                            (inner-forms
  2442.                                              (let ((*format-case* t))
  2443.                                                (formatter-main 'FORMAT-CASE-CONVERSION-END)
  2444.                                            ) )
  2445.                                            (cleanup-forms
  2446.                                              `((WRITE-STRING
  2447.                                                  (,(if colon-p
  2448.                                                      (if atsign-p
  2449.                                                        'NSTRING-UPCASE
  2450.                                                        'NSTRING-CAPITALIZE
  2451.                                                      )
  2452.                                                      (if atsign-p
  2453.                                                        'SYS::NSTRING-CAPITALIZE1
  2454.                                                        'NSTRING-DOWNCASE
  2455.                                                    ) )
  2456.                                                   (GET-OUTPUT-STREAM-STRING STREAM)
  2457.                                                  )
  2458.                                                  ORIG-STREAM
  2459.                                               ))
  2460.                                           ))
  2461.                                       (if (car *format-uwps*)
  2462.                                         `((UNWIND-PROTECT (PROGN ,@inner-forms) ,@cleanup-forms))
  2463.                                         `(,@inner-forms ,@cleanup-forms)
  2464.                                     ) )
  2465.                                 )
  2466.                                forms
  2467.                      ) ) )
  2468.                      (FORMAT-CONDITIONAL            ; #\[
  2469.                        (if colon-p
  2470.                          (if atsign-p
  2471.                            (format-conditional-error)
  2472.                            (progn
  2473.                              (simple-arglist 0)
  2474.                              (push `(IF (NOT ,(formatter-next-arg))
  2475.                                       (PROGN ,@(progn
  2476.                                                  (formatter-stop-linear)
  2477.                                                  (setq *format-csdl* (cdr *format-csdl*))
  2478.                                                  (formatter-main 'FORMAT-CONDITIONAL-END)
  2479.                                       )        )
  2480.                                       (PROGN ,@(progn
  2481.                                                  (formatter-stop-linear)
  2482.                                                  (setq *format-csdl* (cdr *format-csdl*))
  2483.                                                  (formatter-main 'FORMAT-CONDITIONAL-END)
  2484.                                     ) )        )
  2485.                                    forms
  2486.                          ) ) )
  2487.                          (if atsign-p
  2488.                            (progn
  2489.                              (simple-arglist 0)
  2490.                              (formatter-stop-linear)
  2491.                              (push `(IF (CAR ,*args*)
  2492.                                       (PROGN ,@(progn
  2493.                                                  (setq *format-csdl* (cdr *format-csdl*))
  2494.                                                  (formatter-main 'FORMAT-CONDITIONAL-END)
  2495.                                       )        )
  2496.                                       (SETQ ,*args* (CDR ,*args*))
  2497.                                     )
  2498.                                    forms
  2499.                              )
  2500.                              (unless (null (csd-clause-chain (car *format-csdl*)))
  2501.                                (format-error *format-cs* nil
  2502.                                  (DEUTSCH "Hier ist keine ~~;-Direktive m÷glich."
  2503.                                   ENGLISH "The ~~; directive is not allowed at this point."
  2504.                                   FRANCAIS "La directive ~~; n'est pas permise ici.")
  2505.                            ) ) )
  2506.                            (progn
  2507.                              (simple-arglist 1)
  2508.                              (push `(CASE ,(or (first arglist) (formatter-next-arg))
  2509.                                       ,@(let ((index 0) (cases '()))
  2510.                                           (formatter-stop-linear)
  2511.                                           (loop
  2512.                                             (when (null (csd-clause-chain (car *format-csdl*)))
  2513.                                               (return)
  2514.                                             )
  2515.                                             (when (csd-colon-p (car *format-csdl*))
  2516.                                               (setq index 'T)
  2517.                                             )
  2518.                                             (setq *format-csdl* (cdr *format-csdl*))
  2519.                                             (push `(,index ,@(formatter-main 'FORMAT-CONDITIONAL-END))
  2520.                                                   cases
  2521.                                             )
  2522.                                             (if (eq index 'T) (return) (incf index))
  2523.                                           )
  2524.                                           (nreverse cases)
  2525.                                         )
  2526.                                     )
  2527.                                    forms
  2528.                      ) ) ) ) )
  2529.                      (FORMAT-ITERATION              ; #\{
  2530.                        (simple-arglist 1)
  2531.                        (setq *format-csdl* (cdr *format-csdl*))
  2532.                        (let ((max-n-iterations (first arglist))
  2533.                              (min-1-iteration (csd-colon-p (car (csd-clause-chain csd))))
  2534.                              (indirect (eq (csd-clause-chain csd) *format-csdl*)))
  2535.                          (flet ((compute-innermost ()
  2536.                                   (if indirect
  2537.                                     (progn
  2538.                                       (formatter-stop-linear)
  2539.                                       `((SETQ ,*args*
  2540.                                           (DO-FORMAT-INDIRECTION-2 STREAM NODE
  2541.                                                                    ,*args* ,(formatter-whole-args 0)
  2542.                                        )) )
  2543.                                     )
  2544.                                     (formatter-main 'FORMAT-ITERATION-END)
  2545.                                )) )
  2546.                            (flet ((compute-inner ()
  2547.                                     (if colon-p
  2548.                                       (let ((*iterargs* *args*))
  2549.                                         (formatter-bind-terminator
  2550.                                           (multiple-value-bind (lambdalist innermost)
  2551.                                               (formatter-bind-args (compute-innermost))
  2552.                                             `((APPLY #'(LAMBDA ,lambdalist ,@innermost)
  2553.                                                ,(formatter-next-arg)
  2554.                                              ))
  2555.                                       ) ) )
  2556.                                       (let ((*iterargs* nil))
  2557.                                         ; CLtL2 S. 598: "When within a ~{ construct, the "goto" is
  2558.                                         ; relative to the list of arguments being processed by the
  2559.                                         ; iteration." Soll das hei▀en, da▀ man bei ~@{ zu Beginn
  2560.                                         ; jeder Iteration WHOLE-ARGS neu an ARGS binden mu▀ ??
  2561.                                         ; (if atsign-p
  2562.                                         ;   (progn (formatter-stop-linear)
  2563.                                         ;     `((LET ((WHOLE-ARGS ,*args*)) ,@(compute-innermost)))
  2564.                                         ;   )
  2565.                                         ;   (compute-innermost)
  2566.                                         ; )
  2567.                                         (compute-innermost)
  2568.                                  )) ) )
  2569.                              (flet ((compute-middle ()
  2570.                                       (if (eql max-n-iterations 0)
  2571.                                         '()
  2572.                                         (progn
  2573.                                           (unless (and (eql max-n-iterations 1) min-1-iteration)
  2574.                                             (formatter-stop-linear)
  2575.                                           )
  2576.                                           (if (eql max-n-iterations 1)
  2577.                                             (if min-1-iteration
  2578.                                               (compute-inner)
  2579.                                               `((UNLESS (ENDP ,*args*) ,@(compute-inner)))
  2580.                                             )
  2581.                                             `((BLOCK NIL
  2582.                                                 (TAGBODY
  2583.                                                   L
  2584.                                                   ,@(if max-n-iterations
  2585.                                                       `((WHEN (>= I N) (RETURN)) (INCF I))
  2586.                                                     )
  2587.                                                   ,@(if (not min-1-iteration)
  2588.                                                       `((WHEN (ENDP ,*args*) (RETURN)))
  2589.                                                     )
  2590.                                                   ,@(compute-inner)
  2591.                                                   ,@(if min-1-iteration
  2592.                                                       `((WHEN (ENDP ,*args*) (RETURN)))
  2593.                                                     )
  2594.                                                   (GO L)
  2595.                                              )) )
  2596.                                    )) ) ) )
  2597.                                (flet ((compute-outer ()
  2598.                                         (formatter-bind-terminators
  2599.                                           ; *format-terminate-all* und *format-terminate* werden
  2600.                                           ; gebunden, aber falls colon-p, wird *format-terminate*
  2601.                                           ; weiter innen verschattet (s.o.).
  2602.                                           (if atsign-p
  2603.                                             (compute-middle)
  2604.                                             (multiple-value-bind (lambdalist inner-forms)
  2605.                                                 (formatter-bind-args (compute-middle))
  2606.                                               `((APPLY #'(LAMBDA ,lambdalist ,@inner-forms)
  2607.                                                  ,(formatter-next-arg)
  2608.                                                ))
  2609.                                      )) ) ) )
  2610.                                  (flet ((compute-outermost ()
  2611.                                           (if indirect
  2612.                                             `((LET ((NODE (DO-FORMAT-INDIRECTION-1 ,(formatter-next-arg))))
  2613.                                                 ,@(compute-outer)
  2614.                                              ))
  2615.                                             (compute-outer)
  2616.                                        )) )
  2617.                                    (let ((new-forms
  2618.                                            (if (and max-n-iterations (not (member max-n-iterations '(0 1))))
  2619.                                              `((LET ((N ,(first arglist)) (I 0))
  2620.                                                  ,@(compute-outermost)
  2621.                                               ))
  2622.                                               (compute-outermost)
  2623.                                         )) )
  2624.                                      (setq forms (revappend new-forms forms))
  2625.                      ) ) ) ) ) ) ) )
  2626.                      (FORMAT-JUSTIFICATION          ; #\<
  2627.                        (simple-arglist 4)
  2628.                        (let* ((firstseparator (car (csd-clause-chain csd)))
  2629.                               (check-on-line-overflow
  2630.                                 (and (eq (csd-data firstseparator) 'FORMAT-SEPARATOR)
  2631.                                      (csd-colon-p firstseparator)
  2632.                               ) )
  2633.                               (bindings
  2634.                                 `((POS (SYS::LINE-POSITION STREAM))
  2635.                                   (ORIG-STREAM STREAM)
  2636.                                   (STREAM (MAKE-STRING-OUTPUT-STREAM POS))
  2637.                                  )
  2638.                               )
  2639.                               (justify-args
  2640.                                 `(ORIG-STREAM
  2641.                                   ,colon-p
  2642.                                   ,atsign-p
  2643.                                   ,@arglist
  2644.                                   POS
  2645.                                   ,check-on-line-overflow
  2646.                                   ,(when check-on-line-overflow
  2647.                                      (setq *format-csdl* (cdr *format-csdl*))
  2648.                                      `(PROGN
  2649.                                         ,@(formatter-main 'FORMAT-JUSTIFICATION-END)
  2650.                                         (GET-OUTPUT-STREAM-STRING STREAM)
  2651.                                       )
  2652.                                    )
  2653.                                   ,(when check-on-line-overflow
  2654.                                      (formatter-arg (first (csd-parm-list firstseparator)))
  2655.                                    )
  2656.                                   ,(when check-on-line-overflow
  2657.                                      (formatter-arg (second (csd-parm-list firstseparator)))
  2658.                                    )
  2659.                                  )
  2660.                               )
  2661.                               (*format-uwps* (cons 'NIL *format-uwps*))
  2662.                               (pieces-forms '())
  2663.                              )
  2664.                          (loop
  2665.                            (when (null (csd-clause-chain (car *format-csdl*))) (return))
  2666.                            (setq *format-csdl* (cdr *format-csdl*))
  2667.                            (push (formatter-main 'FORMAT-JUSTIFICATION-END) pieces-forms)
  2668.                          )
  2669.                          (setq pieces-forms (nreverse pieces-forms))
  2670.                          (push
  2671.                            (if (car *format-uwps*)
  2672.                              `(LET* (,@bindings
  2673.                                      (JARGS (LIST ,@justify-args))
  2674.                                      (PIECES '()))
  2675.                                 (UNWIND-PROTECT
  2676.                                   (PROGN
  2677.                                     ,@(mapcap #'(lambda (piece-forms)
  2678.                                                   `(,@piece-forms
  2679.                                                     (PUSH (GET-OUTPUT-STREAM-STRING STREAM) PIECES)
  2680.                                                    )
  2681.                                                 )
  2682.                                               pieces-forms
  2683.                                       )
  2684.                                   )
  2685.                                   (APPLY #'DO-FORMAT-JUSTIFICATION
  2686.                                          (NCONC JARGS (LIST (SYS::LIST-NREVERSE PIECES)))
  2687.                               ) ) )
  2688.                              `(LET* (,@bindings)
  2689.                                 (DO-FORMAT-JUSTIFICATION
  2690.                                   ,@justify-args
  2691.                                   (LIST
  2692.                                     ,@(mapcar #'(lambda (piece-forms)
  2693.                                                   `(PROGN ,@piece-forms (GET-OUTPUT-STREAM-STRING STREAM))
  2694.                                                 )
  2695.                                               pieces-forms
  2696.                                       )
  2697.                               ) ) )
  2698.                            )
  2699.                            forms
  2700.                      ) ) )
  2701.                      (FORMAT-UP-AND-OUT             ; #\^
  2702.                        (simple-arglist 3)
  2703.                        (formatter-stop-linear)
  2704.                        (let ((argsvar (if colon-p *iterargs* *args*)))
  2705.                          (push `(IF ,(if (some #'(lambda (x) (and (constantp x) x)) arglist)
  2706.                                        `(UP-AND-OUT-P ,@arglist)
  2707.                                        (if (and (null (second arglist)) (null (third arglist)))
  2708.                                          (let ((first-arg (first arglist)))
  2709.                                            (if (null first-arg)
  2710.                                              `(ENDP ,argsvar)
  2711.                                              (if (and (consp first-arg) (eq (car first-arg) 'LENGTH))
  2712.                                                `(ENDP ,(second first-arg)) ; (EQL (LENGTH x) 0) == (ENDP x)
  2713.                                                `(CASE ,first-arg ((NIL) (ENDP ,argsvar)) ((0) T) (T NIL))
  2714.                                          ) ) )
  2715.                                          `(UP-AND-OUT-P ,@arglist ,argsvar)
  2716.                                      ) )
  2717.                                   (RETURN-FROM ,(if colon-p (formatter-terminate-all) (formatter-terminate)))
  2718.                                 )
  2719.                                forms
  2720.                      ) ) )
  2721.                      (t ; Huh? Someone implemented a new format directive,
  2722.                         ; but forgot it here! Bail out.
  2723.                         (throw 'formatter-hairy nil)
  2724.                      )
  2725.           )  ) ) ) )
  2726.       ) )
  2727.       (setq *format-csdl* (cdr *format-csdl*))
  2728.     )
  2729.     ; Combine adjacent strings:
  2730.     (let ((new-forms '()))
  2731.       (dolist (form forms)
  2732.         (when (characterp form) (setq form (string form)))
  2733.         (if (and (consp new-forms) (stringp (car new-forms)) (stringp form))
  2734.           (setf (car new-forms)
  2735.                 (concatenate 'string form (car new-forms))
  2736.           )
  2737.           (push form new-forms)
  2738.       ) )
  2739.       new-forms
  2740. ) ) )
  2741. (defun formatter-main (&optional (endmarker nil))
  2742.   (let ((new-forms (formatter-main-1 endmarker)))
  2743.     ; Convert strings to WRITE-STRING forms:
  2744.     (mapcap #'(lambda (form)
  2745.                 (if (stringp form)
  2746.                   (case (length form)
  2747.                     (0 )
  2748.                     (1 (setq form (char form 0))
  2749.                        `(,(if (eq form #\Newline)
  2750.                             `(TERPRI STREAM)
  2751.                             `(WRITE-CHAR ,form STREAM)
  2752.                     )   ) )
  2753.                     (t `((WRITE-STRING ,form STREAM)))
  2754.                   )
  2755.                   (list form)
  2756.               ) )
  2757.             new-forms
  2758. ) ) )
  2759.  
  2760. ;; FORMATTER, CLtL2 S. 764
  2761. (defmacro formatter (control-string)
  2762.   (unless (stringp control-string)
  2763.     (error-of-type 'type-error
  2764.       :datum control-string :expected-type 'string
  2765.       (DEUTSCH "Kontrollstring mu▀ ein String sein, nicht ~S"
  2766.        ENGLISH "The control-string must be a string, not ~S"
  2767.        FRANCAIS "La chaεne de contr⌠le doit Ωtre une chaεne et non ~S")
  2768.       control-string
  2769.   ) )
  2770.   ; evtl. noch control-string zu einem Simple-String machen ??
  2771.   (or
  2772.     (catch 'formatter-hairy
  2773.       (let ((node (list control-string)))
  2774.         (format-parse-cs control-string 0 node nil)
  2775.         (let ((*FORMAT-CS* (car node))
  2776.               (*FORMAT-CSDL* (cdr node))
  2777.               (*format-case* nil)
  2778.               (*format-uwps* '())
  2779.               (*iterargs* nil))
  2780.           (multiple-value-bind (lambdalist forms)
  2781.               (formatter-bind-args
  2782.                 `(,@(formatter-bind-terminators
  2783.                       (formatter-main)
  2784.                     )
  2785.                   ,(progn (formatter-stop-linear) `,*args*)
  2786.                  )
  2787.               )
  2788.             `(FUNCTION
  2789.                (LAMBDA (STREAM ,@lambdalist)
  2790.                  (DECLARE (IGNORABLE STREAM))
  2791.                  ,@forms
  2792.              ) )
  2793.     ) ) ) )
  2794.     `(FORMATTER-HAIRY ,(coerce control-string 'simple-string))
  2795. ) )
  2796.  
  2797. ;-------------------------------------------------------------------------------
  2798.  
  2799.