home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga MA Magazine 1998 #6
/
amigamamagazinepolishissue1998.iso
/
coders
/
jËzyki_programowania
/
clisp
/
src
/
archive
/
clisp.faslsp.lha
/
format.lsp
< prev
next >
Wrap
Text File
|
1996-08-07
|
123KB
|
2,858 lines
; FORMAT - und was dazugehört.
; Bruno Haible 22.06.1988
; CLISP-Version 16.08.1988, 03.09.1988, 04.08.1989
; Groß umgearbeitet von Bruno Haible am 14.02.1990-15.02.1990
; Weiter umgearbeitet und FORMATTER geschrieben am 9.4.1995-11.4.1995
(in-package "SYSTEM")
;-------------------------------------------------------------------------------
; Datenstruktur der Kontrollstring-Direktive:
(defstruct (control-string-directive
(:copier nil)
(:conc-name "CSD-")
(:predicate nil)
(:constructor make-csd ())
)
(type 0 :type fixnum)
(cs-index 0 :type fixnum)
(parm-list nil :type list)
(v-or-#-p nil :type symbol)
(colon-p nil :type symbol)
(atsign-p nil :type symbol)
(data nil)
(clause-chain nil)
)
#+CLISP (remprop 'control-string-directive 'sys::defstruct-description)
; Erläuterung:
; type=0 : Direktive ~<Newline>, nichts auszugeben.
; Weitere Komponenten bedeutungslos
; type=1 : String auszugeben,
; von *FORMAT-CS* die Portion :START cs-index :END data.
; Weitere Komponenten bedeutungslos
; type=2 : Formatier-Direktive auszuführen.
; data = Name der Direktive (Symbol),
; colon-p gibt an, ob ein ':' da war,
; atsign-p gibt an, ob ein '@' da war,
; parm-list = Parameterliste an die Direktive,
; v-or-#-p gibt an, ob parm-list vor dem Aufruf noch zu behandeln ist.
; clause-chain ist eine Verzeigerung: z.B. bei ~[...~;...~;...~]
; von der ~[-Direktive auf die Liste ab der ersten ~;-Direktive,
; von da auf die Liste ab der nächsten ~;-Direktive usw.
; bis schließlich auf die Liste ab der ~]-Direktive.
; Zeigt an, ob ein Character ein Whitespace-Character ist.
(defun whitespacep (char)
(member char '(#\Space #\Newline #\Linefeed #\Tab #\Return #\Page))
)
; (FORMAT-PARSE-CS control-string startindex csdl stop-at)
; parst einen Kontrollstring (genauer: (subseq control-string startindex))
; und legt die sich ergebende Control-String-Directive-Liste in (cdr csdl) ab.
; Das Parsen muß mit der Direktive stop-at enden (ein Character, oder NIL
; für Stringende).
; Falls stop-at /= NIL, ist in (csd-clause-chain (car csdl)) ein Pointer auf
; die Teilliste ab dem nächsten Separator einzutragen. Diese Pointer bilden
; eine einfach verkettete Liste innerhalb csdl: von einem Separator zum
; nächsten, zum Schluß zum Ende der Clause.
(defun format-parse-cs (control-string startindex csdl stop-at)
(declare (fixnum startindex))
(macrolet ((errorstring ()
#L{
DEUTSCH "Kontrollstring endet mitten in einer Direktive."
ENGLISH "The control string terminates within a directive."
FRANCAIS "La chaîne de contrôle se termine en plein milieu d'une directive."
}
))
(prog* ((index startindex) ; cs-index des nächsten Zeichens
ch ; current character
intparam ; Integer-Parameter
newcsd ; aktuelle CSD
(last-separator-csd (car csdl))
)
(declare (type simple-string control-string) (type fixnum index))
(loop ; neue Direktive insgesamt
(tagbody
(when (>= index (length control-string))
(go string-ended)
)
(setq ch (schar control-string index))
(unless (eql ch #\~)
; eventuell noch Stringstück zu einer eingenen Direktive machen
(setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd)))))
(setf (csd-type newcsd) 1)
(setf (csd-cs-index newcsd) index)
(setq index (position #\~ control-string :start index))
(unless index
(setf (csd-data newcsd) (setq index (length control-string)))
(go string-ended)
)
(setf (csd-data newcsd) index)
)
(setq csdl (setf (cdr csdl) (list (setq newcsd (make-csd)))))
(setf (csd-type newcsd) 2)
(setf (csd-cs-index newcsd) index)
(setf (csd-parm-list newcsd) nil)
(setf (csd-v-or-#-p newcsd) nil)
(setf (csd-colon-p newcsd) nil)
(setf (csd-atsign-p newcsd) nil)
(setf (csd-data newcsd) nil)
(setf (csd-clause-chain newcsd) nil)
param ; Parameter einer Direktive kann beginnen
(incf index)
(when (>= index (length control-string))
(format-error control-string index (errorstring))
(go string-ended)
)
(setq ch (schar control-string index))
(when (digit-char-p ch) (go num-param))
(case ch
((#\+ #\-) (go num-param))
(#\' (go quote-param))
((#\V #\v #\#)
(push (if (eql ch #\#) ':ARG-COUNT ':NEXT-ARG)
(csd-parm-list newcsd)
)
(setf (csd-v-or-#-p newcsd) T)
(go param-ok-1)
)
(#\, (push nil (csd-parm-list newcsd)) (go param))
(#\: (go colon-modifier))
(#\@ (go atsign-modifier))
(T (go directive))
)
num-param ; numerischer Parameter
(multiple-value-setq (intparam index)
(parse-integer control-string :start index :junk-allowed t)
)
(unless intparam
(format-error control-string index
#L{
DEUTSCH "~A muß eine Zahl einleiten."
ENGLISH "~A must introduce a number."
FRANCAIS "~A doit introduire un nombre."
}
ch
) )
(push intparam (csd-parm-list newcsd))
(go param-ok-2)
quote-param ; Quote-Parameter-Behandlung
(incf index)
(when (>= index (length control-string))
(format-error control-string index
#L{
DEUTSCH "Kontrollstring endet mitten in einem '-Parameter."
ENGLISH "The control string terminates in the middle of a parameter."
FRANCAIS "La chaîne de contrôle se termine au milieu d'un paramètre."
}
)
(go string-ended)
)
(setq ch (schar control-string index))
(push ch (csd-parm-list newcsd))
param-ok-1 ; Parameter OK
(incf index)
param-ok-2 ; Parameter OK
(when (>= index (length control-string))
(format-error control-string index (errorstring))
(go string-ended)
)
(setq ch (schar control-string index))
(case ch
(#\, (go param))
(#\: (go colon-modifier))
(#\@ (go atsign-modifier))
(T (go directive))
)
colon-modifier ; nach :
(setf (csd-colon-p newcsd) T)
(go passed-modifier)
atsign-modifier ; nach @
(setf (csd-atsign-p newcsd) T)
(go passed-modifier)
passed-modifier ; nach : oder @
(incf index)
(when (>= index (length control-string))
(format-error control-string index (errorstring))
(go string-ended)
)
(setq ch (schar control-string index))
(case ch
(#\: (go colon-modifier))
(#\@ (go atsign-modifier))
(T (go directive))
)
directive ; Direktive (ihr Name) erreicht
(setf (csd-parm-list newcsd) (nreverse (csd-parm-list newcsd)))
(let ((directive-name
(cdr (assoc (char-upcase ch)
'((#\A . FORMAT-ASCII)
(#\S . FORMAT-S-EXPRESSION)
(#\W . FORMAT-WRITE)
(#\D . FORMAT-DECIMAL)
(#\B . FORMAT-BINARY)
(#\O . FORMAT-OCTAL)
(#\X . FORMAT-HEXADECIMAL)
(#\R . FORMAT-RADIX)
(#\P . FORMAT-PLURAL)
(#\C . FORMAT-CHARACTER)
(#\F . FORMAT-FIXED-FLOAT)
(#\E . FORMAT-EXPONENTIAL-FLOAT)
(#\G . FORMAT-GENERAL-FLOAT)
(#\$ . FORMAT-DOLLARS-FLOAT)
(#\% . FORMAT-TERPRI)
(#\& . FORMAT-FRESH-LINE) (#\Newline . #\Newline)
(#\| . FORMAT-PAGE)
(#\~ . FORMAT-TILDE)
(#\T . FORMAT-TABULATE)
(#\* . FORMAT-GOTO)
(#\? . FORMAT-INDIRECTION)
(#\( . FORMAT-CASE-CONVERSION) (#\) . FORMAT-CASE-CONVERSION-END)
(#\[ . FORMAT-CONDITIONAL) (#\] . FORMAT-CONDITIONAL-END)
(#\{ . FORMAT-ITERATION) (#\} . FORMAT-ITERATION-END)
(#\< . FORMAT-JUSTIFICATION) (#\> . FORMAT-JUSTIFICATION-END)
(#\^ . FORMAT-UP-AND-OUT) (#\; . FORMAT-SEPARATOR)
; mit Funktionsdefinition ; ohne Funktionsdefinition
)) ) ) )
(if directive-name
(setf (csd-data newcsd) directive-name)
(format-error control-string index
#L{
DEUTSCH "Diese Direktive gibt es nicht."
ENGLISH "Non-existent directive"
FRANCAIS "Directive non reconnue."
}
) ) )
(incf index)
(case ch
(( #\( #\[ #\{ #\< )
(multiple-value-setq (index csdl)
(format-parse-cs control-string index csdl
(case ch (#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) )
) )
)
(( #\) #\] #\} #\> )
(unless stop-at
(format-error control-string index
#L{
DEUTSCH "Schließende Klammer '~A' ohne vorherige öffnende Klammer"
ENGLISH "The closing directive '~A' does not have a corresponding opening one."
FRANCAIS "Parenthèse fermante '~A' sans parenthèse ouvrante correspondante."
}
ch
) )
(unless (eql ch stop-at)
(format-error control-string index
#L{
DEUTSCH "Schließende Klammer '~A' paßt nicht; sollte '~A' lauten."
ENGLISH "The closing directive '~A' does not match the corresponding opening one. It should read '~A'."
FRANCAIS "La parenthèse fermante '~A' ne correspond pas à celle ouvrante. Il devrait y avoir '~A'."
}
ch stop-at
) )
(setf (csd-clause-chain last-separator-csd) csdl)
(go end)
)
(#\;
(unless (or (eql stop-at #\]) (eql stop-at #\>))
(format-error control-string index
#L{
DEUTSCH "Hier ist keine ~~;-Direktive möglich."
ENGLISH "The ~~; directive is not allowed at this point."
FRANCAIS "La directive ~~; n'est pas permise ici."
}
) )
(setf (csd-clause-chain last-separator-csd) csdl)
(setq last-separator-csd newcsd)
)
(#\Newline
(setf (csd-type newcsd) 0)
(if (csd-colon-p newcsd)
(if (csd-atsign-p newcsd)
(format-error control-string index
#L{
DEUTSCH "Die ~~Newline-Direktive ist mit : und @ sinnlos."
ENGLISH "The ~~newline directive cannot take both modifiers."
FRANCAIS "La directive ~~Newline est insensée avec les deux qualificateurs : et @."
}
)
nil ; ~:<newline> -> Newline ignorieren, Whitespace dalassen
)
(progn
(when (csd-atsign-p newcsd)
; ~@<newline> -> Stringstück mit Newline zum Ausgeben
(setf (csd-type newcsd) 1)
(setf (csd-cs-index newcsd) (1- index))
(setf (csd-data newcsd) index)
)
(setq index
(or (position-if-not #'whitespacep control-string :start index)
(length control-string)
) )) ) ) )
) ; tagbody zu Ende
) ; loop zu Ende
string-ended
(when stop-at
(format-error control-string index
#L{
DEUTSCH "Schließende Klammer '~A' fehlt."
ENGLISH "An opening directive is never closed; expecting '~A'."
FRANCAIS "Il manque la borne fermante '~A'."
}
stop-at
) )
end
(return (values index csdl))
) ) )
;-------------------------------------------------------------------------------
(defvar *FORMAT-CS*) ; control-string
(defvar *FORMAT-CSDL*) ; control-string directive list
(defvar *FORMAT-ARG-LIST*) ; argument-list
(defvar *FORMAT-NEXT-ARG*) ; pointer to next argument in argument-list
(defvar *FORMAT-NEXT-ARGLIST*) ; pointer to next sublist in ~:{ iteration
(defvar *FORMAT-UP-AND-OUT* nil) ; reason for up-and-out
; (format-error controlstring errorpos errorcode . arguments)
; signalisiert einen Error, der bei FORMAT aufgetreten ist. Die Stelle im
; Control-string wird mit einem Pfeil markiert.
(defun format-error (controlstring errorpos errorstring &rest arguments)
(when controlstring
(unless errorpos (setq errorpos (csd-cs-index (car *FORMAT-CSDL*))))
(setq errorstring
(string-concat errorstring
#L{
DEUTSCH "~%Stelle im Kontrollstring:"
ENGLISH "~%Current point in control string:"
FRANCAIS "~%Position dans la chaîne de contrôle :"
}
) )
(let ((pos1 0) (pos2 0))
(declare (simple-string errorstring) (fixnum pos1 pos2))
(loop
(setq pos2 (or (position #\Newline controlstring :start pos1)
(length controlstring)
) )
(setq errorstring (string-concat errorstring "~% ~A"))
(setq arguments
(nconc arguments (list (substring controlstring pos1 pos2)))
)
(when (<= pos1 errorpos pos2)
(setq errorstring
(string-concat errorstring "~%~VT"
#+(or DOS OS/2 WIN32-DOS) "" #-(or DOS OS/2 WIN32-DOS) "|"
) )
(setq arguments (nconc arguments (list (+ (- errorpos pos1) 2))))
)
(when (= pos2 (length controlstring)) (return))
(setq pos1 (+ pos2 1))
) ) )
(apply #'error-of-type 'error errorstring arguments)
)
;-------------------------------------------------------------------------------
(defun format (destination control-string &rest arguments)
(unless (or (stringp control-string) (functionp control-string))
(format-cs-error control-string)
)
(cond ((null destination)
(let ((stream (make-string-output-stream)))
(format-apply stream control-string arguments)
(get-output-stream-string stream)
))
((eq destination 'T)
(format-apply *standard-output* control-string arguments)
nil
)
((streamp destination)
(format-apply destination control-string arguments)
nil
)
((stringp destination)
(if (array-has-fill-pointer-p destination)
(let ((stream (sys::make-string-push-stream destination)))
(format-apply stream control-string arguments)
)
(error-of-type 'error
#L{
DEUTSCH "String zum Vollschreiben ~S hat keinen Fill-Pointer."
ENGLISH "The destination string ~S should have a fill pointer."
FRANCAIS "La chaîne destination n'a pas de pointeur de remplissage."
}
destination
) )
nil
)
(t (error-of-type 'type-error
:datum destination :expected-type '(or (member nil t) stream string)
#L{
DEUTSCH "Das ist weder NIL noch T noch ein Stream noch ein String: ~S"
ENGLISH "The destination argument ~S is invalid (not NIL or T or a stream or a string)."
FRANCAIS "L'argument de destination n'est ni NIL, ni T, ni un «stream» ni une chaîne : ~S"
}
destination
) )
) )
(defun format-apply (stream control-string arguments &optional (whole-arguments arguments))
(cond ((stringp control-string)
; evtl. noch control-string zu einem Simple-String machen ??
(let ((node (list control-string)))
(format-parse-cs control-string 0 node nil)
(let* ((*FORMAT-CS* (car node))
(*FORMAT-CSDL* (cdr node))
(*FORMAT-ARG-LIST* whole-arguments)
(*FORMAT-NEXT-ARG* arguments)
(*FORMAT-NEXT-ARGLIST* nil)
(*FORMAT-UP-AND-OUT* nil))
(format-interpret stream)
*FORMAT-NEXT-ARG*
)) )
((functionp control-string)
(let ((*FORMAT-CS* nil)) ; format-error kann nicht mehr auf die Stelle zeigen
(apply control-string stream arguments)
))
(t (format-cs-error control-string))
) )
(defun format-cs-error (control-string)
(error-of-type 'type-error
:datum control-string :expected-type '(or string function)
#L{
DEUTSCH "~S: Kontrollstring muß ein String sein, nicht ~S"
ENGLISH "~S: The control-string must be a string, not ~S"
FRANCAIS "~S : La chaîne de contrôle doit être une chaîne et non ~S"
}
'format control-string
) )
;-------------------------------------------------------------------------------
; (next-arg) liefert (und verbraucht) das nächste Argument aus der Argument-
; liste *FORMAT-NEXT-ARG*.
(defun next-arg ()
(if (atom *FORMAT-NEXT-ARG*)
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Nicht genügend Argumente für diese Direktive übrig."
ENGLISH "There are not enough arguments left for this directive."
FRANCAIS "Il ne reste pas assez d'arguments pour cette directive."
}
)
(pop *FORMAT-NEXT-ARG*)
) )
; (format-interpret stream [endmarker]) interpretiert *FORMAT-CSDL* ab.
; Fluid vars:
; *FORMAT-ARG-LIST*
; *FORMAT-NEXT-ARG*
; *FORMAT-NEXT-ARGLIST*
; *FORMAT-CS*
; *FORMAT-CSDL*
; *FORMAT-UP-AND-OUT*
; Abbruch des Interpretierens bei Antreffen der Direktive endmarker
; oder der Direktive ~; .
(defun format-interpret (stream &optional (endmarker nil))
(loop
(when *FORMAT-UP-AND-OUT* (return))
(when (endp *FORMAT-CSDL*) (return))
(let ((csd (car *FORMAT-CSDL*)))
(case (csd-type csd)
(0 )
(1 (write-string *FORMAT-CS* stream
:start (csd-cs-index csd) :end (csd-data csd)
) )
(2 (let ((directive-name (csd-data csd)))
(if (eq directive-name endmarker) (return))
(if (eq directive-name 'FORMAT-SEPARATOR) (return))
(apply directive-name
stream
(csd-colon-p csd)
(csd-atsign-p csd)
(format-resolve-parms csd)
) ) )
) )
(setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
) )
; liefert die korrekte Argumentliste einer CSD, evtl. mit eingesetzten
; Parametern: V (als :NEXT-ARG) und # (als :ARG-COUNT) werden aufgelöst.
(defun format-resolve-parms (csd)
(let ((arglist (csd-parm-list csd)))
(if (csd-v-or-#-p csd)
(mapcar #'(lambda (arg)
(case arg
(:NEXT-ARG (next-arg))
(:ARG-COUNT (list-length *FORMAT-NEXT-ARG*))
(T arg)
) )
arglist
)
arglist
) ) )
; Definiert eine einfache FORMAT-Unterfunktion, d.i. eine, die genau ein
; Argument verbraucht.
(defmacro defformat-simple (name (stream colon atsign . optionals-with-defaults)
(arg) &body body
&environment env)
(multiple-value-bind (body-rest declarations) (sys::parse-body body nil env)
(let ((name2 (concat-pnames "DO-" name)) ; in #<PACKAGE SYSTEM>
(optionals (mapcar #'(lambda (opt) (if (consp opt) (first opt) opt))
optionals-with-defaults
)) )
`(PROGN
(DEFUN ,name (,stream ,colon ,atsign &OPTIONAL ,@optionals)
(,name2 ,stream ,colon ,atsign ,@optionals (next-arg))
)
(DEFUN ,name2 (,stream ,colon ,atsign ,@optionals ,arg)
,@(if declarations `((DECLARE ,@declarations)))
,@(mapcap #'(lambda (opt)
(if (and (consp opt) (not (null (second opt))))
`((IF (NULL ,(first opt)) (SETQ ,(first opt) ,(second opt))))
'()
) )
optionals-with-defaults
)
,@body-rest
) )
) ) )
; Bewegt den Stand des "Pointers in die Argumentliste" in eine Richtung.
(defun format-goto-new-arg (backwardp index)
(if backwardp
; rückwärts
(setq *FORMAT-NEXT-ARG*
(nthcdr
(max (- (list-length *FORMAT-ARG-LIST*) (list-length *FORMAT-NEXT-ARG*) index) 0)
*FORMAT-ARG-LIST*
) )
; vorwärts ist einfacher:
(setq *FORMAT-NEXT-ARG* (nthcdr index *FORMAT-NEXT-ARG*))
) )
; gibt arg als römische Zahl auf stream aus, z.B. 4 als IIII.
(defun format-old-roman (arg stream)
(unless (and (integerp arg) (<= 1 arg 4999))
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Die ~~:@R-Direktive erwartet ein Integer zwischen 1 und 4999, nicht ~S"
ENGLISH "The ~~:@R directive requires an integer in the range 1 - 4999, not ~S"
FRANCAIS "La directive ~~:@R requiert un entier compris entre 1 et 4999 et non ~S"
}
arg
) )
(do ((charlistr '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr))
(valuelistr '(1000 500 100 50 10 5 1) (cdr valuelistr))
(value arg (multiple-value-bind (multiplicity restvalue)
(floor value (first valuelistr))
(dotimes (i multiplicity)
(write-char (first charlistr) stream)
)
restvalue
)) )
((zerop value))
) )
; gibt arg als römische Zahl auf stream aus, z.B. 4 als IV.
(defun format-new-roman (arg stream)
(unless (and (integerp arg) (<= 1 arg 3999))
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Die ~~@R-Direktive erwartet ein Integer zwischen 1 und 3999, nicht ~S"
ENGLISH "The ~~@R directive requires an integer in the range 1 - 3999, not ~S"
FRANCAIS "La directive ~~@R requiert un entier compris entre 1 et 3999 et non ~S"
}
arg
) )
(do ((charlistr '(#\M #\D #\C #\L #\X #\V #\I) (cdr charlistr))
(valuelistr '(1000 500 100 50 10 5 1 ) (cdr valuelistr))
(lowercharlistr '(#\C #\C #\X #\X #\I #\I ) (cdr lowercharlistr))
(lowervaluelistr '(100 100 10 10 1 1 0 ) (cdr lowervaluelistr))
(value arg
(multiple-value-bind (multiplicity restvalue)
(floor value (first valuelistr))
(dotimes (i multiplicity) (write-char (first charlistr) stream))
(let ((loweredvalue (- (first valuelistr) (first lowervaluelistr))))
(if (>= restvalue loweredvalue)
(progn
(write-char (first lowercharlistr) stream)
(write-char (first charlistr) stream)
(- restvalue loweredvalue)
)
restvalue
)) ) ) )
((zerop value))
) )
(defconstant FORMAT-CARDINAL-ONES
'#(NIL "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
"ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen"
"seventeen" "eighteen" "nineteen"
) )
(defconstant FORMAT-CARDINAL-TENS
'#(NIL NIL "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")
)
; (format-small-cardinal arg stream) gibt eine ganze Zahl >0, <1000 im
; Klartext auf englisch auf den stream aus. (arg=0 -> gibt nichts aus.)
(defun format-small-cardinal (arg stream)
(multiple-value-bind (hundreds tens-and-ones) (truncate arg 100)
(when (> hundreds 0)
(write-string (svref FORMAT-CARDINAL-ONES hundreds) stream)
(write-string " hundred" stream)
)
(when (> tens-and-ones 0)
(when (> hundreds 0) (write-string " and " stream))
(multiple-value-bind (tens ones) (truncate tens-and-ones 10)
(if (< tens 2)
(write-string (svref FORMAT-CARDINAL-ONES tens-and-ones) stream)
(progn
(write-string (svref FORMAT-CARDINAL-TENS tens) stream)
(when (> ones 0)
(write-char #\- stream)
(write-string (svref FORMAT-CARDINAL-ONES ones) stream)
) ) ) ) ) ) )
; (format-cardinal arg stream) gibt die ganze Zahl arg im Klartext auf englisch
; auf den Stream aus.
(defun format-cardinal (arg stream) ; arg Integer
(if (zerop arg)
(write-string "zero" stream)
(progn
(when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
(labels
((blocks1000 (illions-list arg) ; Zerlegung in 1000er-Blöcke
(when (null illions-list)
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Zu großes Argument für ~~R-Direktive."
ENGLISH "The argument for the ~~R directive is too large."
FRANCAIS "L'argument pour la directive ~~R est trop grand."
}
) )
(multiple-value-bind (thousands small) (truncate arg 1000)
(when (> thousands 0) (blocks1000 (cdr illions-list) thousands))
(when (> small 0)
(when (> thousands 0) (write-string ", " stream))
(format-small-cardinal small stream)
(write-string (car illions-list) stream)
)) ) )
(blocks1000
; amerikanisch (billion=10^9)
'("" " thousand" " million" " billion" " trillion" " quadrillion"
" quintillion" " sextillion" " septillion" " octillion" " nonillion"
" decillion" " undecillion" " duodecillion" " tredecillion"
" quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
" octodecillion" " novemdecillion" " vigintillion")
arg
) ) ) ) )
(defconstant FORMAT-ORDINAL-ONES
'#(NIL "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth"
"ninth" "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
"fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"
) )
; (format-ordinal arg stream) gibt eine ganze Zahl arg als Abzählnummer im
; Klartext auf englisch auf den stream aus.
(defun format-ordinal (arg stream) ; arg Integer
(if (zerop arg)
(write-string "zeroth" stream)
(progn
(when (minusp arg) (write-string "minus " stream) (setq arg (- arg)))
(multiple-value-bind (hundreds tens-and-ones) (floor arg 100)
(when (> hundreds 0) (format-cardinal (* hundreds 100) stream))
(if (zerop tens-and-ones)
(write-string "th" stream)
(multiple-value-bind (tens ones) (floor tens-and-ones 10)
(when (> hundreds 0) (write-char #\Space stream))
(cond ((< tens 2)
(write-string (svref FORMAT-ORDINAL-ONES tens-and-ones) stream)
)
((zerop ones)
(write-string
(svref '#(NIL "tenth" "twentieth" "thirtieth" "fortieth" "fiftieth"
"sixtieth" "seventieth" "eightieth" "ninetieth")
tens
)
stream
))
(t (write-string (svref FORMAT-CARDINAL-TENS tens) stream)
(write-char #\- stream)
(write-string (svref FORMAT-ORDINAL-ONES ones) stream)
) ) ) ) ) ) ) )
; (format-padding count char stream) gibt count (ein Fixnum >=0) Zeichen char
; auf stream aus.
(defun format-padding (count char stream)
(dotimes (i count) (write-char char stream))
)
; gibt auf den Stream stream aus:
; den String str, eventuell aufgefüllt mit Padding characters padchar.
; Und zwar so, daß die Breite mindestens mincol ist. Um das zu erreichen,
; werden mindestens minpad Zeichen eingefügt, eventuelle weitere dann in
; Blöcken à colinc Zeichen. Falls padleftflag, werden sie links eingefügt,
; sonst rechts vom String.
(defun format-padded-string
(mincol colinc minpad padchar padleftflag str stream)
(let* ((need (+ (length str) minpad)) ; so viele Zeichen mindestens
(auxpad (if (< need mincol)
(* (ceiling (- mincol need) colinc) colinc)
0
)) ) ; so viele Zeichen zusätzlich
(unless padleftflag (write-string str stream))
(format-padding (+ minpad auxpad) padchar stream)
(when padleftflag (write-string str stream))
) )
; gibt den Integer arg auf den Stream aus:
; in Zahlenbasis base, mit Vorzeichen (+ nur falls >0 und positive-sign-flag),
; bei commaflag alle drei Stellen unterbrochen durch ein Zeichen commachar.
; Das Ganze links aufgefüllt mit padchar's, so daß die Gesamtbreite mindestens
; mincol ist.
(defun format-integer (base
mincol
padchar
commachar
commainterval
commaflag
positive-sign-flag
arg
stream
)
(let* ((*print-base* base)
(*print-radix* nil)
(*print-readably* nil))
(if (and (zerop mincol) (not commaflag) (not positive-sign-flag))
(princ arg stream) ; normale Ausgabe tut's
(let* ((oldstring (princ-to-string arg))
(oldstring-length (length oldstring))
(number-of-digits
(if (minusp arg) (1- oldstring-length) oldstring-length) )
(number-of-commas
(if commaflag (floor (1- number-of-digits) commainterval) 0) )
(positive-sign (and positive-sign-flag (> arg 0)))
(newstring-length
(+ (if positive-sign 1 0) ; Vorzeichen
oldstring-length number-of-commas ; Ziffern, Kommas
) )
(newstring (make-string newstring-length)) )
; Erst Vorzeichen +:
(when positive-sign (setf (schar newstring 0) #\+))
; Dann oldstring in newstring übertragen, dabei Kommata überspringen:
(let ((oldpos oldstring-length) (newpos newstring-length))
(loop
(decf oldpos)
(when (minusp oldpos) (return))
(decf newpos)
(setf (schar newstring newpos) (schar oldstring oldpos))
(when (and (plusp number-of-commas)
(zerop (mod (- oldstring-length oldpos) commainterval))
) ; noch ein Komma einzufügen?
(decf newpos)
(setf (schar newstring newpos) commachar)
(decf number-of-commas)
) ) )
(if (zerop mincol)
(write-string newstring stream) ; schneller
(format-padded-string mincol 1 0 padchar t newstring stream)
) ) ) ) )
; was ~D bei non-Integer-Argument tut: Argument mit ~A, aber dezimal ausgeben
(defun format-ascii-decimal (arg stream)
(let ((*print-base* 10.)
(*print-radix* nil)
(*print-readably* nil))
(princ arg stream)
) )
; Unterprogramm für ~D, ~B, ~O, ~X:
(defun format-base (base stream colon-modifier atsign-modifier
mincol padchar commachar commainterval
arg)
(if (or (and (zerop mincol) (not colon-modifier) (not atsign-modifier))
(not (integerp arg))
)
(let ((*print-base* base)
(*print-radix* nil)
(*print-readably* nil))
(princ arg stream)
)
(format-integer base mincol padchar commachar commainterval
colon-modifier atsign-modifier arg stream
) ) )
; (format-scale-exponent-aux arg null eins zehn zehntel lg2)
; liefert zur Floating-Point-Zahl arg >= 0 und
; null = 0.0, eins = 1.0, zehn = 10.0, zehntel = 0.1, lg2 = log(2)/log(10)
; (erste vier in derselben Floating-Point-Precision wie arg)
; zwei Werte: mantissa und n, mit
; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
; (Bei arg=null: null und n=0.)
(defun format-scale-exponent-aux (arg null eins zehn zehntel lg2)
(multiple-value-bind (significand expon) (decode-float arg)
(declare (ignore significand))
(if (zerop arg)
(values null 0)
(let* ((expon10a (truncate (* expon lg2))) ; nicht round, um Überlauf zu vermeiden
(signif10a (/ arg (expt zehn expon10a))))
(do ((zehnpot zehn (* zehnpot zehn))
(signif10b signif10a (/ signif10a zehnpot))
(expon10b expon10a (1+ expon10b)))
((< signif10b eins)
(do ((zehnpot zehn (* zehnpot zehn))
(signif10c signif10b (* signif10b zehnpot))
(expon10c expon10b (1- expon10c)))
((>= signif10c zehntel)
(values signif10c expon10c)
) )
) )
) ) ) )
; (format-scale-exponent arg) liefert zur Floating-Point-Zahl arg >= 0
; zwei Werte: mantissa und n, mit
; ganzem n und mantissa floating-point, 0.1 <= mantissa < 1,
; arg = mantissa * 10^n (also 10^(n-1) <= arg < 10^n ).
; (Bei arg=null: 0.0 und n=0.)
(defun format-scale-exponent (arg)
(cond ((short-float-p arg)
(format-scale-exponent-aux arg 0.0s0 1.0s0 10.0s0 0.1s0 0.30103s0)
)
((single-float-p arg)
(format-scale-exponent-aux arg 0.0f0 1.0f0 10.0f0 0.1f0 0.30103s0)
)
((double-float-p arg)
(format-scale-exponent-aux arg 0.0d0 1.0d0 10.0d0 0.1d0 0.30103s0)
)
((long-float-p arg)
(format-scale-exponent-aux arg
(float 0 arg) (float 1 arg) (float 10 arg) (float 1/10 arg)
0.30102999566d0 ; lg2 wird mit 32 Bit Genauigkeit gebraucht
) ) ))
; (format-float-to-string arg width d k dmin)
; ergibt einen String zum Floating-point arg:
; er hat den Wert von (* (abs arg) (expt 10 k)), dabei mind. d Nachkommastellen
; und höchstens die Länge width (width=nil -> keine Einschränkung).
; Trotzdem wird nicht auf weniger als dmin Stellen gerundet.
(let ((digit-string
(make-array 20 :element-type 'string-char :adjustable t :fill-pointer t)
))
(defun format-float-to-string (arg width d k dmin)
(if (zerop arg)
(let ((places (max (or d 0) (or dmin 0))))
(when width ; width angegeben -> places := (min places (1- width))
(when (>= places width) (setq places (1- width)))
)
(values
(let ((str (make-string (1+ places) :initial-element #\0)))
(setf (schar str 0) #\.)
str ; ein Punkt und places Nullen
)
(1+ places) ; Stellenzahl
t ; Punkt ganz vorne
(zerop places) ; Punkt ganz hinten ?
0 ; Position des Punktes
) )
(multiple-value-bind (significand expon) (integer-decode-float arg)
; significand : Integer >0
; expon : Integer
; mantprec : Anzahl der echten Mantissenbits von significand
; (also 2^mantprec <= significand < 2^(mantprec+1))
; width : Anzahl Stellen, die die Zahl (inklusive Punkt) nicht überschreiten
; soll, oder NIL
; d : Mindestanzahl Nachkommastellen oder NIL
; k : Skalierungsfaktor (siehe CLTL S.394)
; dmin : Mindestanzahl von Dezimaltellen, die (trotz Angabe von width oder d)
; nicht gerundet werden dürfen.
; (Nur interessant, falls d <= dmin <= (precision der Zahl).)
; wandelt die Zahl significand*2^expon um in einen Dezimalstring um.
; Es ist kein Exponent dabei.
(let* ((mantprec (1- (float-digits arg)))
(numerator significand)
(denominator 1)
(abrund-einh 1) ; Abrundungseinheit:
; Abrunden um 1 in der letzten abrundbaren Stelle entspricht
; einer Erniedrigung von numerator um abrund-einh.
(aufrund-einh 1) ; Aufrundungseinheit:
; Aufrunden um 1 in der letzten aufrundbaren Stelle entspricht
; einer Erhöhung von numerator um aufrund-einh.
; Stellen: 0 = 1. Stelle vor dem Punkt, -1 = 1. Stelle nach dem Punkt.
(stelle 0) ; Stelle der als nächstes auszugebenden Ziffer
(digit-count 0) ; Zahl der bisher in digit-string ausgegebenen
; Ziffern (exklusive den Punkt)
(point-pos 0) ; Punkt-Position = Zahl führender Stellen
; = Zahl der Ziffern vor dem Punkt
(letzte-stelle nil) ; NIL oder (falls d oder width angegeben waren)
; Stelle der letzten signifikanten Ziffer
(halbzahlig nil) ; zeigt an, ob hinten genau ein 0.500000 wegfällt
digit ; die laufende Ziffer, >=0, <10
(abrunden nil) ; T falls letzte Ziffer abzurunden ist
(aufrunden nil) ; T falls letzte Ziffer aufzurunden ist
)
(setf (fill-pointer digit-string) 0) ; digit-string leeren
(cond
((> expon 0)
(setq numerator (ash significand expon))
(setq aufrund-einh (setq abrund-einh (ash 1 expon)))
)
((< expon 0)
(setq denominator (ash 1 (- expon))) ; aufrund-einh = abrund-einh = 1
) )
; Zahl = numerator/denominator
(when (= significand (ash 1 mantprec))
; Ist der Significand=2^mantprec, so ist abrund-einh zu halbieren.
; Man kann stattdessen auch alle 3 anderen Grössen verdoppeln:
(setq aufrund-einh (ash aufrund-einh 1))
(setq numerator (ash numerator 1))
(setq denominator (ash denominator 1))
)
; Defaultmäßig: Auf-/Abrunde-Einheit = eine Einheit in der letzten
; BINÄRstelle.
; Zahl = numerator/denominator
; Skalierungsfaktor k in die Zahl mit einbeziehen (vgl. CLTL S.394)
; k<0 -> Mantisse durch 10^(abs k) dividieren
; k>0 -> Mantisse mit 10^k multiplizieren
; Dabei aufrund-einh, abrund-einh im Verhältnis zu numerator beibehalten.
(when k
(if (< k 0)
(let ((skal-faktor (expt 10 (- k))))
(setq denominator (* denominator skal-faktor))
)
(let ((skal-faktor (expt 10 k)))
(setq numerator (* numerator skal-faktor))
(setq aufrund-einh (* aufrund-einh skal-faktor))
(setq abrund-einh (* abrund-einh skal-faktor))
)
) )
; auf >= 1/10 adjustieren:
; (jeweils numerator mit 10 multiplizieren, eine führende 0 mehr vorsehen)
(do ()
((>= (* numerator 10) denominator))
(setq stelle (1- stelle))
(setq numerator (* numerator 10))
(setq abrund-einh (* abrund-einh 10))
(setq aufrund-einh (* aufrund-einh 10))
)
; stelle = Stelle der letzten führenden 0
; = 1 + Stelle der 1. signifikanten Ziffer
; oder =0, falls k>=0
; Ausführung der Rundung:
(loop
; Solange das Ergebnis auch nach Aufrundung >= 1 bliebe,
; eine Vorkommastelle mehr einplanen:
(do ()
((< (+ (ash numerator 1) aufrund-einh) (ash denominator 1)))
(setq denominator (* denominator 10))
(setq stelle (1+ stelle))
)
; Falls d oder width angegeben:
; letzte-stelle ausrechnen
(if d
; Falls dmin angegeben: (min (- d) (- dmin)) = (- (max d dmin)).
; Sonst (- d).
(progn
(setq letzte-stelle (- d))
(when (and dmin (> letzte-stelle (- dmin)))
(setq letzte-stelle (- dmin))
) )
; Falls nicht d, nur width angegeben:
(when width
(if (< stelle 0)
; Es kommen führende Nullen nach dem Punkt -> d:=(1- width)
(setq letzte-stelle (- 1 width))
; Es kommen keine führenden Nullen nach dem Punkt ->
; Es wird stelle Vorkommaziffern geben, d:=(- (1- width) stelle)
(setq letzte-stelle (1+ (- stelle width)))
)
; also letzte-stelle = (- (- (1- width) (max stelle 0)))
; wieder dmin berücksichtigen:
(when (and dmin (> letzte-stelle (- dmin)))
(setq letzte-stelle (- dmin))
) ) )
(when (or d width)
(let* ((ziffernzahl (- letzte-stelle stelle))
; ziffernzahl = - Zahl signifikanter Stellen oder >=0.
(dezimal-einh denominator))
; dezimal-einh := (ceiling (* dezimal-einh (expt 10 ziffernzahl)))
(if (>= ziffernzahl 0)
(dotimes (i ziffernzahl)
(setq dezimal-einh (* dezimal-einh 10))
)
(dotimes (i (- ziffernzahl))
(setq dezimal-einh (ceiling dezimal-einh 10))
)
)
; dezimal-einh = Um wieviel numerator erhöht bzw. erniedigt werden
; müßte, damit sich die Dezimaldarstellung um genau 1 an der
; Position letzte-stelle verändert.
(setq abrund-einh (max dezimal-einh abrund-einh))
(setq aufrund-einh (max dezimal-einh aufrund-einh))
; Jetzt darf auch um eine (halbe) DEZIMAL-Einheit gerundet werden.
(when (= aufrund-einh dezimal-einh) (setq halbzahlig T))
) )
(when (< (+ (ash numerator 1) aufrund-einh) (ash denominator 1))
(return)
) )
; stelle = Position der ersten signifikanten Stelle + 1
; Führenden Punkt und nachfolgende Nullen ausgeben:
(when (< stelle 0)
(setq point-pos digit-count)
(vector-push-extend #\. digit-string)
(dotimes (i (- stelle))
(incf digit-count)
(vector-push-extend #\0 digit-string)
) )
; Ziffern der Mantisse ausgeben:
(loop
(when (zerop stelle)
(vector-push-extend #\. digit-string)
(setq point-pos digit-count)
)
(decf stelle)
(multiple-value-setq (digit numerator)
(truncate (* numerator 10) denominator)
)
(setq abrund-einh (* abrund-einh 10))
(setq aufrund-einh (* aufrund-einh 10))
(setq abrunden (< (ash numerator 1) abrund-einh))
(if halbzahlig
(setq aufrunden
(>= (ash numerator 1) (- (ash denominator 1) aufrund-einh))
)
(setq aufrunden
(> (ash numerator 1) (- (ash denominator 1) aufrund-einh))
)
)
(when (or abrunden aufrunden
(and letzte-stelle (<= stelle letzte-stelle))
)
(return)
)
(vector-push-extend (schar "0123456789" digit) digit-string)
(incf digit-count)
)
; letzte signifikante Ziffer ausgeben:
(when (or (null letzte-stelle) (>= stelle letzte-stelle))
(vector-push-extend
(schar "0123456789"
(cond
((and abrunden (not aufrunden)) digit)
((and aufrunden (not abrunden)) (1+ digit))
((<= (ash numerator 1) denominator) digit)
(t (1+ digit))
) )
digit-string
)
(incf digit-count)
)
; Nachfolgende Nullen und Punkt ausgeben
(when (>= stelle 0)
(dotimes (i stelle)
(incf digit-count)
(vector-push-extend #\0 digit-string)
)
(vector-push-extend #\. digit-string)
(setq point-pos digit-count)
)
(when d
(dotimes (i (- d (- digit-count point-pos)))
(incf digit-count)
(vector-push-extend #\0 digit-string)
) )
(values
digit-string ; Ziffern
(1+ digit-count) ; Anzahl der Ziffern
(= point-pos 0) ; Punkt ganz vorne?
(= point-pos digit-count) ; Punkt ganz hinten?
point-pos ; Position des Punktes
) ; 5 Werte
) ) ) )
)
; (format-float-for-f w d k overflowchar padchar plus-sign-flag arg stream)
; gibt die Floating-Point-Zahl arg in Festkommadarstellung auf stream aus.
(defun format-float-for-f (w d k overflowchar padchar plus-sign-flag arg stream)
(let ((width (if w (if (or plus-sign-flag (minusp arg)) (1- w) w) nil)))
; width = zur Verfügung stehende Zeichen ohne Vorzeichen
(multiple-value-bind (digits digitslength leadingpoint trailingpoint)
(format-float-to-string arg width d k nil)
(when (eql d 0) (setq trailingpoint nil)) ; d=0 -> keine Zusatz-Null hinten
(when w
(setq width (- width digitslength))
(when leadingpoint ; evtl. Zusatz-Null vorne einplanen
(if (> width 0) (setq width (1- width)) (setq leadingpoint nil))
)
(when trailingpoint ; evtl. Zusatz-Null hinten einplanen
(if (> width 0) (setq width (1- width)) (setq trailingpoint nil))
)
)
; Es bleiben noch width Zeichen übrig.
(if (and overflowchar w (minusp width))
(format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
(progn
(when (and w (> width 0)) (format-padding width padchar stream))
(if (minusp arg)
(write-char #\- stream)
(if plus-sign-flag (write-char #\+ stream))
)
(when leadingpoint (write-char #\0 stream))
(write-string digits stream)
(when trailingpoint (write-char #\0 stream))
) )
) ) )
; (format-float-for-e w d e k overflowchar padchar exponentchar plus-sign-flag
; arg stream)
; gibt die Floating-point-Zahl arg in Exponentialdarstellung auf den stream aus.
; (vgl. CLTL S.392-394)
; Aufteilung der Mantisse:
; Falls k<=0, erst 1 Null (falls von der Breite her passend), dann der Punkt,
; dann |k| Nullen, dann d-|k| signifikante Stellen;
; zusammen also d Nachkommastellen.
; Falls k>0, erst k signifikante Stellen, dann der Punkt,
; dann weitere d-k+1 signifikante Stellen;
; zusammen also d+1 signifikante Stellen. Keine Nullen vorne.
; (Der Defaultwert in FORMAT-EXPONENTIAL-FLOAT ist k=1.)
; Vor der Mantisse das Vorzeichen (ein + nur falls arg>=0 und plus-sign-flag).
; Dann der Exponent, eingeleitet durch exponentchar, dann Vorzeichen des
; Exponenten (stets + oder -), dann e Stellen für den Exponenten.
; Dann wird das Ganze mit padchars auf w Zeichen Breite aufgefüllt.
; Sollte das (auch nach evtl. Unterdrückung einer führenden Null) mehr als
; w Zeichen ergeben, so werden statt dessen w overflowchars ausgegeben, oder
; (falls overflowchar = nil) die Zahl mit so vielen Stellen wie nötig
; ausgegeben.
(defun format-float-for-e (w d e k
overflowchar padchar exponentchar plus-sign-flag arg stream)
(multiple-value-bind (mantissa oldexponent) (format-scale-exponent (abs arg))
(let* ((exponent (if (zerop arg) 0 (- oldexponent k))) ; auszugebender Exponent
(expdigits (write-to-string (abs exponent) :base 10. :radix nil :readably nil))
(expdigitsneed (if e (max (length expdigits) e) (length expdigits)))
; expdigitsneed = Anzahl der Stellen, die für die Ziffern des
; Exponenten nötig sind.
(mantd (if d (if (> k 0) (1+ (- d k)) d) nil))
; mantd = Anzahl der Mantissenstellen hinter dem Punkt
(dmin (if (minusp k) (- 1 k) nil)) ; nachher: fordere, daß
; nicht in die ersten (+ 1 (abs k)) Stellen hineingerundet wird.
(mantwidth (if w (- w 2 expdigitsneed) nil))
; mantwidth = Anzahl der für die Mantisse (inkl. Vorzeichen, Punkt)
; zur Verfügung stehenden Zeichen (oder nil)
)
(declare (simple-string expdigits) (fixnum exponent expdigitsneed))
(if (and overflowchar w e (> expdigitsneed e))
; Falls Overflowchar und w und e angegeben, Exponent mehr braucht:
(format-padding w overflowchar stream)
(progn
(if w
(if (or plus-sign-flag (minusp arg)) (setq mantwidth (1- mantwidth)))
)
; mantwidth = Anzahl der für die Mantisse (ohne Vorzeichen,
; inklusive Punkt) zur Verfügung stehenden Zeichen (oder nil)
(multiple-value-bind (mantdigits mantdigitslength
leadingpoint trailingpoint)
(format-float-to-string mantissa mantwidth mantd k dmin)
(when w
(setq mantwidth (- mantwidth mantdigitslength))
(if trailingpoint
(if (or (null mantd) (> mantd 0))
(setq mantwidth (- mantwidth 1))
(setq trailingpoint nil)
) )
(if leadingpoint
(if (> mantwidth 0)
(setq mantwidth (- mantwidth 1))
(setq leadingpoint nil)
) )
)
; Es bleiben noch mantwidth Zeichen übrig.
(if (and overflowchar w (minusp mantwidth))
(format-padding w overflowchar stream) ; Zu wenig Platz -> overflow
(progn
(when (and w (> mantwidth 0))
(format-padding mantwidth padchar stream)
)
(if (minusp arg)
(write-char #\- stream)
(if plus-sign-flag (write-char #\+ stream))
)
(if leadingpoint (write-char #\0 stream))
(write-string mantdigits stream)
(if trailingpoint (write-char #\0 stream))
(write-char
(cond (exponentchar)
((and (not *PRINT-READABLY*)
(typep arg *READ-DEFAULT-FLOAT-FORMAT*)
)
#\E
)
((short-float-p arg) #\s)
((single-float-p arg) #\f)
((double-float-p arg) #\d)
((long-float-p arg) #\L)
)
stream
)
(write-char (if (minusp exponent) #\- #\+) stream)
(when (and e (> e (length expdigits)))
(format-padding (- e (length expdigits)) #\0 stream)
)
(write-string expdigits stream)
) ) )
) ) )
) )
; Rückt *FORMAT-CSDL* vor bis zum Ende des momentanen ~[ bzw. ~{ bzw. ~< .
(defun format-skip-to-end ()
(do ()
((null (csd-clause-chain (car *FORMAT-CSDL*))))
(setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
) )
; (format-justified-segments mincol colinc minpad justify-left justify-right
; piecelist) berechnet, an welchen Stellen zwischen den einzelnen Strings in
; piecelist wieviele Leerstellen zu setzen sind.
; Zwischen die einzelnen Strings aus piecelist (auch vorher, falls justify-left;
; auch nachher, falls justify-right) werden mindestens minpad padding-characters
; eingefügt. Dann werden nochmals weitere padding-characters dazugenommen,
; damit die Gesamtbreite >= mincol wird. Ist die Breite > mincol, werden weitere
; padding-characters dazugenommen, so daß die Breite von der Form
; mincol + k * colinc wird. Diese padding-characters werden auf die einzelnen
; Stellen gleichmäßig verteilt.
; 1. Wert: Ein Vektor, der zu jeder Stelle angibt, wieviele padding-characters
; einzufügen sind (NIL = keine).
; Erstes Element: ganz links, zweites: nach 1. String, ..., letztes: rechts.
; 2. Wert: Die sich ergebende Gesamtbreite.
(defun format-justified-segments
(mincol colinc minpad justify-left justify-right piecelist)
(declare (fixnum mincol colinc minpad))
(let ((piecesnumber 0)
(pieceswidth 0))
(dolist (piece piecelist)
(declare (simple-string piece))
(incf piecesnumber)
(incf pieceswidth (length piece))
)
(let* ((new-justify-left
(or justify-left (and (= piecesnumber 1) (not justify-right))))
(padblocks (+ piecesnumber -1 ; Anzahl der Einfüge-Stellen
(if new-justify-left 1 0) (if justify-right 1 0)
) )
(width-need (+ pieceswidth (* padblocks minpad)))
(width (+ mincol
(if (<= width-need mincol)
0
(* (ceiling (- width-need mincol) colinc) colinc)
)) ) )
(declare (fixnum piecesnumber pieceswidth padblocks width-need width))
(multiple-value-bind (padwidth rest) (floor (- width pieceswidth) padblocks)
(let ((padblock-lengths
(make-array (1+ piecesnumber) :initial-element padwidth)
))
(unless new-justify-left (setf (svref padblock-lengths 0) nil))
(unless justify-right (setf (svref padblock-lengths piecesnumber) nil))
(do ((i 0 (1+ i)))
((zerop rest))
(when (svref padblock-lengths i)
(incf (svref padblock-lengths i))
(decf rest)
) )
(values padblock-lengths width)
) ) ) ) )
;-------------------------------------------------------------------------------
; ~A, CLTL S.387-388, CLtL2 S. 584
(defformat-simple format-ascii (stream colon-modifier atsign-modifier
(mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
(arg)
(when (and colon-modifier (null arg)) (setq arg "()"))
(if (and (zerop mincol) (zerop minpad))
(princ arg stream)
(format-padded-string mincol colinc minpad padchar
atsign-modifier ; =: padleftflag
(princ-to-string arg)
stream
) ) )
; ~S, CLTL S.388, CLtL2 S. 584
(defformat-simple format-s-expression (stream colon-modifier atsign-modifier
(mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
(arg)
(if (and (zerop mincol) (zerop minpad))
(if (and colon-modifier (null arg))
(write-string "()" stream)
(prin1 arg stream)
)
(format-padded-string mincol colinc minpad padchar
atsign-modifier ; =: padleftflag
(if (and colon-modifier (null arg)) "()" (prin1-to-string arg))
stream
) ) )
; ~W
(defformat-simple format-write (stream colon-modifier atsign-modifier
(mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
(arg)
(declare (ignore colon-modifier))
(if (and (zerop mincol) (zerop minpad))
(write arg :stream stream)
(format-padded-string mincol colinc minpad padchar
atsign-modifier ; =: padleftflag
(write-to-string arg)
stream
) ) )
; ~D, CLTL S.388, CLtL2 S. 585
(defformat-simple format-decimal (stream colon-modifier atsign-modifier
(mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
(arg)
(format-base 10 stream colon-modifier atsign-modifier mincol padchar commachar commainterval arg)
)
; ~B, CLTL S.388, CLtL2 S. 585
(defformat-simple format-binary (stream colon-modifier atsign-modifier
(mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
(arg)
(format-base 2 stream colon-modifier atsign-modifier mincol padchar commachar commainterval arg)
)
; ~O, CLTL S.388, CLtL2 S. 585
(defformat-simple format-octal (stream colon-modifier atsign-modifier
(mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
(arg)
(format-base 8 stream colon-modifier atsign-modifier mincol padchar commachar commainterval arg)
)
; ~X, CLTL S.388-389, CLtL2 S. 586
(defformat-simple format-hexadecimal (stream colon-modifier atsign-modifier
(mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
(arg)
(format-base 16 stream colon-modifier atsign-modifier mincol padchar commachar commainterval arg)
)
; ~R, CLTL S.389, CLtL2 S. 586-587
(defformat-simple format-radix (stream colon-modifier atsign-modifier
(radix nil) (mincol 0) (padchar #\Space) (commachar #\,) (commainterval 3))
(arg)
(if radix
(format-integer radix mincol padchar commachar commainterval
colon-modifier atsign-modifier
arg stream
)
(if atsign-modifier
(if (integerp arg)
(if colon-modifier
(format-old-roman arg stream)
(format-new-roman arg stream)
)
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Die ~~R- und ~~:R-Direktiven erwarten ein Integer als Argument, nicht ~S"
ENGLISH "The ~~R and ~~:R directives require an integer argument, not ~S"
FRANCAIS "Les directives ~~R et ~~:R nécessitent un argument de type entier et non ~S"
}
arg
) )
(if colon-modifier
(format-ordinal arg stream)
(format-cardinal arg stream)
) ) ) )
; ~P, CLTL S. 389, CLtL2 S. 587-588
(defun format-plural (stream colon-modifier atsign-modifier)
(when colon-modifier (format-goto-new-arg t 1))
(let ((singular (eql (next-arg) 1)))
(if atsign-modifier
(write-string (if singular "y" "ies") stream)
(unless singular (write-char #\s stream))
) ) )
; ~C, CLTL S.389-390, CLtL2 S. 588
(defformat-simple format-character (stream colon-modifier atsign-modifier)
(arg)
(unless (characterp arg)
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Die ~~C-Direktive erwartet ein Character, nicht ~S"
ENGLISH "The ~~C directive requires a character argument, not ~S"
FRANCAIS "La directive ~~C requiert un caractère et non ~S"
}
arg
) )
(flet ((write-charname (arg)
(let ((name (char-name arg)))
(if name
(write-string (string-capitalize name) stream)
(write-char arg stream)
)) ) )
(if (not atsign-modifier)
; ~C oder ~:C
(progn
(dolist (name '(:CONTROL :META :SUPER :HYPER))
(when (char-bit arg name)
(write-string (string-capitalize (symbol-name name)) stream
:end (if colon-modifier nil 1)
)
(write-char #\- stream)
) )
(if (not colon-modifier)
; ~C
(write-char (make-char arg 0 (char-font arg)) stream)
; ~:C
(write-charname (make-char arg))
) )
(if (not colon-modifier)
; ~@C
(prin1 arg stream)
; ~:@C -- hier NUR die Anweisung, wie's zu tippen ist.
(progn
(let ((keynames '("Shift-" "Control-" "Alternate-")))
(dolist (name '(:SUPER :CONTROL :META))
(when (char-bit arg name)
(write-string (car keynames) stream)
(setq arg (set-char-bit arg name nil))
)
(setq keynames (cdr keynames))
) )
(let* ((hyperkey-alist
#+(or DOS OS/2 UNIX AMIGA WIN32-DOS WIN32-UNIX)
'(
#-(or UNIX AMIGA WIN32-UNIX) (#\Enter . "Enter" )
#-AMIGA (#\Insert . "Insert")
#-AMIGA (#\End . "End" )
(#\Down . "Down")
#-AMIGA (#\PgDn . "PgDn" )
(#\Left . "Left")
#+UNIX (#\Center . "Center")
(#\Right . "Right")
#-AMIGA (#\Home . "Home")
(#\Up . "Up")
#-AMIGA (#\PgUp . "PgUp" )
#+AMIGA (#\Help . "Help" )
#+(or DOS OS/2) (#\Prtscr . "PrtScr")
#-(or UNIX AMIGA) (#\Delete . "Delete")
(#\F1 . "F1" )
(#\F2 . "F2" )
(#\F3 . "F3" )
(#\F4 . "F4" )
(#\F5 . "F5" )
(#\F6 . "F6" )
(#\F7 . "F7" )
(#\F8 . "F8" )
(#\F9 . "F9" )
(#\F10 . "F10" )
#-AMIGA (#\F11 . "F11" )
#-AMIGA (#\F12 . "F12" )
)
#-(or DOS OS/2 UNIX AMIGA WIN32-DOS WIN32-UNIX)
'()
)
(acons (assoc arg hyperkey-alist)))
(if acons
(write-string (cdr acons) stream)
(progn
(when (char-bit arg ':HYPER)
(write-string
#L{
DEUTSCH "Ziffernblock-"
ENGLISH "Keypad-"
FRANCAIS "bloc numérique "
}
stream
)
(setq arg (set-char-bit arg :HYPER nil))
)
(write-charname arg)
) ) ) )
) ) ) )
; ~F, CLTL S.390-392, CLtL2 S. 588-590
(defformat-simple format-fixed-float (stream colon-modifier atsign-modifier
(w nil) (d nil) (k 0) (overflowchar nil) (padchar #\Space))
(arg)
(declare (ignore colon-modifier))
(when (rationalp arg) (setq arg (float arg)))
(if (floatp arg)
(format-float-for-f w d k overflowchar padchar atsign-modifier arg stream)
(format-ascii-decimal arg stream)
) )
; ~E, CLTL S.392-395, CLtL2 S. 590-593
(defformat-simple format-exponential-float (stream colon-modifier atsign-modifier
(w nil) (d nil) (e nil) (k 1)
(overflowchar nil) (padchar #\Space) (exponentchar nil))
(arg)
(declare (ignore colon-modifier))
(when (rationalp arg) (setq arg (float arg)))
(if (floatp arg)
(format-float-for-e w d e k overflowchar padchar exponentchar
atsign-modifier arg stream
)
(format-ascii-decimal arg stream)
) )
; ~G, CLTL S.395-396, CLtL2 S. 594-595
(defformat-simple format-general-float (stream colon-modifier atsign-modifier
(w nil) (d nil) (e nil) (k 1)
(overflowchar nil) (padchar #\Space) (exponentchar nil))
(arg)
(declare (ignore colon-modifier))
(if (rationalp arg) (setq arg (float arg)))
(if (floatp arg)
(multiple-value-bind (mantissa n) (format-scale-exponent (abs arg))
(declare (ignore mantissa))
(if (null d)
(setq d
(multiple-value-bind (digits digitslength)
(format-float-to-string (abs arg) nil nil nil nil)
(declare (ignore digits))
(max (max (1- digitslength) 1) (min n 7))
) ) )
(let* ((ee (if e (+ 2 e) 4))
(dd (- d n)))
(if (<= 0 dd d)
(progn
(format-float-for-f
(if w (- w ee) nil)
dd 0
overflowchar padchar atsign-modifier arg stream
)
(format-padding ee #\Space stream)
)
(format-float-for-e w d e k overflowchar padchar exponentchar
atsign-modifier arg stream
) ) ) )
(format-ascii-decimal arg stream)
) )
; ~$, CLTL S.396-397, CLtL2 S. 595-596
(defformat-simple format-dollars-float (stream colon-modifier atsign-modifier
(d 2) (n 1) (w 0) (padchar #\Space))
(arg)
(when (rationalp arg) (setq arg (float arg)))
(if (floatp arg)
(multiple-value-bind (digits digitslength
leadingpoint trailingpoint leadings)
(format-float-to-string arg nil d 0 nil)
(declare (ignore digitslength leadingpoint trailingpoint))
(let* ((lefts (max leadings n))
(totalwidth (+ (if (or atsign-modifier (minusp arg)) 1 0)
lefts 1 d
) )
(padcount (max (- w totalwidth) 0)))
(if (not colon-modifier) (format-padding padcount padchar stream))
(if (minusp arg)
(write-char #\- stream)
(if atsign-modifier (write-char #\+ stream))
)
(if colon-modifier (format-padding padcount padchar stream))
(format-padding (- lefts leadings) #\0 stream)
(write-string digits stream)
) )
(format-ascii-decimal arg stream)
) )
; ~%, CLTL S.397, CLtL2 S. 596
(defun format-terpri (stream colon-modifier atsign-modifier &optional (count 1))
(declare (ignore colon-modifier atsign-modifier))
(if (null count) (setq count 1))
(dotimes (i count) (terpri stream))
)
; ~&, CLTL S.397, CLtL2 S. 596
(defun format-fresh-line (stream colon-modifier atsign-modifier
&optional (count 1))
(declare (ignore colon-modifier atsign-modifier))
(if (null count) (setq count 1))
(when (plusp count)
(fresh-line stream)
(dotimes (i (1- count)) (terpri stream))
) )
; ~|, CLTL S.397, CLtL2 S. 596
(defun format-page (stream colon-modifier atsign-modifier &optional (count 1))
(declare (ignore colon-modifier atsign-modifier))
(if (null count) (setq count 1))
(dotimes (i count) (write-char #\Page stream))
)
; ~~, CLTL S.397, CLtL2 S. 596
(defun format-tilde (stream colon-modifier atsign-modifier &optional (count 1))
(declare (ignore colon-modifier atsign-modifier))
(if (null count) (setq count 1))
(dotimes (i count) (write-char #\~ stream))
)
; ~T, CLTL S.398-399, CLtL2 S. 597-598
(defun format-tabulate (stream colon-modifier atsign-modifier
&optional (colnum 1) (colinc 1))
(declare (ignore colon-modifier))
(if (null colnum) (setq colnum 1))
(if (null colinc) (setq colinc 1))
(let* ((new-colnum (max colnum 0))
(new-colinc (max colinc 1)) ; >0
(pos (sys::line-position stream))) ; aktuelle Position, Fixnum >=0
(if atsign-modifier
(format-padding
(+ new-colnum (mod (- (+ pos new-colnum)) new-colinc))
#\Space stream
)
(if (< pos new-colnum)
(format-padding (- new-colnum pos) #\Space stream)
(unless (zerop colinc)
(format-padding (+ colinc (mod (- new-colnum pos) (- colinc)))
#\Space stream
) ) ) ) ) )
; ~*, CLTL S.399, CLtL2 S. 598
(defun format-goto (stream colon-modifier atsign-modifier &optional (index nil))
(declare (ignore stream))
(if atsign-modifier
(setq *FORMAT-NEXT-ARG* (nthcdr (or index 0) *FORMAT-ARG-LIST*))
(format-goto-new-arg colon-modifier (or index 1))
) )
; ~?, CLTL S.399-401, CLtL2 S. 598-599
(defun format-indirection (stream colon-modifier atsign-modifier)
(declare (ignore colon-modifier))
(let* ((csarg (next-arg))
(node (do-format-indirection-1 csarg)))
(if atsign-modifier
(if (consp node)
(let ((*FORMAT-CS* (car node))
(*FORMAT-CSDL* (cdr node))
;(*FORMAT-ARG-LIST* *FORMAT-NEXT-ARG*) ; ??
(*FORMAT-UP-AND-OUT* nil))
(format-interpret stream)
)
(setq *FORMAT-NEXT-ARG*
(let ((*FORMAT-CS* nil))
(apply node stream *FORMAT-NEXT-ARG*)
) ) )
(let ((arglistarg (next-arg)))
(do-format-indirection-2 stream node arglistarg arglistarg)
) ) ) )
(defun do-format-indirection (stream csarg arguments)
(unless (or (stringp csarg) (functionp csarg))
(format-indirection-cserror csarg)
)
(unless (listp arguments) (format-indirection-lerror arguments))
(format-apply stream csarg arguments)
)
(defun do-format-indirection-1 (csarg)
(cond ((stringp csarg)
(let ((node (list csarg)))
(format-parse-cs csarg 0 node nil)
node
))
((functionp csarg)
csarg
)
(t (format-indirection-cserror csarg))
) )
(defun do-format-indirection-2 (stream node arglistarg wholelistarg)
(unless (listp arglistarg) (format-indirection-lerror arglistarg))
(if (consp node)
(let* ((*FORMAT-CS* (car node))
(*FORMAT-CSDL* (cdr node))
(*FORMAT-ARG-LIST* wholelistarg)
(*FORMAT-NEXT-ARG* arglistarg)
(*FORMAT-NEXT-ARGLIST* nil)
(*FORMAT-UP-AND-OUT* nil))
(format-interpret stream)
*FORMAT-NEXT-ARG*
)
(let ((*FORMAT-CS* nil))
(apply node stream arglistarg) ; wholelistarg??
) ) )
(defun format-indirection-cserror (csarg)
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Als Kontrollstring für ~~? ist das untauglich: ~S"
ENGLISH "The control string argument for the ~~? directive is invalid: ~S"
FRANCAIS "~S ne convient pas comme chaîne de contrôle pour ~~?."
}
csarg
) )
(defun format-indirection-lerror (arguments)
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Das ist keine passende Argumentliste für die ~~?-Direktive: ~S"
ENGLISH "The argument list argument for the ~~? directive is invalid: ~S"
FRANCAIS "Ceci n'est pas une liste d'arguments convenable pour la directive ~~? : ~S"
}
arguments
) )
; ~(, CLTL S.401, CLtL2 S. 600-601
(defun format-case-conversion (stream colon-modifier atsign-modifier)
(setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
(let ((tempstr
(let ((tempstream (make-string-output-stream (sys::line-position stream))))
(format-interpret tempstream 'FORMAT-CASE-CONVERSION-END)
; Was bewirkt UP-AND-OUT in ~{...~(...~^...~)...~} ??
(get-output-stream-string tempstream)
)) )
(if colon-modifier
(if atsign-modifier
(write-string (nstring-upcase tempstr) stream)
(write-string (nstring-capitalize tempstr) stream)
)
(if atsign-modifier
(write-string (nstring-capitalize1 tempstr) stream)
(write-string (nstring-downcase tempstr) stream)
) ) ) )
(defun nstring-capitalize1 (string)
(setq string (nstring-downcase string))
(dotimes (i (length string)) ; erstes Zeichen zum Upcase machen
(when (both-case-p (schar string i))
(setf (schar string i) (char-upcase (schar string i)))
(return)
) )
string
)
; ~[, CLTL S.402-403, CLtL2 S. 601-602
(defun format-conditional (stream colon-modifier atsign-modifier
&optional (prefix nil))
(if colon-modifier
(if atsign-modifier
(format-conditional-error)
(progn
(when (next-arg)
(setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
)
(setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
(format-interpret stream 'FORMAT-CONDITIONAL-END)
)
)
(if atsign-modifier
(when (next-arg)
(format-goto-new-arg t 1)
(setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
(format-interpret stream 'FORMAT-CONDITIONAL-END)
(unless (null (csd-clause-chain (car *FORMAT-CSDL*)))
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Hier ist keine ~~;-Direktive möglich."
ENGLISH "The ~~; directive is not allowed at this point."
FRANCAIS "La directive ~~; n'est pas permise ici."
}
) ) )
(let ((index (or prefix (next-arg))))
(unless (integerp index)
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Argument für ~~[ muß ein Integer sein, nicht ~S"
ENGLISH "The ~~[ parameter must be an integer, not ~S"
FRANCAIS "L'argument pour ~~[ doit être un entier et non ~S"
}
index
) )
(dotimes (i (if (minusp index) most-positive-fixnum index))
(when (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
(return)
)
(setq *FORMAT-CSDL* (csd-clause-chain (car *FORMAT-CSDL*)))
(when (csd-colon-p (car *FORMAT-CSDL*)) (return))
)
(unless (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-CONDITIONAL-END)
(setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
)
(format-interpret stream 'FORMAT-CONDITIONAL-END)
) ) )
(format-skip-to-end) ; Weiterrücken bis ans Ende der ~[...~]-Direktive
)
(defun format-conditional-error ()
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "~~[ geht nicht mit : und @ gleichzeitig."
ENGLISH "The ~~[ directive cannot take both modifiers."
FRANCAIS "La directive ~~[ ne peut pas accepter les deux qualificateurs : et @ en même temps."
}
) )
; ~{, CLTL S.403-404, CLtL2 S. 602-604
(defun format-iteration (stream colon-modifier atsign-modifier
&optional (prefix nil))
(let* ((total-csdl *FORMAT-CSDL*)
(max-iteration-count prefix))
(format-skip-to-end) ; Weiterrücken bis ans Ende der ~{...~}-Direktive
(let* ((min-1-iteration (csd-colon-p (car *FORMAT-CSDL*)))
(inner-cs (if (eq (cdr total-csdl) *FORMAT-CSDL*)
(next-arg)
*FORMAT-CS*
) )
(inner-csdl (if (stringp inner-cs)
(if (eq (cdr total-csdl) *FORMAT-CSDL*)
(let ((node (list inner-cs)))
(format-parse-cs inner-cs 0 node nil)
(cdr node)
)
(cdr total-csdl)
) ) )
(arg-list-rest (if (not atsign-modifier)
(let ((arg (next-arg)))
(unless (listp arg)
(format-error *FORMAT-CS* nil
#L{
DEUTSCH "Das Argument zu ~~{ muß eine Liste sein, nicht ~S"
ENGLISH "The ~~{ directive requires a list argument, not ~S"
FRANCAIS "L'argument de ~~{ doit être une liste et non ~S"
}
arg
) )
arg
)) ) )
(do* ((iteration-count 0 (1+ iteration-count)))
((or (and max-iteration-count
(>= iteration-count max-iteration-count)
)
(let ((remaining (if atsign-modifier
*FORMAT-NEXT-ARG*
arg-list-rest
)) )
(if min-1-iteration
(and (plusp iteration-count) (null remaining))
(null remaining)
)) ) )
(if (stringp inner-cs)
(if colon-modifier
(let* ((*FORMAT-ARG-LIST*
(if atsign-modifier (next-arg) (pop arg-list-rest))
)
(*FORMAT-NEXT-ARGLIST* ; für ~:^
(if atsign-modifier *FORMAT-NEXT-ARG* arg-list-rest)
)
(*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
(*FORMAT-CS* inner-cs)
(*FORMAT-CSDL* inner-csdl)
(*FORMAT-UP-AND-OUT* nil))
(format-interpret stream 'FORMAT-ITERATION-END)
(when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
)
(if atsign-modifier
(let* (; CLtL2 S. 598: "When within a ~{ construct, the "goto" is
; relative to the list of arguments being processed by the
; iteration." Soll das heißen, daß man bei ~@{ zu Beginn
; jeder Iteration *FORMAT-ARG-LIST* neu binden muß ??
; (*FORMAT-ARG-LIST* *FORMAT-NEXT-ARG*) ??
(*FORMAT-CS* inner-cs)
(*FORMAT-CSDL* inner-csdl)
(*FORMAT-UP-AND-OUT* nil))
(format-interpret stream 'FORMAT-ITERATION-END)
(when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
)
(let* ((*FORMAT-ARG-LIST* arg-list-rest)
(*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
(*FORMAT-CS* inner-cs)
(*FORMAT-CSDL* inner-csdl)
(*FORMAT-UP-AND-OUT* nil))
(format-interpret stream 'FORMAT-ITERATION-END)
(setq arg-list-rest *FORMAT-NEXT-ARG*)
(when (eq *FORMAT-UP-AND-OUT* ':TERMINATE-ALL) (return))
) ) )
; inner-cs may be a function in the ~{~} case
(if (functionp inner-cs)
(if colon-modifier
(let* ((arglist (if atsign-modifier (next-arg) (pop arg-list-rest)))
(*FORMAT-CS* nil))
(apply inner-cs stream arglist)
)
(if atsign-modifier
(setq *FORMAT-NEXT-ARG*
(let ((*FORMAT-CS* nil))
(apply inner-cs stream *FORMAT-NEXT-ARG*)
) )
(setq arg-list-rest
(let ((*FORMAT-CS* nil))
(apply inner-cs stream arg-list-rest)
) ) ) )
(format-indirection-cserror inner-cs)
) ) ) ) ) )
; ~<, CLTL S.404-406, CLtL2 S. 604-605
(defun format-justification (stream colon-modifier atsign-modifier
&optional (mincol 0) (colinc 1) (minpad 0) (padchar #\Space))
(let* ((saved-csdl *FORMAT-CSDL*)
(pos (sys::line-position stream))
(tempstream (make-string-output-stream pos))
(check-on-line-overflow nil)
supplementary-need
line-length
(old-piecelist
(let ((pieces nil))
(do ((first-piece-flag t nil))
((eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-JUSTIFICATION-END))
(setq *FORMAT-CSDL* (cdr *FORMAT-CSDL*))
(let ((*FORMAT-UP-AND-OUT* nil))
(format-interpret tempstream 'FORMAT-JUSTIFICATION-END)
(when (and first-piece-flag (eq (csd-data (car *FORMAT-CSDL*)) 'FORMAT-SEPARATOR))
(when (setq check-on-line-overflow (csd-colon-p (car *FORMAT-CSDL*)))
(multiple-value-setq (supplementary-need line-length)
(values-list (format-resolve-parms (car *FORMAT-CSDL*)))
) ) )
(when *FORMAT-UP-AND-OUT*
(setq *FORMAT-CSDL* saved-csdl)
(format-skip-to-end)
(return)
)
(push (get-output-stream-string tempstream) pieces)
) )
(nreverse pieces)
)) )
(do-format-justification stream colon-modifier atsign-modifier
mincol colinc minpad padchar
pos check-on-line-overflow
(if check-on-line-overflow (car old-piecelist))
supplementary-need line-length
(if check-on-line-overflow (cdr old-piecelist) old-piecelist)
) ) )
(defun do-format-justification (stream colon-modifier atsign-modifier
mincol colinc minpad padchar
pos check-on-line-overflow firstpiece
supplementary-need line-length piecelist)
(if (null mincol) (setq mincol 0))
(if (null colinc) (setq colinc 1))
(if (null minpad) (setq minpad 0))
(if (null padchar) (setq padchar #\Space))
(if piecelist
(multiple-value-bind (padblocklengths width)
(format-justified-segments mincol colinc minpad
colon-modifier atsign-modifier piecelist)
(when (and check-on-line-overflow
(> (+ pos width (or supplementary-need 0))
(or line-length #|(sys::line-length stream)|# 72)
) )
(write-string firstpiece stream)
)
(do ((i 0 (1+ i)))
(nil)
(when (svref padblocklengths i)
(format-padding (svref padblocklengths i) padchar stream)
)
(when (null piecelist) (return))
(write-string (pop piecelist) stream)
) )
(format-padding mincol padchar stream)
) )
; ~^, CLTL S.406-407, CLtL2 S. 605-606
(defun format-up-and-out (stream colon-modifier atsign-modifier
&optional (a nil) (b nil) (c nil))
(declare (ignore stream atsign-modifier))
(if (up-and-out-p a b c
(if colon-modifier *FORMAT-NEXT-ARGLIST* *FORMAT-NEXT-ARG*)
)
(setq *FORMAT-UP-AND-OUT* (if colon-modifier ':TERMINATE-ALL ':TERMINATE))
) )
(defun up-and-out-p (a b c &optional args)
(cond ((and (null a) (null b) (null c)) ; keine Parameter
(null args)
)
((and (null b) (null c)) (eql a 0)) ; ein Parameter
((null c) (eql a b)) ; zwei Parameter
((and (integerp a) (integerp b) (integerp c)) (<= a b c))
((and (characterp a) (characterp b) (characterp c)) (char<= a b c))
) )
;-------------------------------------------------------------------------------
;; FORMATTER - Compilation von FORMAT-Strings.
; Fall-back function if control-string cannot be compiled.
(defun formatter-hairy (control-string)
; control-string is known to be a string
#'(lambda (stream &rest args)
(let ((node (list control-string)))
(format-parse-cs control-string 0 node nil)
(let* ((*FORMAT-CS* (car node))
(*FORMAT-CSDL* (cdr node))
(*FORMAT-ARG-LIST* args)
(*FORMAT-NEXT-ARG* *FORMAT-ARG-LIST*)
(*FORMAT-NEXT-ARGLIST* nil)
(*FORMAT-UP-AND-OUT* nil))
(format-interpret stream)
*FORMAT-NEXT-ARG*
) ) )
)
; Block für ~^
(defvar *format-terminate*)
; Block für ~:^
(defvar *format-terminate-all*)
; Der Block wird nur bei Bedarf bereitgestellt.
; Um unnötige UNWIND-PROTECTs zu vermeiden, wird eine Liste der anhängigen
; UNWIND-PROTECTs geführt. Jeder Blockname (ein Gensym) enthält einen Verweis
; auf diese Liste zum Zeitpunkt seiner Bildung.
; Liste der anhängigen UNWIND-PROTECTs
(defvar *format-uwps*)
(defun formatter-block (prefix)
(let ((sym (gensym prefix)))
(setf (get sym 'uwps) *format-uwps*)
sym
) )
(flet ((mark-used (blockname)
; Markiere den Block, so daß er nicht wegoptimiert wird.
(setf (get blockname 'used) t)
; Markiere alle übersprungenen UNWIND-PROTECTs, so daß sie nicht
; wegoptimiert werden.
(do ((L1 *format-uwps* (cdr L1))
(L2 (get blockname 'uwps)))
((eq L1 L2))
(setf (car L1) 'T)
)
blockname
))
(defun formatter-terminate ()
(mark-used *format-terminate*)
)
(defun formatter-terminate-all ()
(mark-used *format-terminate-all*)
)
)
(defmacro formatter-bind-terminator (&body body)
`(let ((*format-terminate* (formatter-block "TERMINATE-")))
(formatter-bind-terminator-1 (progn ,@body))
)
)
(defun formatter-bind-terminator-1 (forms)
(when (get *format-terminate* 'used)
(setq forms `((BLOCK ,*format-terminate* ,@forms)))
)
forms
)
(defmacro formatter-bind-terminators (&body body)
`(let ((*format-terminate* (formatter-block "TERMINATE-"))
(*format-terminate-all* (formatter-block "TERMINATE-ALL-")))
(formatter-bind-terminators-1 (progn ,@body))
)
)
(defun formatter-bind-terminators-1 (forms)
(when (get *format-terminate* 'used)
(setq forms `((BLOCK ,*format-terminate* ,@forms)))
)
(when (get *format-terminate-all* 'used)
(setq forms `((BLOCK ,*format-terminate-all* ,@forms)))
)
forms
)
; Flag, ob innerhalb von ~(...~)
(defvar *format-case*)
; Wegen ~:^ kann die Argumentliste nicht immer denselben Namen ARGS haben.
; Ihr Name.
(defvar *args*)
; Name der Argumentliste der umschließenden ~:{ Iteration.
(defvar *iterargs*)
; Zugriff auf die normale Argumentliste:
; Normalfall:
; Argumentliste &REST ARGS,
; Zugriff auf das nächste Element ist (POP ARGS),
; ~# ist (LENGTH ARGS),
; Gesamtliste für ~:* ist WHOLE-ARGS.
; Optimiert, falls kein (LENGTH ARGS) und kein WHOLE-ARGS nötig ist:
; Argumentliste #:ARG1 #:ARG2 ... &REST ARGS
; Zugriff auf das nächste Element ist #:ARGi oder (POP ARGS).
; Flag, das anzeigt, ob man sich noch in der linearen Abarbeitungsphase der
; Argumente befindet (jedes genau einmal, bekannte Position).
(defvar *formatter-linear-args*)
; Anzahl der Argumente, die bisher zur linearen Abarbeitungsphase gehören.
; Wichtig: Diese kann hinterher erniedrigt werden!!
(defvar *formatter-linear-argcount*)
; Position in der Argumentliste während der linearen Abarbeitungsphase.
; Stets <= *formatter-linear-argcount*.
(defvar *formatter-linear-position*)
; Flag, ob WHOLE-ARGS gebunden werden soll.
(defvar *formatter-whole-args*)
; Beginnt eine Iteration, die ARGS und evtl. WHOLE-ARGS bindet.
(defmacro formatter-bind-args (&body body)
`(let ((*args* (gensym "ARGS"))
(*formatter-linear-args* t)
(*formatter-linear-argcount* 0)
(*formatter-linear-position* 0)
(*formatter-whole-args* nil))
(formatter-bind-args-1 (progn ,@body))
)
)
(defun formatter-bind-args-1 (forms)
(when *formatter-whole-args*
(subst-if-then #'(lambda (x) ; x = `(WHOLE-ARGS ,i)
(setq *formatter-linear-argcount*
(min *formatter-linear-argcount* (second x))
) )
#'(lambda (x) ; x = `(WHOLE-ARGS ,i) ?
(and (consp x) (eq (car x) 'WHOLE-ARGS)
(consp (cdr x)) (numberp (cadr x)) (null (cddr x))
) )
forms
) )
(let ((argsyms nil))
(dotimes (i *formatter-linear-argcount*) (push (gensym "ARG") argsyms))
(setq argsyms (nreverse argsyms))
(setq forms
(subst-if-then #'(lambda (x) ; x = `(ARG ,i)
(if (< (second x) *formatter-linear-argcount*)
(nth (second x) argsyms)
`(POP ,*args*)
) )
#'(lambda (x) ; x = `(ARG ,i) ?
(and (consp x) (eq (car x) 'ARG) (consp (cdr x)) (null (cddr x)))
)
forms
) )
(setq forms
(subst-if-then #'(lambda (x) ; x = `(SETQ-ARGS-WHOLE-ARGS ,old-pos ,new-pos)
(let ((old-pos (second x)) (new-pos (third x)))
(if (<= old-pos *formatter-linear-argcount*)
; no need for WHOLE-ARGS since ARGS = WHOLE-ARGS at this point
(if (<= new-pos *formatter-linear-argcount*)
`(PROGN)
`(SETQ ,*args* (NTHCDR ,(- new-pos *formatter-linear-argcount*) ,*args*))
)
(progn
(setq *formatter-whole-args* t)
`(SETQ ,*args* (WHOLE-ARGS ,(max new-pos *formatter-linear-argcount*)))
) ) ) )
#'(lambda (x) ; x = `(SETQ-ARGS-WHOLE-ARGS ,i ,j) ?
(and (consp x) (eq (car x) 'SETQ-ARGS-WHOLE-ARGS)
(consp (cdr x)) (consp (cddr x)) (null (cdddr x)))
)
forms
) )
(when *formatter-whole-args*
(setq forms
(subst-if-then #'(lambda (x) ; x = `(WHOLE-ARGS ,i)
(let ((i (- (second x) *formatter-linear-argcount*)))
(if (zerop i)
`WHOLE-ARGS
`(NTHCDR ,i WHOLE-ARGS)
) ) )
#'(lambda (x) ; x = `(WHOLE-ARGS ,i) ?
(and (consp x) (eq (car x) 'WHOLE-ARGS)
(consp (cdr x)) (numberp (cadr x)) (null (cddr x))
) )
forms
) )
(setq forms `((LET ((WHOLE-ARGS ,*args*)) ,@forms)))
)
(values `(,@argsyms &REST ,*args*)
`((DECLARE (IGNORABLE ,@argsyms ,*args*)) ,@forms)
) ) )
; Beendet den linearen Modus. Ab jetzt kann auf die Argumentliste
; als ARGS zugegriffen werden.
(defun formatter-stop-linear ()
(when *formatter-linear-args*
(setq *formatter-linear-argcount*
(min *formatter-linear-argcount* *formatter-linear-position*)
)
; Jetzt ist *formatter-linear-argcount* = *formatter-linear-position*.
(setq *formatter-linear-args* nil)
) )
; Holt eine Form, die die Länge der Argumentliste liefert.
(defun formatter-length-args ()
(formatter-stop-linear)
`(LENGTH ,*args*)
)
; Holt eine Form für das nächste Argument.
; Diese Form muß nachher mit SUBST ersetzt werden.
(defun formatter-next-arg ()
(if *formatter-linear-args*
(prog1
`(ARG ,*formatter-linear-position*)
(incf *formatter-linear-position*)
(setq *formatter-linear-argcount*
(max *formatter-linear-argcount* *formatter-linear-position*)
) )
`(POP ,*args*)
) )
; Holt eine Form, die ein nthcdr der ganzen Argumentliste liefert.
; Diese Form muß nachher mit SUBST ersetzt werden.
(defun formatter-whole-args (n)
(formatter-stop-linear)
(setq *formatter-whole-args* t)
`(WHOLE-ARGS ,n)
)
; Holt eine Formenliste zum Überspringen (vor/zurück) von Argumenten.
(defun formatter-goto-arg (absolute-p backward-p n)
(if absolute-p
; im einfachsten Fall: (setq args (nthcdr n whole-args))
(if (numberp n)
(progn
(setq n (max n 0))
(if *formatter-linear-args*
(if (< n *formatter-linear-position*)
(prog1
`((SETQ-ARGS-WHOLE-ARGS ,*formatter-linear-position* ,n))
(setq *formatter-linear-position* n)
)
; n >= *formatter-linear-position*
(formatter-goto-arg nil nil (- n *formatter-linear-position*))
)
(progn
(formatter-stop-linear)
`((SETQ ,*args* ,(formatter-whole-args n)))
) ) )
(progn
(formatter-stop-linear)
`((SETQ ,*args* (NTHCDR ,n ,(formatter-whole-args 0))))
) )
(if backward-p
; im einfachsten Fall:
; (setq args (nthcdr (max (- (length whole-args) (length args) n) 0) whole-args))
(if (and (numberp n) *formatter-linear-args*)
(formatter-goto-arg t nil (- *formatter-linear-position* n))
(progn
(formatter-stop-linear)
`((SETQ ,*args* ,(if *formatter-linear-args*
`(NTHCDR (MAX (- ,*formatter-linear-position* ,n) 0) ,(formatter-whole-args 0))
`(LIST-BACKWARD ,n ; n zuerst auswerten, da es (POP ARGS) enthalten kann
,(formatter-whole-args 0) ,*args*
)
)
))
) )
; im einfachsten Fall: (setq args (nthcdr n args))
(if (and (numberp n) (<= n 100) *formatter-linear-args*)
(do ((l '() (cons (formatter-next-arg) l)) (i 0 (1+ i)))
((>= i n) (nreverse l))
)
(progn
(formatter-stop-linear)
`((SETQ ,*args* (NTHCDR ,n ,*args*)))
) )
) ) )
(defun list-backward (n whole-list list)
(nthcdr (max (- (length whole-list) (length list) n) 0) whole-list)
)
; Holt eine Form, der ein Direktiven-Argument liefert.
(defun formatter-arg (arg)
(case arg
(:NEXT-ARG (formatter-next-arg))
(:ARG-COUNT (formatter-length-args))
(T ; arg ist NIL oder Integer oder Character, braucht nicht quotiert zu werden.
arg
) ) )
; Haupt-Compilier-Funktion. Liefert eine Formenliste.
; Fluid übergeben: *format-cs* und *format-csdl* (wird weitergerückt).
(defun formatter-main-1 (&optional (endmarker nil))
(let ((forms '()))
(loop
(when (endp *format-csdl*) (return))
(let ((csd (car *format-csdl*)))
(case (csd-type csd)
(0 )
(1 (push (subseq *format-cs* (csd-cs-index csd) (csd-data csd))
forms
) )
(2 (let ((directive-name (csd-data csd)))
(if (eq directive-name endmarker) (return))
(if (eq directive-name 'FORMAT-SEPARATOR) (return))
(let ((colon-p (csd-colon-p csd))
(atsign-p (csd-atsign-p csd))
(arglist (mapcar #'formatter-arg (csd-parm-list csd)))
)
(labels ((simple-arglist (n)
(unless (<= (length arglist) n)
(format-error *format-cs* nil
#L{
DEUTSCH "Zu viele Argumente für diese Direktive."
ENGLISH "Too many arguments for this directive"
FRANCAIS "Trop d'arguments pour cette directive."
}
) )
(setq arglist
(append arglist
(make-list (- n (length arglist))
:initial-element 'NIL
) ) ) )
(trivial-call ()
(push `(,directive-name
STREAM
,colon-p
,atsign-p
,@arglist
)
forms
) )
(trivial (n)
(simple-arglist n)
(trivial-call)
)
(simple-call ()
(push `(,(intern (string-concat "DO-" (string directive-name))
(find-package "SYSTEM")
)
STREAM
,colon-p
,atsign-p
,@arglist
; Pass the actual argument last because
; ,@arglist may contain `(POP ,*args*) as well.
,(formatter-next-arg)
)
forms
) )
(simple (n)
(simple-arglist n)
(simple-call)
))
(case directive-name
(FORMAT-ASCII ; #\A
(simple-arglist 4)
(if (and (member (first arglist) '(nil 0)) ; mincol
(member (third arglist) '(nil 0)) ; minpad
)
(progn
(setq forms (revappend (remove 'NIL arglist) forms))
(push `(PRINC ,(if colon-p
`(OR ,(formatter-next-arg) "()")
(formatter-next-arg)
)
STREAM
)
forms
) )
(simple-call)
) )
(FORMAT-S-EXPRESSION ; #\S
(simple-arglist 4)
(if (and (member (first arglist) '(nil 0)) ; mincol
(member (third arglist) '(nil 0)) ; minpad
(not colon-p)
)
(progn
(setq forms (revappend (remove 'NIL arglist) forms))
(push `(PRIN1 ,(formatter-next-arg) STREAM) forms)
)
(simple-call)
) )
(FORMAT-WRITE ; #\W
(simple-arglist 4)
(if (and (member (first arglist) '(nil 0)) ; mincol
(member (third arglist) '(nil 0)) ; minpad
)
(progn
(setq forms (revappend (remove 'NIL arglist) forms))
(push `(WRITE ,(formatter-next-arg) :STREAM STREAM) forms)
)
(simple-call)
) )
(FORMAT-DECIMAL ; #\D
(simple 4) )
(FORMAT-BINARY ; #\B
(simple 4) )
(FORMAT-OCTAL ; #\O
(simple 4) )
(FORMAT-HEXADECIMAL ; #\X
(simple 4) )
(FORMAT-RADIX ; #\R
(simple-arglist 5)
(if (and (null (first arglist)) (not atsign-p))
(progn
(setq forms (revappend (remove 'NIL arglist) forms))
(push `(,(if colon-p 'FORMAT-ORDINAL 'FORMAT-CARDINAL)
,(formatter-next-arg) STREAM
)
forms
) )
(simple-call)
) )
(FORMAT-PLURAL ; #\P
(simple-arglist 0)
(when colon-p
(setq forms (revappend (formatter-goto-arg nil t 1) forms))
)
(push (if atsign-p
`(WRITE-STRING
(IF (EQL ,(formatter-next-arg) 1) "y" "ies")
STREAM
)
`(UNLESS (EQL ,(formatter-next-arg) 1)
(WRITE-CHAR #\s STREAM)
)
)
forms
) )
(FORMAT-CHARACTER ; #\C
(simple 0) )
(FORMAT-FIXED-FLOAT ; #\F
(simple 5) )
(FORMAT-EXPONENTIAL-FLOAT ; #\E
(simple 7) )
(FORMAT-GENERAL-FLOAT ; #\G
(simple 7) )
(FORMAT-DOLLARS-FLOAT ; #\$
(simple 4) )
(FORMAT-TERPRI ; #\%
(simple-arglist 1)
(if (member (first arglist) '(nil 1))
(push #\Newline forms) ; equiv. to `(TERPRI STREAM)
(trivial-call)
) )
(FORMAT-FRESH-LINE ; #\&
(simple-arglist 1)
(if (member (first arglist) '(nil 1))
(push `(FRESH-LINE STREAM) forms)
(trivial-call)
) )
(FORMAT-PAGE ; #\|
(simple-arglist 1)
(if (member (first arglist) '(nil 1))
(push #\Page forms)
(trivial-call)
) )
(FORMAT-TILDE ; #\~
(simple-arglist 1)
(if (member (first arglist) '(nil 1))
(push #\~ forms)
(trivial-call)
) )
(FORMAT-TABULATE ; #\T
(trivial 2) )
(FORMAT-GOTO ; #\*
(simple-arglist 1)
(setq forms
(revappend
(formatter-goto-arg atsign-p colon-p
(or (first arglist) (if atsign-p 0 1))
)
forms
) ) )
(FORMAT-INDIRECTION ; #\?
(simple-arglist 0)
(if atsign-p
(push `(SETQ ,*args*
(DO-FORMAT-INDIRECTION STREAM
,(formatter-next-arg)
,(progn (formatter-stop-linear) `,*args*)
) )
forms
)
(push `(DO-FORMAT-INDIRECTION STREAM ,(formatter-next-arg) ,(formatter-next-arg))
forms
) ) )
(FORMAT-CASE-CONVERSION ; #\(
(simple-arglist 0)
(setq *format-csdl* (cdr *format-csdl*))
(if *format-case*
; Richard Waters notes: It is possible for ~(...~) to
; be nested in a format string, but note that inner
; nested modes never have any effect. You can just
; ignore them.
(let ((inner-forms
; no need to bind *format-case* to t here
(formatter-main-1 'FORMAT-CASE-CONVERSION-END)
))
(setq forms (revappend inner-forms forms))
)
(push `(LET ((ORIG-STREAM STREAM)
(STREAM (MAKE-STRING-OUTPUT-STREAM (SYS::LINE-POSITION STREAM))))
,@(let* ((*format-uwps* (cons 'NIL *format-uwps*))
(inner-forms
(let ((*format-case* t))
(formatter-main 'FORMAT-CASE-CONVERSION-END)
) )
(cleanup-forms
`((WRITE-STRING
(,(if colon-p
(if atsign-p
'NSTRING-UPCASE
'NSTRING-CAPITALIZE
)
(if atsign-p
'SYS::NSTRING-CAPITALIZE1
'NSTRING-DOWNCASE
) )
(GET-OUTPUT-STREAM-STRING STREAM)
)
ORIG-STREAM
))
))
(if (car *format-uwps*)
`((UNWIND-PROTECT (PROGN ,@inner-forms) ,@cleanup-forms))
`(,@inner-forms ,@cleanup-forms)
) )
)
forms
) ) )
(FORMAT-CONDITIONAL ; #\[
(if colon-p
(if atsign-p
(format-conditional-error)
(progn
(simple-arglist 0)
(push `(IF (NOT ,(formatter-next-arg))
(PROGN ,@(progn
(formatter-stop-linear)
(setq *format-csdl* (cdr *format-csdl*))
(formatter-main 'FORMAT-CONDITIONAL-END)
) )
(PROGN ,@(progn
(formatter-stop-linear)
(setq *format-csdl* (cdr *format-csdl*))
(formatter-main 'FORMAT-CONDITIONAL-END)
) ) )
forms
) ) )
(if atsign-p
(progn
(simple-arglist 0)
(formatter-stop-linear)
(push `(IF (CAR ,*args*)
(PROGN ,@(progn
(setq *format-csdl* (cdr *format-csdl*))
(formatter-main 'FORMAT-CONDITIONAL-END)
) )
(SETQ ,*args* (CDR ,*args*))
)
forms
)
(unless (null (csd-clause-chain (car *format-csdl*)))
(format-error *format-cs* nil
#L{
DEUTSCH "Hier ist keine ~~;-Direktive möglich."
ENGLISH "The ~~; directive is not allowed at this point."
FRANCAIS "La directive ~~; n'est pas permise ici."
}
) ) )
(progn
(simple-arglist 1)
(push `(CASE ,(or (first arglist) (formatter-next-arg))
,@(let ((index 0) (cases '()))
(formatter-stop-linear)
(loop
(when (null (csd-clause-chain (car *format-csdl*)))
(return)
)
(when (csd-colon-p (car *format-csdl*))
(setq index 'T)
)
(setq *format-csdl* (cdr *format-csdl*))
(push `(,index ,@(formatter-main 'FORMAT-CONDITIONAL-END))
cases
)
(if (eq index 'T) (return) (incf index))
)
(nreverse cases)
)
)
forms
) ) ) ) )
(FORMAT-ITERATION ; #\{
(simple-arglist 1)
(setq *format-csdl* (cdr *format-csdl*))
(let ((max-n-iterations (first arglist))
(min-1-iteration (csd-colon-p (car (csd-clause-chain csd))))
(indirect (eq (csd-clause-chain csd) *format-csdl*)))
(flet ((compute-innermost ()
(if indirect
(progn
(formatter-stop-linear)
`((SETQ ,*args*
(DO-FORMAT-INDIRECTION-2 STREAM NODE
,*args* ,(formatter-whole-args 0)
)) )
)
(formatter-main 'FORMAT-ITERATION-END)
)) )
(flet ((compute-inner ()
(if colon-p
(let ((*iterargs* *args*))
(formatter-bind-terminator
(multiple-value-bind (lambdalist innermost)
(formatter-bind-args (compute-innermost))
`((APPLY #'(LAMBDA ,lambdalist ,@innermost)
,(formatter-next-arg)
))
) ) )
(let ((*iterargs* nil))
; CLtL2 S. 598: "When within a ~{ construct, the "goto" is
; relative to the list of arguments being processed by the
; iteration." Soll das heißen, daß man bei ~@{ zu Beginn
; jeder Iteration WHOLE-ARGS neu an ARGS binden muß ??
; (if atsign-p
; (progn (formatter-stop-linear)
; `((LET ((WHOLE-ARGS ,*args*)) ,@(compute-innermost)))
; )
; (compute-innermost)
; )
(compute-innermost)
)) ) )
(flet ((compute-middle ()
(if (eql max-n-iterations 0)
'()
(progn
(unless (and (eql max-n-iterations 1) min-1-iteration)
(formatter-stop-linear)
)
(if (eql max-n-iterations 1)
(if min-1-iteration
(compute-inner)
`((UNLESS (ENDP ,*args*) ,@(compute-inner)))
)
`((BLOCK NIL
(TAGBODY
L
,@(if max-n-iterations
`((WHEN (>= I N) (RETURN)) (INCF I))
)
,@(if (not min-1-iteration)
`((WHEN (ENDP ,*args*) (RETURN)))
)
,@(compute-inner)
,@(if min-1-iteration
`((WHEN (ENDP ,*args*) (RETURN)))
)
(GO L)
)) )
)) ) ) )
(flet ((compute-outer ()
(formatter-bind-terminators
; *format-terminate-all* und *format-terminate* werden
; gebunden, aber falls colon-p, wird *format-terminate*
; weiter innen verschattet (s.o.).
(if atsign-p
(compute-middle)
(multiple-value-bind (lambdalist inner-forms)
(formatter-bind-args (compute-middle))
`((APPLY #'(LAMBDA ,lambdalist ,@inner-forms)
,(formatter-next-arg)
))
)) ) ) )
(flet ((compute-outermost ()
(if indirect
`((LET ((NODE (DO-FORMAT-INDIRECTION-1 ,(formatter-next-arg))))
,@(compute-outer)
))
(compute-outer)
)) )
(let ((new-forms
(if (and max-n-iterations (not (member max-n-iterations '(0 1))))
`((LET ((N ,(first arglist)) (I 0))
,@(compute-outermost)
))
(compute-outermost)
)) )
(setq forms (revappend new-forms forms))
) ) ) ) ) ) ) )
(FORMAT-JUSTIFICATION ; #\<
(simple-arglist 4)
(let* ((firstseparator (car (csd-clause-chain csd)))
(check-on-line-overflow
(and (eq (csd-data firstseparator) 'FORMAT-SEPARATOR)
(csd-colon-p firstseparator)
) )
(bindings
`((POS (SYS::LINE-POSITION STREAM))
(ORIG-STREAM STREAM)
(STREAM (MAKE-STRING-OUTPUT-STREAM POS))
)
)
(justify-args
`(ORIG-STREAM
,colon-p
,atsign-p
,@arglist
POS
,check-on-line-overflow
,(when check-on-line-overflow
(setq *format-csdl* (cdr *format-csdl*))
`(PROGN
,@(formatter-main 'FORMAT-JUSTIFICATION-END)
(GET-OUTPUT-STREAM-STRING STREAM)
)
)
,(when check-on-line-overflow
(formatter-arg (first (csd-parm-list firstseparator)))
)
,(when check-on-line-overflow
(formatter-arg (second (csd-parm-list firstseparator)))
)
)
)
(*format-uwps* (cons 'NIL *format-uwps*))
(pieces-forms '())
)
(loop
(when (null (csd-clause-chain (car *format-csdl*))) (return))
(setq *format-csdl* (cdr *format-csdl*))
(push (formatter-main 'FORMAT-JUSTIFICATION-END) pieces-forms)
)
(setq pieces-forms (nreverse pieces-forms))
(push
(if (car *format-uwps*)
`(LET* (,@bindings
(JARGS (LIST ,@justify-args))
(PIECES '()))
(UNWIND-PROTECT
(PROGN
,@(mapcap #'(lambda (piece-forms)
`(,@piece-forms
(PUSH (GET-OUTPUT-STREAM-STRING STREAM) PIECES)
)
)
pieces-forms
)
)
(APPLY #'DO-FORMAT-JUSTIFICATION
(NCONC JARGS (LIST (SYS::LIST-NREVERSE PIECES)))
) ) )
`(LET* (,@bindings)
(DO-FORMAT-JUSTIFICATION
,@justify-args
(LIST
,@(mapcar #'(lambda (piece-forms)
`(PROGN ,@piece-forms (GET-OUTPUT-STREAM-STRING STREAM))
)
pieces-forms
)
) ) )
)
forms
) ) )
(FORMAT-UP-AND-OUT ; #\^
(simple-arglist 3)
(formatter-stop-linear)
(let ((argsvar (if colon-p *iterargs* *args*)))
(push `(IF ,(if (some #'(lambda (x) (and (constantp x) x)) arglist)
`(UP-AND-OUT-P ,@arglist)
(if (and (null (second arglist)) (null (third arglist)))
(let ((first-arg (first arglist)))
(if (null first-arg)
`(ENDP ,argsvar)
(if (and (consp first-arg) (eq (car first-arg) 'LENGTH))
`(ENDP ,(second first-arg)) ; (EQL (LENGTH x) 0) == (ENDP x)
`(CASE ,first-arg ((NIL) (ENDP ,argsvar)) ((0) T) (T NIL))
) ) )
`(UP-AND-OUT-P ,@arglist ,argsvar)
) )
(RETURN-FROM ,(if colon-p (formatter-terminate-all) (formatter-terminate)))
)
forms
) ) )
(t ; Huh? Someone implemented a new format directive,
; but forgot it here! Bail out.
(throw 'formatter-hairy nil)
)
) ) ) ) )
) )
(setq *format-csdl* (cdr *format-csdl*))
)
; Combine adjacent strings:
(let ((new-forms '()))
(dolist (form forms)
(when (characterp form) (setq form (string form)))
(if (and (consp new-forms) (stringp (car new-forms)) (stringp form))
(setf (car new-forms)
(string-concat form (car new-forms))
)
(push form new-forms)
) )
new-forms
) ) )
(defun formatter-main (&optional (endmarker nil))
(let ((new-forms (formatter-main-1 endmarker)))
; Convert strings to WRITE-STRING forms:
(mapcap #'(lambda (form)
(if (stringp form)
(case (length form)
(0 )
(1 (setq form (char form 0))
`(,(if (eq form #\Newline)
`(TERPRI STREAM)
`(WRITE-CHAR ,form STREAM)
) ) )
(t `((WRITE-STRING ,form STREAM)))
)
(list form)
) )
new-forms
) ) )
;; FORMATTER, CLtL2 S. 764
(defmacro formatter (control-string)
(unless (stringp control-string)
(error-of-type 'type-error
:datum control-string :expected-type 'string
#L{
DEUTSCH "Kontrollstring muß ein String sein, nicht ~S"
ENGLISH "The control-string must be a string, not ~S"
FRANCAIS "La chaîne de contrôle doit être une chaîne et non ~S"
}
control-string
) )
; evtl. noch control-string zu einem Simple-String machen ??
(or
(catch 'formatter-hairy
(let ((node (list control-string)))
(format-parse-cs control-string 0 node nil)
(let ((*FORMAT-CS* (car node))
(*FORMAT-CSDL* (cdr node))
(*format-case* nil)
(*format-uwps* '())
(*iterargs* nil))
(multiple-value-bind (lambdalist forms)
(formatter-bind-args
`(,@(formatter-bind-terminators
(formatter-main)
)
,(progn (formatter-stop-linear) `,*args*)
)
)
`(FUNCTION
(LAMBDA (STREAM ,@lambdalist)
(DECLARE (IGNORABLE STREAM))
,@forms
) )
) ) ) )
`(FORMATTER-HAIRY ,(coerce control-string 'simple-string))
) )
;-------------------------------------------------------------------------------
