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