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