1 ;;;; functions to implement FORMAT and FORMATTER
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!FORMAT")
16 (defun format (destination control-string
&rest format-arguments
)
18 "Provides various facilities for formatting output.
19 CONTROL-STRING contains a string to be output, possibly with embedded
20 directives, which are flagged with the escape character \"~\". Directives
21 generally expand into additional text to be output, usually consuming one
22 or more of the FORMAT-ARGUMENTS in the process. A few useful directives
24 ~A or ~nA Prints one argument as if by PRINC
25 ~S or ~nS Prints one argument as if by PRIN1
26 ~D or ~nD Prints one argument as a decimal integer
29 where n is the width of the field in which the object is printed.
31 DESTINATION controls where the result will go. If DESTINATION is T, then
32 the output is sent to the standard output stream. If it is NIL, then the
33 output is returned in a string as the value of the call. Otherwise,
34 DESTINATION must be a stream to which the output will be sent.
36 Example: (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\"
38 FORMAT has many additional capabilities not described here. Consult the
40 (etypecase destination
42 (with-output-to-string (stream)
43 (%format stream control-string format-arguments
)))
45 (with-output-to-string (stream destination
)
46 (%format stream control-string format-arguments
)))
48 (%format
*standard-output
* control-string format-arguments
)
51 (%format destination control-string format-arguments
)
54 (defun %format
(stream string-or-fun orig-args
&optional
(args orig-args
))
55 (if (functionp string-or-fun
)
56 (apply string-or-fun stream args
)
58 (let* ((string (etypecase string-or-fun
62 (coerce string-or-fun
'simple-string
))))
63 (*default-format-error-control-string
* string
)
64 (*logical-block-popper
* nil
))
65 (interpret-directive-list stream
(tokenize-control-string string
)
68 (defun interpret-directive-list (stream directives orig-args args
)
70 (let ((directive (car directives
)))
73 (write-string directive stream
)
74 (interpret-directive-list stream
(cdr directives
) orig-args args
))
76 (multiple-value-bind (new-directives new-args
)
77 (let* ((character (format-directive-character directive
))
79 (svref *format-directive-interpreters
*
80 (char-code character
)))
81 (*default-format-error-offset
*
82 (1- (format-directive-end directive
))))
85 :complaint
"unknown format directive ~@[(character: ~A)~]"
86 :args
(list (char-name character
))))
87 (multiple-value-bind (new-directives new-args
)
88 (funcall function stream directive
89 (cdr directives
) orig-args args
)
90 (values new-directives new-args
)))
91 (interpret-directive-list stream new-directives
92 orig-args new-args
)))))
95 ;;;; FORMAT directive definition macros and runtime support
97 (eval-when (:compile-toplevel
:execute
)
99 ;;; This macro is used to extract the next argument from the current arg list.
100 ;;; This is the version used by format directive interpreters.
101 (sb!xc
:defmacro next-arg
(&optional offset
)
105 :complaint
"no more arguments"
107 `(:offset
,offset
))))
108 (when *logical-block-popper
*
109 (funcall *logical-block-popper
*))
112 (sb!xc
:defmacro def-complex-format-interpreter
(char lambda-list
&body body
)
115 "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
118 (directives (if lambda-list
(car (last lambda-list
)) (gensym))))
120 (defun ,defun-name
(stream ,directive
,directives orig-args args
)
121 (declare (ignorable stream orig-args args
))
123 `((let ,(mapcar (lambda (var)
125 (,(symbolicate "FORMAT-DIRECTIVE-" var
)
127 (butlast lambda-list
))
128 (values (progn ,@body
) args
)))
129 `((declare (ignore ,directive
,directives
))
131 (%set-format-directive-interpreter
,char
#',defun-name
))))
133 (sb!xc
:defmacro def-format-interpreter
(char lambda-list
&body body
)
134 (let ((directives (gensym)))
135 `(def-complex-format-interpreter ,char
(,@lambda-list
,directives
)
139 (sb!xc
:defmacro interpret-bind-defaults
(specs params
&body body
)
140 (once-only ((params params
))
141 (collect ((bindings))
143 (destructuring-bind (var default
) spec
144 (bindings `(,var
(let* ((param-and-offset (pop ,params
))
145 (offset (car param-and-offset
))
146 (param (cdr param-and-offset
)))
148 (:arg
(next-arg offset
))
149 (:remaining
(length args
))
156 "too many parameters, expected no more than ~W"
157 :args
(list ,(length specs
))
158 :offset
(caar ,params
)))
163 ;;;; format interpreters and support functions for simple output
165 (defun format-write-field (stream string mincol colinc minpad padchar padleft
)
167 (write-string string stream
))
169 (write-char padchar stream
))
170 ;; As of sbcl-0.6.12.34, we could end up here when someone tries to
171 ;; print e.g. (FORMAT T "~F" "NOTFLOAT"), in which case ANSI says
172 ;; we're supposed to soldier on bravely, and so we have to deal with
173 ;; the unsupplied-MINCOL-and-COLINC case without blowing up.
174 (when (and mincol colinc
)
175 (do ((chars (+ (length string
) minpad
) (+ chars colinc
)))
178 (write-char padchar stream
))))
180 (write-string string stream
)))
182 (defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar
)
183 (format-write-field stream
184 (if (or arg
(not colonp
))
185 (princ-to-string arg
)
187 mincol colinc minpad padchar atsignp
))
189 (def-format-interpreter #\A
(colonp atsignp params
)
191 (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
194 (format-princ stream
(next-arg) colonp atsignp
195 mincol colinc minpad padchar
))
196 (princ (if colonp
(or (next-arg) "()") (next-arg)) stream
)))
198 (defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar
)
199 (format-write-field stream
200 (if (or arg
(not colonp
))
201 (prin1-to-string arg
)
203 mincol colinc minpad padchar atsignp
))
205 (def-format-interpreter #\S
(colonp atsignp params
)
207 (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
210 (format-prin1 stream
(next-arg) colonp atsignp
211 mincol colinc minpad padchar
)))
213 (let ((arg (next-arg)))
216 (princ "()" stream
))))
218 (prin1 (next-arg) stream
))))
220 (def-format-interpreter #\C
(colonp atsignp params
)
221 (interpret-bind-defaults () params
223 (format-print-named-character (next-arg) stream
)
225 (prin1 (next-arg) stream
)
226 (write-char (next-arg) stream
)))))
228 (defun format-print-named-character (char stream
)
229 (let* ((name (char-name char
)))
231 (write-string (string-capitalize name
) stream
))
233 (write-char char stream
)))))
235 (def-format-interpreter #\W
(colonp atsignp params
)
236 (interpret-bind-defaults () params
237 (let ((*print-pretty
* (or colonp
*print-pretty
*))
238 (*print-level
* (and atsignp
*print-level
*))
239 (*print-length
* (and atsignp
*print-length
*)))
240 (output-object (next-arg) stream
))))
242 ;;;; format interpreters and support functions for integer output
244 ;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
245 ;;; directives. The parameters are interpreted as defined for ~D.
246 (defun format-print-integer (stream number print-commas-p print-sign-p
247 radix mincol padchar commachar commainterval
)
248 (let ((*print-base
* radix
)
250 (if (integerp number
)
251 (let* ((text (princ-to-string (abs number
)))
252 (commaed (if print-commas-p
253 (format-add-commas text commachar commainterval
)
255 (signed (cond ((minusp number
)
256 (concatenate 'string
"-" commaed
))
258 (concatenate 'string
"+" commaed
))
260 ;; colinc = 1, minpad = 0, padleft = t
261 (format-write-field stream signed mincol
1 0 padchar t
))
262 (princ number stream
))))
264 (defun format-add-commas (string commachar commainterval
)
265 (let ((length (length string
)))
266 (multiple-value-bind (commas extra
) (truncate (1- length
) commainterval
)
267 (let ((new-string (make-string (+ length commas
)))
268 (first-comma (1+ extra
)))
269 (replace new-string string
:end1 first-comma
:end2 first-comma
)
270 (do ((src first-comma
(+ src commainterval
))
271 (dst first-comma
(+ dst commainterval
1)))
273 (setf (schar new-string dst
) commachar
)
274 (replace new-string string
:start1
(1+ dst
)
275 :start2 src
:end2
(+ src commainterval
)))
278 ;;; FIXME: This is only needed in this file, could be defined with
279 ;;; SB!XC:DEFMACRO inside EVAL-WHEN
280 (defmacro interpret-format-integer
(base)
281 `(if (or colonp atsignp params
)
282 (interpret-bind-defaults
283 ((mincol 0) (padchar #\space
) (commachar #\
,) (commainterval 3))
285 (format-print-integer stream
(next-arg) colonp atsignp
,base mincol
286 padchar commachar commainterval
))
287 (write (next-arg) :stream stream
:base
,base
:radix nil
:escape nil
)))
289 (def-format-interpreter #\D
(colonp atsignp params
)
290 (interpret-format-integer 10))
292 (def-format-interpreter #\B
(colonp atsignp params
)
293 (interpret-format-integer 2))
295 (def-format-interpreter #\O
(colonp atsignp params
)
296 (interpret-format-integer 8))
298 (def-format-interpreter #\X
(colonp atsignp params
)
299 (interpret-format-integer 16))
301 (def-format-interpreter #\R
(colonp atsignp params
)
303 (interpret-bind-defaults
304 ((base 10) (mincol 0) (padchar #\space
) (commachar #\
,)
307 (format-print-integer stream
(next-arg) colonp atsignp base mincol
308 padchar commachar commainterval
))
311 (format-print-old-roman stream
(next-arg))
312 (format-print-roman stream
(next-arg)))
314 (format-print-ordinal stream
(next-arg))
315 (format-print-cardinal stream
(next-arg))))))
317 (defparameter *cardinal-ones
*
318 #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
320 (defparameter *cardinal-tens
*
321 #(nil nil
"twenty" "thirty" "forty"
322 "fifty" "sixty" "seventy" "eighty" "ninety"))
324 (defparameter *cardinal-teens
*
325 #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD
326 "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
328 (defparameter *cardinal-periods
*
329 #("" " thousand" " million" " billion" " trillion" " quadrillion"
330 " quintillion" " sextillion" " septillion" " octillion" " nonillion"
331 " decillion" " undecillion" " duodecillion" " tredecillion"
332 " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
333 " octodecillion" " novemdecillion" " vigintillion"))
335 (defparameter *ordinal-ones
*
336 #(nil "first" "second" "third" "fourth"
337 "fifth" "sixth" "seventh" "eighth" "ninth"))
339 (defparameter *ordinal-tens
*
340 #(nil "tenth" "twentieth" "thirtieth" "fortieth"
341 "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))
343 (defun format-print-small-cardinal (stream n
)
344 (multiple-value-bind (hundreds rem
) (truncate n
100)
345 (when (plusp hundreds
)
346 (write-string (svref *cardinal-ones
* hundreds
) stream
)
347 (write-string " hundred" stream
)
349 (write-char #\space stream
)))
351 (multiple-value-bind (tens ones
) (truncate rem
10)
353 (write-string (svref *cardinal-tens
* tens
) stream
)
355 (write-char #\- stream
)
356 (write-string (svref *cardinal-ones
* ones
) stream
)))
358 (write-string (svref *cardinal-teens
* ones
) stream
))
360 (write-string (svref *cardinal-ones
* ones
) stream
)))))))
362 (defun format-print-cardinal (stream n
)
364 (write-string "negative " stream
)
365 (format-print-cardinal-aux stream
(- n
) 0 n
))
367 (write-string "zero" stream
))
369 (format-print-cardinal-aux stream n
0 n
))))
371 (defun format-print-cardinal-aux (stream n period err
)
372 (multiple-value-bind (beyond here
) (truncate n
1000)
373 (unless (<= period
20)
374 (error "number too large to print in English: ~:D" err
))
375 (unless (zerop beyond
)
376 (format-print-cardinal-aux stream beyond
(1+ period
) err
))
378 (unless (zerop beyond
)
379 (write-char #\space stream
))
380 (format-print-small-cardinal stream here
)
381 (write-string (svref *cardinal-periods
* period
) stream
))))
383 (defun format-print-ordinal (stream n
)
385 (write-string "negative " stream
))
386 (let ((number (abs n
)))
387 (multiple-value-bind (top bot
) (truncate number
100)
389 (format-print-cardinal stream
(- number bot
)))
390 (when (and (plusp top
) (plusp bot
))
391 (write-char #\space stream
))
392 (multiple-value-bind (tens ones
) (truncate bot
10)
393 (cond ((= bot
12) (write-string "twelfth" stream
))
395 (write-string (svref *cardinal-teens
* ones
) stream
);;;RAD
396 (write-string "th" stream
))
397 ((and (zerop tens
) (plusp ones
))
398 (write-string (svref *ordinal-ones
* ones
) stream
))
399 ((and (zerop ones
)(plusp tens
))
400 (write-string (svref *ordinal-tens
* tens
) stream
))
402 (write-string (svref *cardinal-tens
* tens
) stream
)
403 (write-char #\- stream
)
404 (write-string (svref *ordinal-ones
* ones
) stream
))
406 (write-string "th" stream
))
408 (write-string "zeroth" stream
)))))))
410 ;;; Print Roman numerals
412 (defun format-print-old-roman (stream n
)
414 (error "Number too large to print in old Roman numerals: ~:D" n
))
415 (do ((char-list '(#\D
#\C
#\L
#\X
#\V
#\I
) (cdr char-list
))
416 (val-list '(500 100 50 10 5 1) (cdr val-list
))
417 (cur-char #\M
(car char-list
))
418 (cur-val 1000 (car val-list
))
419 (start n
(do ((i start
(progn
420 (write-char cur-char stream
)
425 (defun format-print-roman (stream n
)
427 (error "Number too large to print in Roman numerals: ~:D" n
))
428 (do ((char-list '(#\D
#\C
#\L
#\X
#\V
#\I
) (cdr char-list
))
429 (val-list '(500 100 50 10 5 1) (cdr val-list
))
430 (sub-chars '(#\C
#\X
#\X
#\I
#\I
) (cdr sub-chars
))
431 (sub-val '(100 10 10 1 1 0) (cdr sub-val
))
432 (cur-char #\M
(car char-list
))
433 (cur-val 1000 (car val-list
))
434 (cur-sub-char #\C
(car sub-chars
))
435 (cur-sub-val 100 (car sub-val
))
436 (start n
(do ((i start
(progn
437 (write-char cur-char stream
)
440 (cond ((<= (- cur-val cur-sub-val
) i
)
441 (write-char cur-sub-char stream
)
442 (write-char cur-char stream
)
443 (- i
(- cur-val cur-sub-val
)))
449 (def-format-interpreter #\P
(colonp atsignp params
)
450 (interpret-bind-defaults () params
451 (let ((arg (if colonp
452 (if (eq orig-args args
)
454 :complaint
"no previous argument")
455 (do ((arg-ptr orig-args
(cdr arg-ptr
)))
456 ((eq (cdr arg-ptr
) args
)
460 (write-string (if (eql arg
1) "y" "ies") stream
)
461 (unless (eql arg
1) (write-char #\s stream
))))))
463 ;;;; format interpreters and support functions for floating point output
465 (defun decimal-string (n)
466 (write-to-string n
:base
10 :radix nil
:escape nil
))
468 (def-format-interpreter #\F
(colonp atsignp params
)
472 "cannot specify the colon modifier with this directive"))
473 (interpret-bind-defaults ((w nil
) (d nil
) (k nil
) (ovf nil
) (pad #\space
))
475 (format-fixed stream
(next-arg) w d k ovf pad atsignp
)))
477 (defun format-fixed (stream number w d k ovf pad atsign
)
480 (format-fixed-aux stream number w d k ovf pad atsign
)
481 (if (rationalp number
)
482 (format-fixed-aux stream
483 (coerce number
'single-float
)
484 w d k ovf pad atsign
)
485 (format-write-field stream
486 (decimal-string number
)
488 (format-princ stream number nil nil w
1 0 pad
)))
490 ;;; We return true if we overflowed, so that ~G can output the overflow char
491 ;;; instead of spaces.
492 (defun format-fixed-aux (stream number w d k ovf pad atsign
)
496 (or (float-infinity-p number
)
497 (float-nan-p number
))))
498 (prin1 number stream
)
502 (when (and w
(or atsign
(minusp number
))) (decf spaceleft
))
503 (multiple-value-bind (str len lpoint tpoint
)
504 (sb!impl
::flonum-to-string
(abs number
) spaceleft d k
)
505 ;;if caller specifically requested no fraction digits, suppress the
506 ;;optional trailing zero
507 (when (and d
(zerop d
)) (setq tpoint nil
))
510 ;;optional leading zero
512 (if (or (> spaceleft
0) tpoint
) ;force at least one digit
515 ;;optional trailing zero
520 (cond ((and w
(< spaceleft
0) ovf
)
521 ;;field width overflow
522 (dotimes (i w
) (write-char ovf stream
))
525 (when w
(dotimes (i spaceleft
) (write-char pad stream
)))
527 (write-char #\- stream
)
528 (if atsign
(write-char #\
+ stream
)))
529 (when lpoint
(write-char #\
0 stream
))
530 (write-string str stream
)
531 (when tpoint
(write-char #\
0 stream
))
534 (def-format-interpreter #\E
(colonp atsignp params
)
538 "cannot specify the colon modifier with this directive"))
539 (interpret-bind-defaults
540 ((w nil
) (d nil
) (e nil
) (k 1) (ovf nil
) (pad #\space
) (mark nil
))
542 (format-exponential stream
(next-arg) w d e k ovf pad mark atsignp
)))
544 (defun format-exponential (stream number w d e k ovf pad marker atsign
)
547 (format-exp-aux stream number w d e k ovf pad marker atsign
)
548 (if (rationalp number
)
549 (format-exp-aux stream
550 (coerce number
'single-float
)
551 w d e k ovf pad marker atsign
)
552 (format-write-field stream
553 (decimal-string number
)
555 (format-princ stream number nil nil w
1 0 pad
)))
557 (defun format-exponent-marker (number)
558 (if (typep number
*read-default-float-format
*)
566 ;;; Here we prevent the scale factor from shifting all significance out of
567 ;;; a number to the right. We allow insignificant zeroes to be shifted in
568 ;;; to the left right, athough it is an error to specify k and d such that this
569 ;;; occurs. Perhaps we should detect both these condtions and flag them as
570 ;;; errors. As for now, we let the user get away with it, and merely guarantee
571 ;;; that at least one significant digit will appear.
573 ;;; Raymond Toy writes: The Hyperspec seems to say that the exponent
574 ;;; marker is always printed. Make it so. Also, the original version
575 ;;; causes errors when printing infinities or NaN's. The Hyperspec is
576 ;;; silent here, so let's just print out infinities and NaN's instead
577 ;;; of causing an error.
578 (defun format-exp-aux (stream number w d e k ovf pad marker atsign
)
579 (if (and (floatp number
)
580 (or (float-infinity-p number
)
581 (float-nan-p number
)))
582 (prin1 number stream
)
583 (multiple-value-bind (num expt
) (sb!impl
::scale-exponent
(abs number
))
584 (let* ((expt (- expt k
))
585 (estr (decimal-string (abs expt
)))
586 (elen (if e
(max (length estr
) e
) (length estr
)))
587 (fdig (if d
(if (plusp k
) (1+ (- d k
)) d
) nil
))
588 (fmin (if (minusp k
) (- 1 k
) nil
))
591 (if (or atsign
(minusp number
))
594 (if (and w ovf e
(> elen e
)) ;exponent overflow
595 (dotimes (i w
) (write-char ovf stream
))
596 (multiple-value-bind (fstr flen lpoint
)
597 (sb!impl
::flonum-to-string num spaceleft fdig k fmin
)
599 (decf spaceleft flen
)
604 (cond ((and w
(< spaceleft
0) ovf
)
605 ;;significand overflow
606 (dotimes (i w
) (write-char ovf stream
)))
608 (dotimes (i spaceleft
) (write-char pad stream
)))
610 (write-char #\- stream
)
611 (if atsign
(write-char #\
+ stream
)))
612 (when lpoint
(write-char #\
0 stream
))
613 (write-string fstr stream
)
614 (write-char (if marker
616 (format-exponent-marker number
))
618 (write-char (if (minusp expt
) #\-
#\
+) stream
)
620 ;;zero-fill before exponent if necessary
621 (dotimes (i (- e
(length estr
)))
622 (write-char #\
0 stream
)))
623 (write-string estr stream
)))))))))
625 (def-format-interpreter #\G
(colonp atsignp params
)
629 "cannot specify the colon modifier with this directive"))
630 (interpret-bind-defaults
631 ((w nil
) (d nil
) (e nil
) (k nil
) (ovf nil
) (pad #\space
) (mark nil
))
633 (format-general stream
(next-arg) w d e k ovf pad mark atsignp
)))
635 (defun format-general (stream number w d e k ovf pad marker atsign
)
638 (format-general-aux stream number w d e k ovf pad marker atsign
)
639 (if (rationalp number
)
640 (format-general-aux stream
641 (coerce number
'single-float
)
642 w d e k ovf pad marker atsign
)
643 (format-write-field stream
644 (decimal-string number
)
646 (format-princ stream number nil nil w
1 0 pad
)))
648 ;;; Raymond Toy writes: same change as for format-exp-aux
649 (defun format-general-aux (stream number w d e k ovf pad marker atsign
)
650 (if (and (floatp number
)
651 (or (float-infinity-p number
)
652 (float-nan-p number
)))
653 (prin1 number stream
)
654 (multiple-value-bind (ignore n
) (sb!impl
::scale-exponent
(abs number
))
655 (declare (ignore ignore
))
656 ;; KLUDGE: Default d if omitted. The procedure is taken directly from
657 ;; the definition given in the manual, and is not very efficient, since
658 ;; we generate the digits twice. Future maintainers are encouraged to
659 ;; improve on this. -- rtoy?? 1998??
661 (multiple-value-bind (str len
)
662 (sb!impl
::flonum-to-string
(abs number
))
663 (declare (ignore str
))
664 (let ((q (if (= len
1) 1 (1- len
))))
665 (setq d
(max q
(min n
7))))))
666 (let* ((ee (if e
(+ e
2) 4))
667 (ww (if w
(- w ee
) nil
))
670 (let ((char (if (format-fixed-aux stream number ww dd nil
674 (dotimes (i ee
) (write-char char stream
))))
676 (format-exp-aux stream number w d e
(or k
1)
677 ovf pad marker atsign
)))))))
679 (def-format-interpreter #\$
(colonp atsignp params
)
680 (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space
)) params
681 (format-dollars stream
(next-arg) d n w pad colonp atsignp
)))
683 (defun format-dollars (stream number d n w pad colon atsign
)
684 (when (rationalp number
)
685 ;; This coercion to SINGLE-FLOAT seems as though it gratuitously
686 ;; loses precision (why not LONG-FLOAT?) but it's the default
687 ;; behavior in the ANSI spec, so in some sense it's the right
688 ;; thing, and at least the user shouldn't be surprised.
689 (setq number
(coerce number
'single-float
)))
691 (let* ((signstr (if (minusp number
) "-" (if atsign
"+" "")))
692 (signlen (length signstr
)))
693 (multiple-value-bind (str strlen ig2 ig3 pointplace
)
694 (sb!impl
::flonum-to-string number nil d nil
)
695 (declare (ignore ig2 ig3 strlen
))
697 (write-string signstr stream
))
698 (dotimes (i (- w signlen
(max n pointplace
) 1 d
))
699 (write-char pad stream
))
701 (write-string signstr stream
))
702 (dotimes (i (- n pointplace
))
703 (write-char #\
0 stream
))
704 (write-string str stream
)))
705 (format-write-field stream
706 (decimal-string number
)
709 ;;;; FORMAT interpreters and support functions for line/page breaks etc.
711 (def-format-interpreter #\%
(colonp atsignp params
)
712 (when (or colonp atsignp
)
715 "cannot specify either colon or atsign for this directive"))
716 (interpret-bind-defaults ((count 1)) params
720 (def-format-interpreter #\
& (colonp atsignp params
)
721 (when (or colonp atsignp
)
724 "cannot specify either colon or atsign for this directive"))
725 (interpret-bind-defaults ((count 1)) params
727 (dotimes (i (1- count
))
730 (def-format-interpreter #\|
(colonp atsignp params
)
731 (when (or colonp atsignp
)
734 "cannot specify either colon or atsign for this directive"))
735 (interpret-bind-defaults ((count 1)) params
737 (write-char (code-char form-feed-char-code
) stream
))))
739 (def-format-interpreter #\~
(colonp atsignp params
)
740 (when (or colonp atsignp
)
743 "cannot specify either colon or atsign for this directive"))
744 (interpret-bind-defaults ((count 1)) params
746 (write-char #\~ stream
))))
748 (def-complex-format-interpreter #\newline
(colonp atsignp params directives
)
749 (when (and colonp atsignp
)
752 "cannot specify both colon and atsign for this directive"))
753 (interpret-bind-defaults () params
755 (write-char #\newline stream
)))
756 (if (and (not colonp
)
758 (simple-string-p (car directives
)))
759 (cons (string-left-trim *format-whitespace-chars
*
764 ;;;; format interpreters and support functions for tabs and simple pretty
767 (def-format-interpreter #\T
(colonp atsignp params
)
769 (interpret-bind-defaults ((n 1) (m 1)) params
770 (pprint-tab (if atsignp
:section-relative
:section
) n m stream
))
772 (interpret-bind-defaults ((colrel 1) (colinc 1)) params
773 (format-relative-tab stream colrel colinc
))
774 (interpret-bind-defaults ((colnum 1) (colinc 1)) params
775 (format-absolute-tab stream colnum colinc
)))))
777 (defun output-spaces (stream n
)
778 (let ((spaces #.
(make-string 100 :initial-element
#\space
)))
780 (when (< n
(length spaces
))
782 (write-string spaces stream
)
783 (decf n
(length spaces
)))
784 (write-string spaces stream
:end n
)))
786 (defun format-relative-tab (stream colrel colinc
)
787 (if (sb!pretty
:pretty-stream-p stream
)
788 (pprint-tab :line-relative colrel colinc stream
)
789 (let* ((cur (sb!impl
::charpos stream
))
790 (spaces (if (and cur
(plusp colinc
))
791 (- (* (ceiling (+ cur colrel
) colinc
) colinc
) cur
)
793 (output-spaces stream spaces
))))
795 (defun format-absolute-tab (stream colnum colinc
)
796 (if (sb!pretty
:pretty-stream-p stream
)
797 (pprint-tab :line colnum colinc stream
)
798 (let ((cur (sb!impl
::charpos stream
)))
800 (write-string " " stream
))
802 (output-spaces stream
(- colnum cur
)))
804 (unless (zerop colinc
)
805 (output-spaces stream
806 (- colinc
(rem (- cur colnum
) colinc
)))))))))
808 (def-format-interpreter #\_
(colonp atsignp params
)
809 (interpret-bind-defaults () params
810 (pprint-newline (if colonp
819 (def-format-interpreter #\I
(colonp atsignp params
)
822 :complaint
"cannot specify the at-sign modifier"))
823 (interpret-bind-defaults ((n 0)) params
824 (pprint-indent (if colonp
:current
:block
) n stream
)))
826 ;;;; format interpreter for ~*
828 (def-format-interpreter #\
* (colonp atsignp params
)
832 :complaint
"cannot specify both colon and at-sign")
833 (interpret-bind-defaults ((posn 0)) params
834 (if (<= 0 posn
(length orig-args
))
835 (setf args
(nthcdr posn orig-args
))
837 :complaint
"Index ~W is out of bounds. (It should ~
838 have been between 0 and ~W.)"
839 :args
(list posn
(length orig-args
))))))
841 (interpret-bind-defaults ((n 1)) params
842 (do ((cur-posn 0 (1+ cur-posn
))
843 (arg-ptr orig-args
(cdr arg-ptr
)))
845 (let ((new-posn (- cur-posn n
)))
846 (if (<= 0 new-posn
(length orig-args
))
847 (setf args
(nthcdr new-posn orig-args
))
850 "Index ~W is out of bounds. (It should
851 have been between 0 and ~W.)"
853 (list new-posn
(length orig-args
))))))))
854 (interpret-bind-defaults ((n 1)) params
858 ;;;; format interpreter for indirection
860 (def-format-interpreter #\? (colonp atsignp params string end
)
863 :complaint
"cannot specify the colon modifier"))
864 (interpret-bind-defaults () params
870 "~A~%while processing indirect format string:"
871 :args
(list condition
)
873 :control-string string
876 (setf args
(%format stream
(next-arg) orig-args args
))
877 (%format stream
(next-arg) (next-arg))))))
879 ;;;; format interpreters for capitalization
881 (def-complex-format-interpreter #\
( (colonp atsignp params directives
)
882 (let ((close (find-directive directives
#\
) nil
)))
885 :complaint
"no corresponding close paren"))
886 (interpret-bind-defaults () params
887 (let* ((posn (position close directives
))
888 (before (subseq directives
0 posn
))
889 (after (nthcdr (1+ posn
) directives
))
890 (stream (make-case-frob-stream stream
898 (setf args
(interpret-directive-list stream before orig-args args
))
901 (def-complex-format-interpreter #\
) ()
903 :complaint
"no corresponding open paren"))
905 ;;;; format interpreters and support functions for conditionalization
907 (def-complex-format-interpreter #\
[ (colonp atsignp params directives
)
908 (multiple-value-bind (sublists last-semi-with-colon-p remaining
)
909 (parse-conditional-directive directives
)
915 "cannot specify both the colon and at-sign modifiers")
919 "can only specify one section")
920 (interpret-bind-defaults () params
921 (let ((prev-args args
)
924 (interpret-directive-list stream
930 (if (= (length sublists
) 2)
931 (interpret-bind-defaults () params
933 (interpret-directive-list stream
(car sublists
)
935 (interpret-directive-list stream
(cadr sublists
)
939 "must specify exactly two sections"))
940 (interpret-bind-defaults ((index (next-arg))) params
941 (let* ((default (and last-semi-with-colon-p
943 (last (1- (length sublists
)))
945 (if (<= 0 index last
)
946 (nth (- last index
) sublists
)
948 (interpret-directive-list stream sublist orig-args
952 (def-complex-format-interpreter #\
; ()
955 "~~; not contained within either ~~[...~~] or ~~<...~~>"))
957 (def-complex-format-interpreter #\
] ()
960 "no corresponding open bracket"))
962 ;;;; format interpreter for up-and-out
964 (defvar *outside-args
*)
966 (def-format-interpreter #\^
(colonp atsignp params
)
969 :complaint
"cannot specify the at-sign modifier"))
970 (when (and colonp
(not *up-up-and-out-allowed
*))
972 :complaint
"attempt to use ~~:^ outside a ~~:{...~~} construct"))
973 (when (case (length params
)
975 (null *outside-args
*)
977 (1 (interpret-bind-defaults ((count 0)) params
979 (2 (interpret-bind-defaults ((arg1 0) (arg2 0)) params
981 (t (interpret-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
982 (<= arg1 arg2 arg3
))))
983 (throw (if colonp
'up-up-and-out
'up-and-out
)
986 ;;;; format interpreters for iteration
988 (def-complex-format-interpreter #\
{
989 (colonp atsignp params string end directives
)
990 (let ((close (find-directive directives
#\
} nil
)))
994 "no corresponding close brace"))
995 (interpret-bind-defaults ((max-count nil
)) params
996 (let* ((closed-with-colon (format-directive-colonp close
))
997 (posn (position close directives
))
998 (insides (if (zerop posn
)
1000 (subseq directives
0 posn
)))
1001 (*up-up-and-out-allowed
* colonp
))
1003 ((do-guts (orig-args args
)
1011 "~A~%while processing indirect format string:"
1012 :args
(list condition
)
1014 :control-string string
1015 :offset
(1- end
)))))
1016 (%format stream insides orig-args args
))
1017 (interpret-directive-list stream insides
1019 (bind-args (orig-args args
)
1021 (let* ((arg (next-arg))
1022 (*logical-block-popper
* nil
)
1023 (*outside-args
* args
))
1027 (do-guts orig-args args
)))
1028 (do-loop (orig-args args
)
1029 (catch (if colonp
'up-up-and-out
'up-and-out
)
1031 (when (and (not closed-with-colon
) (null args
))
1033 (when (and max-count
(minusp (decf max-count
)))
1035 (setf args
(bind-args orig-args args
))
1036 (when (and closed-with-colon
(null args
))
1040 (setf args
(do-loop orig-args args
))
1041 (let ((arg (next-arg))
1042 (*logical-block-popper
* nil
))
1044 (nthcdr (1+ posn
) directives
))))))
1046 (def-complex-format-interpreter #\
} ()
1047 (error 'format-error
1048 :complaint
"no corresponding open brace"))
1050 ;;;; format interpreters and support functions for justification
1052 (def-complex-format-interpreter #\
<
1053 (colonp atsignp params string end directives
)
1054 (multiple-value-bind (segments first-semi close remaining
)
1055 (parse-format-justification directives
)
1057 (if (format-directive-colonp close
)
1058 (multiple-value-bind (prefix per-line-p insides suffix
)
1059 (parse-format-logical-block segments colonp first-semi
1060 close params string end
)
1061 (interpret-format-logical-block stream orig-args args
1062 prefix per-line-p insides
1064 (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x
)) segments
))))
1066 ;; ANSI specifies that "an error is signalled" in this
1068 (error 'format-error
1069 :complaint
"~D illegal directive~:P found inside justification block"
1070 :args
(list count
)))
1071 (interpret-format-justification stream orig-args args
1072 segments colonp atsignp
1073 first-semi params
))))
1076 (defun interpret-format-justification
1077 (stream orig-args args segments colonp atsignp first-semi params
)
1078 (interpret-bind-defaults
1079 ((mincol 0) (colinc 1) (minpad 0) (padchar #\space
))
1081 (let ((newline-string nil
)
1087 (when (and first-semi
(format-directive-colonp first-semi
))
1088 (interpret-bind-defaults
1090 (len (or (sb!impl
::line-length stream
) 72)))
1091 (format-directive-params first-semi
)
1092 (setf newline-string
1093 (with-output-to-string (stream)
1095 (interpret-directive-list stream
1099 (setf extra-space extra
)
1100 (setf line-len len
)))
1101 (dolist (segment segments
)
1102 (push (with-output-to-string (stream)
1104 (interpret-directive-list stream segment
1108 (format-justification stream newline-string extra-space line-len strings
1109 colonp atsignp mincol colinc minpad padchar
)))
1112 (defun format-justification (stream newline-prefix extra-space line-len strings
1113 pad-left pad-right mincol colinc minpad padchar
)
1114 (setf strings
(reverse strings
))
1115 (when (and (not pad-left
) (not pad-right
) (null (cdr strings
)))
1117 (let* ((num-gaps (+ (1- (length strings
))
1119 (if pad-right
1 0)))
1120 (chars (+ (* num-gaps minpad
)
1122 for string in strings
1123 summing
(length string
))))
1124 (length (if (> chars mincol
)
1125 (+ mincol
(* (ceiling (- chars mincol
) colinc
) colinc
))
1127 (padding (- length chars
)))
1128 (when (and newline-prefix
1129 (> (+ (or (sb!impl
::charpos stream
) 0)
1132 (write-string newline-prefix stream
))
1133 (flet ((do-padding ()
1134 (let ((pad-len (truncate padding num-gaps
)))
1135 (decf padding pad-len
)
1137 (dotimes (i pad-len
) (write-char padchar stream
)))))
1141 (write-string (car strings
) stream
)
1142 (dolist (string (cdr strings
))
1144 (write-string string stream
)))
1148 (defun interpret-format-logical-block
1149 (stream orig-args args prefix per-line-p insides suffix atsignp
)
1150 (let ((arg (if atsignp args
(next-arg))))
1152 (pprint-logical-block
1153 (stream arg
:per-line-prefix prefix
:suffix suffix
)
1154 (let ((*logical-block-popper
* (lambda () (pprint-pop))))
1156 (interpret-directive-list stream insides
1157 (if atsignp orig-args arg
)
1159 (pprint-logical-block (stream arg
:prefix prefix
:suffix suffix
)
1160 (let ((*logical-block-popper
* (lambda () (pprint-pop))))
1162 (interpret-directive-list stream insides
1163 (if atsignp orig-args arg
)
1165 (if atsignp nil args
))
1167 ;;;; format interpreter and support functions for user-defined method
1169 (def-format-interpreter #\
/ (string start end colonp atsignp params
)
1170 (let ((symbol (extract-user-fun-name string start end
)))
1172 (dolist (param-and-offset params
)
1173 (let ((param (cdr param-and-offset
)))
1175 (:arg
(args (next-arg)))
1176 (:remaining
(args (length args
)))
1178 (apply (fdefinition symbol
) stream
(next-arg) colonp atsignp
(args)))))