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