1.0.27.46: Fix build on systems with "src" in the path.
[sbcl/tcr.git] / src / code / target-format.lisp
blobc851874abe50cc5ab4994b0836845c830d21188b
1 ;;;; functions to implement FORMAT and FORMATTER
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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")
14 ;;;; FORMAT
16 (defun format (destination control-string &rest format-arguments)
17 #!+sb-doc
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
23 are:
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
27 ~% Does a TERPRI
28 ~& Does a FRESH-LINE
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
39 manual for details."
40 (etypecase destination
41 (null
42 (with-output-to-string (stream)
43 (%format stream control-string format-arguments)))
44 (string
45 (with-output-to-string (stream destination)
46 (%format stream control-string format-arguments)))
47 ((member t)
48 (%format *standard-output* control-string format-arguments)
49 nil)
50 (stream
51 (%format destination control-string format-arguments)
52 nil)))
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)
57 (catch 'up-and-out
58 (let* ((string (etypecase string-or-fun
59 (simple-string
60 string-or-fun)
61 (string
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)
66 orig-args args)))))
68 (defun interpret-directive-list (stream directives orig-args args)
69 (if directives
70 (let ((directive (car directives)))
71 (etypecase directive
72 (simple-string
73 (write-string directive stream)
74 (interpret-directive-list stream (cdr directives) orig-args args))
75 (format-directive
76 (multiple-value-bind (new-directives new-args)
77 (let* ((character (format-directive-character directive))
78 (function
79 (typecase character
80 (base-char
81 (svref *format-directive-interpreters* (char-code character)))
82 (character nil)))
83 (*default-format-error-offset*
84 (1- (format-directive-end directive))))
85 (unless function
86 (error 'format-error
87 :complaint "unknown format directive ~@[(character: ~A)~]"
88 :args (list (char-name character))))
89 (multiple-value-bind (new-directives new-args)
90 (funcall function stream directive
91 (cdr directives) orig-args args)
92 (values new-directives new-args)))
93 (interpret-directive-list stream new-directives
94 orig-args new-args)))))
95 args))
97 ;;;; FORMAT directive definition macros and runtime support
99 (eval-when (:compile-toplevel :execute)
101 ;;; This macro is used to extract the next argument from the current arg list.
102 ;;; This is the version used by format directive interpreters.
103 (sb!xc:defmacro next-arg (&optional offset)
104 `(progn
105 (when (null args)
106 (error 'format-error
107 :complaint "no more arguments"
108 ,@(when offset
109 `(:offset ,offset))))
110 (when *logical-block-popper*
111 (funcall *logical-block-popper*))
112 (pop args)))
114 (sb!xc:defmacro def-complex-format-interpreter (char lambda-list &body body)
115 (let ((defun-name
116 (intern (format nil
117 "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
118 char)))
119 (directive (sb!xc:gensym "DIRECTIVE"))
120 (directives (if lambda-list (car (last lambda-list)) (sb!xc:gensym "DIRECTIVES"))))
121 `(progn
122 (defun ,defun-name (stream ,directive ,directives orig-args args)
123 (declare (ignorable stream orig-args args))
124 ,@(if lambda-list
125 `((let ,(mapcar (lambda (var)
126 `(,var
127 (,(symbolicate "FORMAT-DIRECTIVE-" var)
128 ,directive)))
129 (butlast lambda-list))
130 (values (progn ,@body) args)))
131 `((declare (ignore ,directive ,directives))
132 ,@body)))
133 (%set-format-directive-interpreter ,char #',defun-name))))
135 (sb!xc:defmacro def-format-interpreter (char lambda-list &body body)
136 (let ((directives (sb!xc:gensym "DIRECTIVES")))
137 `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
138 ,@body
139 ,directives)))
141 (sb!xc:defmacro interpret-bind-defaults (specs params &body body)
142 (once-only ((params params))
143 (collect ((bindings))
144 (dolist (spec specs)
145 (destructuring-bind (var default) spec
146 (bindings `(,var (let* ((param-and-offset (pop ,params))
147 (offset (car param-and-offset))
148 (param (cdr param-and-offset)))
149 (case param
150 (:arg (or (next-arg offset) ,default))
151 (:remaining (length args))
152 ((nil) ,default)
153 (t param)))))))
154 `(let* ,(bindings)
155 (when ,params
156 (error 'format-error
157 :complaint
158 "too many parameters, expected no more than ~W"
159 :args (list ,(length specs))
160 :offset (caar ,params)))
161 ,@body))))
163 ) ; EVAL-WHEN
165 ;;;; format interpreters and support functions for simple output
167 (defun format-write-field (stream string mincol colinc minpad padchar padleft)
168 (unless padleft
169 (write-string string stream))
170 (dotimes (i minpad)
171 (write-char padchar stream))
172 ;; As of sbcl-0.6.12.34, we could end up here when someone tries to
173 ;; print e.g. (FORMAT T "~F" "NOTFLOAT"), in which case ANSI says
174 ;; we're supposed to soldier on bravely, and so we have to deal with
175 ;; the unsupplied-MINCOL-and-COLINC case without blowing up.
176 (when (and mincol colinc)
177 (do ((chars (+ (length string) (max minpad 0)) (+ chars colinc)))
178 ((>= chars mincol))
179 (dotimes (i colinc)
180 (write-char padchar stream))))
181 (when padleft
182 (write-string string stream)))
184 (defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar)
185 (format-write-field stream
186 (if (or arg (not colonp))
187 (princ-to-string arg)
188 "()")
189 mincol colinc minpad padchar atsignp))
191 (def-format-interpreter #\A (colonp atsignp params)
192 (if params
193 (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
194 (padchar #\space))
195 params
196 (format-princ stream (next-arg) colonp atsignp
197 mincol colinc minpad padchar))
198 (princ (if colonp (or (next-arg) "()") (next-arg)) stream)))
200 (defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
201 (format-write-field stream
202 (if (or arg (not colonp))
203 (prin1-to-string arg)
204 "()")
205 mincol colinc minpad padchar atsignp))
207 (def-format-interpreter #\S (colonp atsignp params)
208 (cond (params
209 (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
210 (padchar #\space))
211 params
212 (format-prin1 stream (next-arg) colonp atsignp
213 mincol colinc minpad padchar)))
214 (colonp
215 (let ((arg (next-arg)))
216 (if arg
217 (prin1 arg stream)
218 (princ "()" stream))))
220 (prin1 (next-arg) stream))))
222 (def-format-interpreter #\C (colonp atsignp params)
223 (interpret-bind-defaults () params
224 (if colonp
225 (format-print-named-character (next-arg) stream)
226 (if atsignp
227 (prin1 (next-arg) stream)
228 (write-char (next-arg) stream)))))
230 ;;; "printing" as defined in the ANSI CL glossary, which is normative.
231 (defun char-printing-p (char)
232 (and (not (eql char #\Space))
233 (graphic-char-p char)))
235 (defun format-print-named-character (char stream)
236 (cond ((not (char-printing-p char))
237 (write-string (string-capitalize (char-name char)) stream))
239 (write-char char stream))))
241 (def-format-interpreter #\W (colonp atsignp params)
242 (interpret-bind-defaults () params
243 (let ((*print-pretty* (or colonp *print-pretty*))
244 (*print-level* (unless atsignp *print-level*))
245 (*print-length* (unless atsignp *print-length*)))
246 (output-object (next-arg) stream))))
248 ;;;; format interpreters and support functions for integer output
250 ;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
251 ;;; directives. The parameters are interpreted as defined for ~D.
252 (defun format-print-integer (stream number print-commas-p print-sign-p
253 radix mincol padchar commachar commainterval)
254 (let ((*print-base* radix)
255 (*print-radix* nil))
256 (if (integerp number)
257 (let* ((text (princ-to-string (abs number)))
258 (commaed (if print-commas-p
259 (format-add-commas text commachar commainterval)
260 text))
261 (signed (cond ((minusp number)
262 (concatenate 'string "-" commaed))
263 (print-sign-p
264 (concatenate 'string "+" commaed))
265 (t commaed))))
266 ;; colinc = 1, minpad = 0, padleft = t
267 (format-write-field stream signed mincol 1 0 padchar t))
268 (princ number stream))))
270 (defun format-add-commas (string commachar commainterval)
271 (let ((length (length string)))
272 (multiple-value-bind (commas extra) (truncate (1- length) commainterval)
273 (let ((new-string (make-string (+ length commas)))
274 (first-comma (1+ extra)))
275 (replace new-string string :end1 first-comma :end2 first-comma)
276 (do ((src first-comma (+ src commainterval))
277 (dst first-comma (+ dst commainterval 1)))
278 ((= src length))
279 (setf (schar new-string dst) commachar)
280 (replace new-string string :start1 (1+ dst)
281 :start2 src :end2 (+ src commainterval)))
282 new-string))))
284 ;;; FIXME: This is only needed in this file, could be defined with
285 ;;; SB!XC:DEFMACRO inside EVAL-WHEN
286 (defmacro interpret-format-integer (base)
287 `(if (or colonp atsignp params)
288 (interpret-bind-defaults
289 ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
290 params
291 (format-print-integer stream (next-arg) colonp atsignp ,base mincol
292 padchar commachar commainterval))
293 (let ((*print-base* ,base)
294 (*print-radix* nil)
295 (*print-escape* nil))
296 (output-object (next-arg) stream))))
298 (def-format-interpreter #\D (colonp atsignp params)
299 (interpret-format-integer 10))
301 (def-format-interpreter #\B (colonp atsignp params)
302 (interpret-format-integer 2))
304 (def-format-interpreter #\O (colonp atsignp params)
305 (interpret-format-integer 8))
307 (def-format-interpreter #\X (colonp atsignp params)
308 (interpret-format-integer 16))
310 (def-format-interpreter #\R (colonp atsignp params)
311 (interpret-bind-defaults
312 ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
313 (commainterval 3))
314 params
315 (let ((arg (next-arg)))
316 (if base
317 (format-print-integer stream arg colonp atsignp base mincol
318 padchar commachar commainterval)
319 (if atsignp
320 (if colonp
321 (format-print-old-roman stream arg)
322 (format-print-roman stream arg))
323 (if colonp
324 (format-print-ordinal stream arg)
325 (format-print-cardinal stream arg)))))))
327 (defparameter *cardinal-ones*
328 #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
330 (defparameter *cardinal-tens*
331 #(nil nil "twenty" "thirty" "forty"
332 "fifty" "sixty" "seventy" "eighty" "ninety"))
334 (defparameter *cardinal-teens*
335 #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD
336 "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
338 (defparameter *cardinal-periods*
339 #("" " thousand" " million" " billion" " trillion" " quadrillion"
340 " quintillion" " sextillion" " septillion" " octillion" " nonillion"
341 " decillion" " undecillion" " duodecillion" " tredecillion"
342 " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
343 " octodecillion" " novemdecillion" " vigintillion"))
345 (defparameter *ordinal-ones*
346 #(nil "first" "second" "third" "fourth"
347 "fifth" "sixth" "seventh" "eighth" "ninth"))
349 (defparameter *ordinal-tens*
350 #(nil "tenth" "twentieth" "thirtieth" "fortieth"
351 "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))
353 (defun format-print-small-cardinal (stream n)
354 (multiple-value-bind (hundreds rem) (truncate n 100)
355 (when (plusp hundreds)
356 (write-string (svref *cardinal-ones* hundreds) stream)
357 (write-string " hundred" stream)
358 (when (plusp rem)
359 (write-char #\space stream)))
360 (when (plusp rem)
361 (multiple-value-bind (tens ones) (truncate rem 10)
362 (cond ((< 1 tens)
363 (write-string (svref *cardinal-tens* tens) stream)
364 (when (plusp ones)
365 (write-char #\- stream)
366 (write-string (svref *cardinal-ones* ones) stream)))
367 ((= tens 1)
368 (write-string (svref *cardinal-teens* ones) stream))
369 ((plusp ones)
370 (write-string (svref *cardinal-ones* ones) stream)))))))
372 (defun format-print-cardinal (stream n)
373 (cond ((minusp n)
374 (write-string "negative " stream)
375 (format-print-cardinal-aux stream (- n) 0 n))
376 ((zerop n)
377 (write-string "zero" stream))
379 (format-print-cardinal-aux stream n 0 n))))
381 (defun format-print-cardinal-aux (stream n period err)
382 (multiple-value-bind (beyond here) (truncate n 1000)
383 (unless (<= period 21)
384 (error "number too large to print in English: ~:D" err))
385 (unless (zerop beyond)
386 (format-print-cardinal-aux stream beyond (1+ period) err))
387 (unless (zerop here)
388 (unless (zerop beyond)
389 (write-char #\space stream))
390 (format-print-small-cardinal stream here)
391 (write-string (svref *cardinal-periods* period) stream))))
393 (defun format-print-ordinal (stream n)
394 (when (minusp n)
395 (write-string "negative " stream))
396 (let ((number (abs n)))
397 (multiple-value-bind (top bot) (truncate number 100)
398 (unless (zerop top)
399 (format-print-cardinal stream (- number bot)))
400 (when (and (plusp top) (plusp bot))
401 (write-char #\space stream))
402 (multiple-value-bind (tens ones) (truncate bot 10)
403 (cond ((= bot 12) (write-string "twelfth" stream))
404 ((= tens 1)
405 (write-string (svref *cardinal-teens* ones) stream);;;RAD
406 (write-string "th" stream))
407 ((and (zerop tens) (plusp ones))
408 (write-string (svref *ordinal-ones* ones) stream))
409 ((and (zerop ones)(plusp tens))
410 (write-string (svref *ordinal-tens* tens) stream))
411 ((plusp bot)
412 (write-string (svref *cardinal-tens* tens) stream)
413 (write-char #\- stream)
414 (write-string (svref *ordinal-ones* ones) stream))
415 ((plusp number)
416 (write-string "th" stream))
418 (write-string "zeroth" stream)))))))
420 ;;; Print Roman numerals
422 (defun format-print-old-roman (stream n)
423 (unless (< 0 n 5000)
424 (error "Number too large to print in old Roman numerals: ~:D" n))
425 (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
426 (val-list '(500 100 50 10 5 1) (cdr val-list))
427 (cur-char #\M (car char-list))
428 (cur-val 1000 (car val-list))
429 (start n (do ((i start (progn
430 (write-char cur-char stream)
431 (- i cur-val))))
432 ((< i cur-val) i))))
433 ((zerop start))))
435 (defun format-print-roman (stream n)
436 (unless (< 0 n 4000)
437 (error "Number too large to print in Roman numerals: ~:D" n))
438 (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
439 (val-list '(500 100 50 10 5 1) (cdr val-list))
440 (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
441 (sub-val '(100 10 10 1 1 0) (cdr sub-val))
442 (cur-char #\M (car char-list))
443 (cur-val 1000 (car val-list))
444 (cur-sub-char #\C (car sub-chars))
445 (cur-sub-val 100 (car sub-val))
446 (start n (do ((i start (progn
447 (write-char cur-char stream)
448 (- i cur-val))))
449 ((< i cur-val)
450 (cond ((<= (- cur-val cur-sub-val) i)
451 (write-char cur-sub-char stream)
452 (write-char cur-char stream)
453 (- i (- cur-val cur-sub-val)))
454 (t i))))))
455 ((zerop start))))
457 ;;;; plural
459 (def-format-interpreter #\P (colonp atsignp params)
460 (interpret-bind-defaults () params
461 (let ((arg (if colonp
462 (if (eq orig-args args)
463 (error 'format-error
464 :complaint "no previous argument")
465 (do ((arg-ptr orig-args (cdr arg-ptr)))
466 ((eq (cdr arg-ptr) args)
467 (car arg-ptr))))
468 (next-arg))))
469 (if atsignp
470 (write-string (if (eql arg 1) "y" "ies") stream)
471 (unless (eql arg 1) (write-char #\s stream))))))
473 ;;;; format interpreters and support functions for floating point output
475 (defun decimal-string (n)
476 (write-to-string n :base 10 :radix nil :escape nil))
478 (def-format-interpreter #\F (colonp atsignp params)
479 (when colonp
480 (error 'format-error
481 :complaint
482 "cannot specify the colon modifier with this directive"))
483 (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
484 params
485 (format-fixed stream (next-arg) w d k ovf pad atsignp)))
487 (defun format-fixed (stream number w d k ovf pad atsign)
488 (typecase number
489 (float
490 (format-fixed-aux stream number w d k ovf pad atsign))
491 (rational
492 (format-fixed-aux stream (coerce number 'single-float)
493 w d k ovf pad atsign))
494 (number
495 (format-write-field stream (decimal-string number) w 1 0 #\space t))
497 (format-princ stream number nil nil w 1 0 pad))))
499 ;;; We return true if we overflowed, so that ~G can output the overflow char
500 ;;; instead of spaces.
501 (defun format-fixed-aux (stream number w d k ovf pad atsign)
502 (declare (type float number))
503 (cond
504 ((or (float-infinity-p number)
505 (float-nan-p number))
506 (prin1 number stream)
507 nil)
509 (sb!impl::string-dispatch (single-float double-float)
510 number
511 (let ((spaceleft w))
512 (when (and w (or atsign (minusp (float-sign number))))
513 (decf spaceleft))
514 (multiple-value-bind (str len lpoint tpoint)
515 (sb!impl::flonum-to-string (abs number) spaceleft d k)
516 ;; if caller specifically requested no fraction digits, suppress the
517 ;; optional trailing zero
518 (when (and d (zerop d))
519 (setq tpoint nil))
520 (when w
521 (decf spaceleft len)
522 ;; optional leading zero
523 (when lpoint
524 (if (or (> spaceleft 0) tpoint) ;force at least one digit
525 (decf spaceleft)
526 (setq lpoint nil)))
527 ;; optional trailing zero
528 (when tpoint
529 (if (> spaceleft 0)
530 (decf spaceleft)
531 (setq tpoint nil))))
532 (cond ((and w (< spaceleft 0) ovf)
533 ;; field width overflow
534 (dotimes (i w)
535 (write-char ovf stream))
538 (when w
539 (dotimes (i spaceleft)
540 (write-char pad stream)))
541 (if (minusp (float-sign number))
542 (write-char #\- stream)
543 (when atsign
544 (write-char #\+ stream)))
545 (when lpoint
546 (write-char #\0 stream))
547 (write-string str stream)
548 (when tpoint
549 (write-char #\0 stream))
550 nil))))))))
552 (def-format-interpreter #\E (colonp atsignp params)
553 (when colonp
554 (error 'format-error
555 :complaint
556 "cannot specify the colon modifier with this directive"))
557 (interpret-bind-defaults
558 ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
559 params
560 (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
562 (defun format-exponential (stream number w d e k ovf pad marker atsign)
563 (if (numberp number)
564 (if (floatp number)
565 (format-exp-aux stream number w d e k ovf pad marker atsign)
566 (if (rationalp number)
567 (format-exp-aux stream
568 (coerce number 'single-float)
569 w d e k ovf pad marker atsign)
570 (format-write-field stream
571 (decimal-string number)
572 w 1 0 #\space t)))
573 (format-princ stream number nil nil w 1 0 pad)))
575 (defun format-exponent-marker (number)
576 (if (typep number *read-default-float-format*)
578 (typecase number
579 (single-float #\f)
580 (double-float #\d)
581 (short-float #\s)
582 (long-float #\l))))
584 ;;; Here we prevent the scale factor from shifting all significance out of
585 ;;; a number to the right. We allow insignificant zeroes to be shifted in
586 ;;; to the left right, athough it is an error to specify k and d such that this
587 ;;; occurs. Perhaps we should detect both these condtions and flag them as
588 ;;; errors. As for now, we let the user get away with it, and merely guarantee
589 ;;; that at least one significant digit will appear.
591 ;;; Raymond Toy writes: The Hyperspec seems to say that the exponent
592 ;;; marker is always printed. Make it so. Also, the original version
593 ;;; causes errors when printing infinities or NaN's. The Hyperspec is
594 ;;; silent here, so let's just print out infinities and NaN's instead
595 ;;; of causing an error.
596 (defun format-exp-aux (stream number w d e k ovf pad marker atsign)
597 (declare (type float number))
598 (if (or (float-infinity-p number)
599 (float-nan-p number))
600 (prin1 number stream)
601 (multiple-value-bind (num expt) (sb!impl::scale-exponent (abs number))
602 (let* ((expt (- expt k))
603 (estr (decimal-string (abs expt)))
604 (elen (if e (max (length estr) e) (length estr)))
605 spaceleft)
606 (when w
607 (setf spaceleft (- w 2 elen))
608 (when (or atsign (minusp (float-sign number)))
609 (decf spaceleft)))
610 (if (and w ovf e (> elen e)) ;exponent overflow
611 (dotimes (i w) (write-char ovf stream))
612 (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
613 (fmin (if (minusp k) 1 fdig)))
614 (multiple-value-bind (fstr flen lpoint tpoint)
615 (sb!impl::flonum-to-string num spaceleft fdig k fmin)
616 (when (and d (zerop d)) (setq tpoint nil))
617 (when w
618 (decf spaceleft flen)
619 ;; See CLHS 22.3.3.2. "If the parameter d is
620 ;; omitted, ... [and] if the fraction to be
621 ;; printed is zero then a single zero digit should
622 ;; appear after the decimal point." So we need to
623 ;; subtract one from here because we're going to
624 ;; add an extra 0 digit later. [rtoy]
625 (when (and (zerop number) (null d))
626 (decf spaceleft))
627 (when lpoint
628 (if (or (> spaceleft 0) tpoint)
629 (decf spaceleft)
630 (setq lpoint nil)))
631 (when (and tpoint (<= spaceleft 0))
632 (setq tpoint nil)))
633 (cond ((and w (< spaceleft 0) ovf)
634 ;;significand overflow
635 (dotimes (i w) (write-char ovf stream)))
636 (t (when w
637 (dotimes (i spaceleft) (write-char pad stream)))
638 (if (minusp (float-sign number))
639 (write-char #\- stream)
640 (if atsign (write-char #\+ stream)))
641 (when lpoint (write-char #\0 stream))
642 (write-string fstr stream)
643 (when (and (zerop number) (null d))
644 ;; It's later and we're adding the zero
645 ;; digit.
646 (write-char #\0 stream))
647 (write-char (if marker
648 marker
649 (format-exponent-marker number))
650 stream)
651 (write-char (if (minusp expt) #\- #\+) stream)
652 (when e
653 ;;zero-fill before exponent if necessary
654 (dotimes (i (- e (length estr)))
655 (write-char #\0 stream)))
656 (write-string estr stream))))))))))
658 (def-format-interpreter #\G (colonp atsignp params)
659 (when colonp
660 (error 'format-error
661 :complaint
662 "cannot specify the colon modifier with this directive"))
663 (interpret-bind-defaults
664 ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
665 params
666 (format-general stream (next-arg) w d e k ovf pad mark atsignp)))
668 (defun format-general (stream number w d e k ovf pad marker atsign)
669 (if (numberp number)
670 (if (floatp number)
671 (format-general-aux stream number w d e k ovf pad marker atsign)
672 (if (rationalp number)
673 (format-general-aux stream
674 (coerce number 'single-float)
675 w d e k ovf pad marker atsign)
676 (format-write-field stream
677 (decimal-string number)
678 w 1 0 #\space t)))
679 (format-princ stream number nil nil w 1 0 pad)))
681 ;;; Raymond Toy writes: same change as for format-exp-aux
682 (defun format-general-aux (stream number w d e k ovf pad marker atsign)
683 (declare (type float number))
684 (if (or (float-infinity-p number)
685 (float-nan-p number))
686 (prin1 number stream)
687 (multiple-value-bind (ignore n) (sb!impl::scale-exponent (abs number))
688 (declare (ignore ignore))
689 ;; KLUDGE: Default d if omitted. The procedure is taken directly from
690 ;; the definition given in the manual, and is not very efficient, since
691 ;; we generate the digits twice. Future maintainers are encouraged to
692 ;; improve on this. -- rtoy?? 1998??
693 (unless d
694 (multiple-value-bind (str len)
695 (sb!impl::flonum-to-string (abs number))
696 (declare (ignore str))
697 (let ((q (if (= len 1) 1 (1- len))))
698 (setq d (max q (min n 7))))))
699 (let* ((ee (if e (+ e 2) 4))
700 (ww (if w (- w ee) nil))
701 (dd (- d n)))
702 (cond ((<= 0 dd d)
703 (let ((char (if (format-fixed-aux stream number ww dd nil
704 ovf pad atsign)
706 #\space)))
707 (dotimes (i ee) (write-char char stream))))
709 (format-exp-aux stream number w d e (or k 1)
710 ovf pad marker atsign)))))))
712 (def-format-interpreter #\$ (colonp atsignp params)
713 (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
714 (format-dollars stream (next-arg) d n w pad colonp atsignp)))
716 (defun format-dollars (stream number d n w pad colon atsign)
717 (when (rationalp number)
718 ;; This coercion to SINGLE-FLOAT seems as though it gratuitously
719 ;; loses precision (why not LONG-FLOAT?) but it's the default
720 ;; behavior in the ANSI spec, so in some sense it's the right
721 ;; thing, and at least the user shouldn't be surprised.
722 (setq number (coerce number 'single-float)))
723 (if (floatp number)
724 (let* ((signstr (if (minusp (float-sign number))
726 (if atsign "+" "")))
727 (signlen (length signstr)))
728 (multiple-value-bind (str strlen ig2 ig3 pointplace)
729 (sb!impl::flonum-to-string number nil d nil)
730 (declare (ignore ig2 ig3 strlen))
731 (when colon
732 (write-string signstr stream))
733 (dotimes (i (- w signlen (max n pointplace) 1 d))
734 (write-char pad stream))
735 (unless colon
736 (write-string signstr stream))
737 (dotimes (i (- n pointplace))
738 (write-char #\0 stream))
739 (write-string str stream)))
740 (format-write-field stream
741 (decimal-string number)
742 w 1 0 #\space t)))
744 ;;;; FORMAT interpreters and support functions for line/page breaks etc.
746 (def-format-interpreter #\% (colonp atsignp params)
747 (when (or colonp atsignp)
748 (error 'format-error
749 :complaint
750 "cannot specify either colon or atsign for this directive"))
751 (interpret-bind-defaults ((count 1)) params
752 (dotimes (i count)
753 (terpri stream))))
755 (def-format-interpreter #\& (colonp atsignp params)
756 (when (or colonp atsignp)
757 (error 'format-error
758 :complaint
759 "cannot specify either colon or atsign for this directive"))
760 (interpret-bind-defaults ((count 1)) params
761 (fresh-line stream)
762 (dotimes (i (1- count))
763 (terpri stream))))
765 (def-format-interpreter #\| (colonp atsignp params)
766 (when (or colonp atsignp)
767 (error 'format-error
768 :complaint
769 "cannot specify either colon or atsign for this directive"))
770 (interpret-bind-defaults ((count 1)) params
771 (dotimes (i count)
772 (write-char (code-char form-feed-char-code) stream))))
774 (def-format-interpreter #\~ (colonp atsignp params)
775 (when (or colonp atsignp)
776 (error 'format-error
777 :complaint
778 "cannot specify either colon or atsign for this directive"))
779 (interpret-bind-defaults ((count 1)) params
780 (dotimes (i count)
781 (write-char #\~ stream))))
783 (def-complex-format-interpreter #\newline (colonp atsignp params directives)
784 (when (and colonp atsignp)
785 (error 'format-error
786 :complaint
787 "cannot specify both colon and atsign for this directive"))
788 (interpret-bind-defaults () params
789 (when atsignp
790 (write-char #\newline stream)))
791 (if (and (not colonp)
792 directives
793 (simple-string-p (car directives)))
794 (cons (string-left-trim *format-whitespace-chars*
795 (car directives))
796 (cdr directives))
797 directives))
799 ;;;; format interpreters and support functions for tabs and simple pretty
800 ;;;; printing
802 (def-format-interpreter #\T (colonp atsignp params)
803 (if colonp
804 (interpret-bind-defaults ((n 1) (m 1)) params
805 (pprint-tab (if atsignp :section-relative :section) n m stream))
806 (if atsignp
807 (interpret-bind-defaults ((colrel 1) (colinc 1)) params
808 (format-relative-tab stream colrel colinc))
809 (interpret-bind-defaults ((colnum 1) (colinc 1)) params
810 (format-absolute-tab stream colnum colinc)))))
812 (defun output-spaces (stream n)
813 (let ((spaces #.(make-string 100 :initial-element #\space)))
814 (loop
815 (when (< n (length spaces))
816 (return))
817 (write-string spaces stream)
818 (decf n (length spaces)))
819 (write-string spaces stream :end n)))
821 (defun format-relative-tab (stream colrel colinc)
822 (if (sb!pretty:pretty-stream-p stream)
823 (pprint-tab :line-relative colrel colinc stream)
824 (let* ((cur (sb!impl::charpos stream))
825 (spaces (if (and cur (plusp colinc))
826 (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
827 colrel)))
828 (output-spaces stream spaces))))
830 (defun format-absolute-tab (stream colnum colinc)
831 (if (sb!pretty:pretty-stream-p stream)
832 (pprint-tab :line colnum colinc stream)
833 (let ((cur (sb!impl::charpos stream)))
834 (cond ((null cur)
835 (write-string " " stream))
836 ((< cur colnum)
837 (output-spaces stream (- colnum cur)))
839 (unless (zerop colinc)
840 (output-spaces stream
841 (- colinc (rem (- cur colnum) colinc)))))))))
843 (def-format-interpreter #\_ (colonp atsignp params)
844 (interpret-bind-defaults () params
845 (pprint-newline (if colonp
846 (if atsignp
847 :mandatory
848 :fill)
849 (if atsignp
850 :miser
851 :linear))
852 stream)))
854 (def-format-interpreter #\I (colonp atsignp params)
855 (when atsignp
856 (error 'format-error
857 :complaint "cannot specify the at-sign modifier"))
858 (interpret-bind-defaults ((n 0)) params
859 (pprint-indent (if colonp :current :block) n stream)))
861 ;;;; format interpreter for ~*
863 (def-format-interpreter #\* (colonp atsignp params)
864 (if atsignp
865 (if colonp
866 (error 'format-error
867 :complaint "cannot specify both colon and at-sign")
868 (interpret-bind-defaults ((posn 0)) params
869 (if (<= 0 posn (length orig-args))
870 (setf args (nthcdr posn orig-args))
871 (error 'format-error
872 :complaint "Index ~W is out of bounds. (It should ~
873 have been between 0 and ~W.)"
874 :args (list posn (length orig-args))))))
875 (if colonp
876 (interpret-bind-defaults ((n 1)) params
877 (do ((cur-posn 0 (1+ cur-posn))
878 (arg-ptr orig-args (cdr arg-ptr)))
879 ((eq arg-ptr args)
880 (let ((new-posn (- cur-posn n)))
881 (if (<= 0 new-posn (length orig-args))
882 (setf args (nthcdr new-posn orig-args))
883 (error 'format-error
884 :complaint
885 "Index ~W is out of bounds. (It should
886 have been between 0 and ~W.)"
887 :args
888 (list new-posn (length orig-args))))))))
889 (interpret-bind-defaults ((n 1)) params
890 (dotimes (i n)
891 (next-arg))))))
893 ;;;; format interpreter for indirection
895 (def-format-interpreter #\? (colonp atsignp params string end)
896 (when colonp
897 (error 'format-error
898 :complaint "cannot specify the colon modifier"))
899 (interpret-bind-defaults () params
900 (handler-bind
901 ((format-error
902 (lambda (condition)
903 (error 'format-error
904 :complaint
905 "~A~%while processing indirect format string:"
906 :args (list condition)
907 :print-banner nil
908 :control-string string
909 :offset (1- end)))))
910 (if atsignp
911 (setf args (%format stream (next-arg) orig-args args))
912 (%format stream (next-arg) (next-arg))))))
914 ;;;; format interpreters for capitalization
916 (def-complex-format-interpreter #\( (colonp atsignp params directives)
917 (let ((close (find-directive directives #\) nil)))
918 (unless close
919 (error 'format-error
920 :complaint "no corresponding close paren"))
921 (interpret-bind-defaults () params
922 (let* ((posn (position close directives))
923 (before (subseq directives 0 posn))
924 (after (nthcdr (1+ posn) directives))
925 (stream (make-case-frob-stream stream
926 (if colonp
927 (if atsignp
928 :upcase
929 :capitalize)
930 (if atsignp
931 :capitalize-first
932 :downcase)))))
933 (setf args (interpret-directive-list stream before orig-args args))
934 after))))
936 (def-complex-format-interpreter #\) ()
937 (error 'format-error
938 :complaint "no corresponding open paren"))
940 ;;;; format interpreters and support functions for conditionalization
942 (def-complex-format-interpreter #\[ (colonp atsignp params directives)
943 (multiple-value-bind (sublists last-semi-with-colon-p remaining)
944 (parse-conditional-directive directives)
945 (setf args
946 (if atsignp
947 (if colonp
948 (error 'format-error
949 :complaint
950 "cannot specify both the colon and at-sign modifiers")
951 (if (cdr sublists)
952 (error 'format-error
953 :complaint
954 "can only specify one section")
955 (interpret-bind-defaults () params
956 (let ((prev-args args)
957 (arg (next-arg)))
958 (if arg
959 (interpret-directive-list stream
960 (car sublists)
961 orig-args
962 prev-args)
963 args)))))
964 (if colonp
965 (if (= (length sublists) 2)
966 (interpret-bind-defaults () params
967 (if (next-arg)
968 (interpret-directive-list stream (car sublists)
969 orig-args args)
970 (interpret-directive-list stream (cadr sublists)
971 orig-args args)))
972 (error 'format-error
973 :complaint
974 "must specify exactly two sections"))
975 (interpret-bind-defaults ((index (next-arg))) params
976 (let* ((default (and last-semi-with-colon-p
977 (pop sublists)))
978 (last (1- (length sublists)))
979 (sublist
980 (if (<= 0 index last)
981 (nth (- last index) sublists)
982 default)))
983 (interpret-directive-list stream sublist orig-args
984 args))))))
985 remaining))
987 (def-complex-format-interpreter #\; ()
988 (error 'format-error
989 :complaint
990 "~~; not contained within either ~~[...~~] or ~~<...~~>"))
992 (def-complex-format-interpreter #\] ()
993 (error 'format-error
994 :complaint
995 "no corresponding open bracket"))
997 ;;;; format interpreter for up-and-out
999 (defvar *outside-args*)
1001 (def-format-interpreter #\^ (colonp atsignp params)
1002 (when atsignp
1003 (error 'format-error
1004 :complaint "cannot specify the at-sign modifier"))
1005 (when (and colonp (not *up-up-and-out-allowed*))
1006 (error 'format-error
1007 :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
1008 (when (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
1009 (cond (arg3 (<= arg1 arg2 arg3))
1010 (arg2 (eql arg1 arg2))
1011 (arg1 (eql arg1 0))
1012 (t (if colonp
1013 (null *outside-args*)
1014 (null args)))))
1015 (throw (if colonp 'up-up-and-out 'up-and-out)
1016 args)))
1018 ;;;; format interpreters for iteration
1020 (def-complex-format-interpreter #\{
1021 (colonp atsignp params string end directives)
1022 (let ((close (find-directive directives #\} nil)))
1023 (unless close
1024 (error 'format-error
1025 :complaint
1026 "no corresponding close brace"))
1027 (interpret-bind-defaults ((max-count nil)) params
1028 (let* ((closed-with-colon (format-directive-colonp close))
1029 (posn (position close directives))
1030 (insides (if (zerop posn)
1031 (next-arg)
1032 (subseq directives 0 posn)))
1033 (*up-up-and-out-allowed* colonp))
1034 (labels
1035 ((do-guts (orig-args args)
1036 (if (zerop posn)
1037 (handler-bind
1038 ((format-error
1039 (lambda (condition)
1040 (error
1041 'format-error
1042 :complaint
1043 "~A~%while processing indirect format string:"
1044 :args (list condition)
1045 :print-banner nil
1046 :control-string string
1047 :offset (1- end)))))
1048 (%format stream insides orig-args args))
1049 (interpret-directive-list stream insides
1050 orig-args args)))
1051 (bind-args (orig-args args)
1052 (if colonp
1053 (let* ((arg (next-arg))
1054 (*logical-block-popper* nil)
1055 (*outside-args* args))
1056 (catch 'up-and-out
1057 (do-guts arg arg))
1058 args)
1059 (do-guts orig-args args)))
1060 (do-loop (orig-args args)
1061 (catch (if colonp 'up-up-and-out 'up-and-out)
1062 (loop
1063 (when (and (not closed-with-colon) (null args))
1064 (return))
1065 (when (and max-count (minusp (decf max-count)))
1066 (return))
1067 (setf args (bind-args orig-args args))
1068 (when (and closed-with-colon (null args))
1069 (return)))
1070 args)))
1071 (if atsignp
1072 (setf args (do-loop orig-args args))
1073 (let ((arg (next-arg))
1074 (*logical-block-popper* nil))
1075 (do-loop arg arg)))
1076 (nthcdr (1+ posn) directives))))))
1078 (def-complex-format-interpreter #\} ()
1079 (error 'format-error
1080 :complaint "no corresponding open brace"))
1082 ;;;; format interpreters and support functions for justification
1084 (def-complex-format-interpreter #\<
1085 (colonp atsignp params string end directives)
1086 (multiple-value-bind (segments first-semi close remaining)
1087 (parse-format-justification directives)
1088 (setf args
1089 (if (format-directive-colonp close)
1090 (multiple-value-bind (prefix per-line-p insides suffix)
1091 (parse-format-logical-block segments colonp first-semi
1092 close params string end)
1093 (interpret-format-logical-block stream orig-args args
1094 prefix per-line-p insides
1095 suffix atsignp))
1096 (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
1097 (when (> count 0)
1098 ;; ANSI specifies that "an error is signalled" in this
1099 ;; situation.
1100 (error 'format-error
1101 :complaint "~D illegal directive~:P found inside justification block"
1102 :args (list count)
1103 :references (list '(:ansi-cl :section (22 3 5 2)))))
1104 (interpret-format-justification stream orig-args args
1105 segments colonp atsignp
1106 first-semi params))))
1107 remaining))
1109 (defun interpret-format-justification
1110 (stream orig-args args segments colonp atsignp first-semi params)
1111 (interpret-bind-defaults
1112 ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
1113 params
1114 (let ((newline-string nil)
1115 (strings nil)
1116 (extra-space 0)
1117 (line-len 0))
1118 (setf args
1119 (catch 'up-and-out
1120 (when (and first-semi (format-directive-colonp first-semi))
1121 (interpret-bind-defaults
1122 ((extra 0)
1123 (len (or (sb!impl::line-length stream) 72)))
1124 (format-directive-params first-semi)
1125 (setf newline-string
1126 (with-output-to-string (stream)
1127 (setf args
1128 (interpret-directive-list stream
1129 (pop segments)
1130 orig-args
1131 args))))
1132 (setf extra-space extra)
1133 (setf line-len len)))
1134 (dolist (segment segments)
1135 (push (with-output-to-string (stream)
1136 (setf args
1137 (interpret-directive-list stream segment
1138 orig-args args)))
1139 strings))
1140 args))
1141 (format-justification stream newline-string extra-space line-len strings
1142 colonp atsignp mincol colinc minpad padchar)))
1143 args)
1145 (defun format-justification (stream newline-prefix extra-space line-len strings
1146 pad-left pad-right mincol colinc minpad padchar)
1147 (setf strings (reverse strings))
1148 (let* ((num-gaps (+ (1- (length strings))
1149 (if pad-left 1 0)
1150 (if pad-right 1 0)))
1151 (chars (+ (* num-gaps minpad)
1152 (loop
1153 for string in strings
1154 summing (length string))))
1155 (length (if (> chars mincol)
1156 (+ mincol (* (ceiling (- chars mincol) colinc) colinc))
1157 mincol))
1158 (padding (+ (- length chars) (* num-gaps minpad))))
1159 (when (and newline-prefix
1160 (> (+ (or (sb!impl::charpos stream) 0)
1161 length extra-space)
1162 line-len))
1163 (write-string newline-prefix stream))
1164 (flet ((do-padding ()
1165 (let ((pad-len
1166 (if (zerop num-gaps) padding (truncate padding num-gaps))))
1167 (decf padding pad-len)
1168 (decf num-gaps)
1169 (dotimes (i pad-len) (write-char padchar stream)))))
1170 (when (or pad-left (and (not pad-right) (null (cdr strings))))
1171 (do-padding))
1172 (when strings
1173 (write-string (car strings) stream)
1174 (dolist (string (cdr strings))
1175 (do-padding)
1176 (write-string string stream)))
1177 (when pad-right
1178 (do-padding)))))
1180 (defun interpret-format-logical-block
1181 (stream orig-args args prefix per-line-p insides suffix atsignp)
1182 (let ((arg (if atsignp args (next-arg))))
1183 (if per-line-p
1184 (pprint-logical-block
1185 (stream arg :per-line-prefix prefix :suffix suffix)
1186 (let ((*logical-block-popper* (lambda () (pprint-pop))))
1187 (catch 'up-and-out
1188 (interpret-directive-list stream insides
1189 (if atsignp orig-args arg)
1190 arg))))
1191 (pprint-logical-block (stream arg :prefix prefix :suffix suffix)
1192 (let ((*logical-block-popper* (lambda () (pprint-pop))))
1193 (catch 'up-and-out
1194 (interpret-directive-list stream insides
1195 (if atsignp orig-args arg)
1196 arg))))))
1197 (if atsignp nil args))
1199 ;;;; format interpreter and support functions for user-defined method
1201 (def-format-interpreter #\/ (string start end colonp atsignp params)
1202 (let ((symbol (extract-user-fun-name string start end)))
1203 (collect ((args))
1204 (dolist (param-and-offset params)
1205 (let ((param (cdr param-and-offset)))
1206 (case param
1207 (:arg (args (next-arg)))
1208 (:remaining (args (length args)))
1209 (t (args param)))))
1210 (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args)))))